Imported Upstream snapshot 8.3~beta0+13298

279 files changed, 80280 insertions, 0 deletions

diff --git a/plugins/cc/README b/plugins/cc/README
new file mode 100644
index 00000000..073b140e
--- /dev/null
+++ b/plugins/cc/README
@@ -0,0 +1,20 @@
+
+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/plugins/cc/cc_plugin.mllib b/plugins/cc/cc_plugin.mllib
new file mode 100644
index 00000000..1bcfc537
--- /dev/null
+++ b/plugins/cc/cc_plugin.mllib
@@ -0,0 +1,5 @@
+Ccalgo
+Ccproof
+Cctac
+G_congruence
+Cc_plugin_mod
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml
new file mode 100644
index 00000000..9cc6f9de
--- /dev/null
+++ b/plugins/cc/ccalgo.ml
@@ -0,0 +1,884 @@
+(************************************************************************)
+(*  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$ *)
+
+(* 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=["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/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli
new file mode 100644
index 00000000..5f56c7e6
--- /dev/null
+++ b/plugins/cc/ccalgo.mli
@@ -0,0 +1,222 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml
new file mode 100644
index 00000000..2a019ebf
--- /dev/null
+++ b/plugins/cc/ccproof.ml
@@ -0,0 +1,153 @@
+(************************************************************************)
+(*  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$ *)
+
+(* 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/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli
new file mode 100644
index 00000000..2a0ca688
--- /dev/null
+++ b/plugins/cc/ccproof.mli
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+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/plugins/cc/cctac.ml b/plugins/cc/cctac.ml
new file mode 100644
index 00000000..4e6ea802
--- /dev/null
+++ b/plugins/cc/cctac.ml
@@ -0,0 +1,465 @@
+(************************************************************************)
+(*  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$ *)
+
+(* 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 (sort_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 (decompose_prod_assum ti) in
+    let head=
+      if i=ci then special else default in
+      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/plugins/cc/cctac.mli b/plugins/cc/cctac.mli
new file mode 100644
index 00000000..7ed077bd
--- /dev/null
+++ b/plugins/cc/cctac.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
new file mode 100644
index 00000000..d9db927a
--- /dev/null
+++ b/plugins/cc/g_congruence.ml4
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/dp/Dp.v b/plugins/dp/Dp.v
new file mode 100644
index 00000000..bc7d73f6
--- /dev/null
+++ b/plugins/dp/Dp.v
@@ -0,0 +1,120 @@
+(* Calls to external decision procedures *)
+
+Require Export ZArith.
+Require Export Classical.
+
+(* Zenon *)
+
+(*  Copyright 2004 INRIA  *)
+(*  $Id$  *)
+
+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/plugins/dp/TODO b/plugins/dp/TODO
new file mode 100644
index 00000000..44349e21
--- /dev/null
+++ b/plugins/dp/TODO
@@ -0,0 +1,24 @@
+
+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/plugins/dp/dp.ml b/plugins/dp/dp.ml
new file mode 100644
index 00000000..34b32c0a
--- /dev/null
+++ b/plugins/dp/dp.ml
@@ -0,0 +1,1134 @@
+(* 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 Namegen
+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)}
+
+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)}
+
+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)}
+
+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"; "Reals"; "Rdefinitions"];
+       ["Coq"; "Reals"; "Raxioms";];
+       ["Coq"; "Reals"; "Rbasic_fun";];
+       ["Coq"; "Reals"; "R_sqrt";];
+       ["Coq"; "Reals"; "Rfunctions";]]
+    @ [["Coq"; "omega"; "OmegaLemmas"]]
+
+let constant = gen_constant_in_modules "dp" coq_modules
+
+(* integers constants and operations *)
+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")
+
+(* real constants and operations *)
+let coq_R = lazy (constant "R")
+let coq_R0 = lazy (constant "R0")
+let coq_R1 = lazy (constant "R1")
+let coq_Rgt = lazy (constant "Rgt")
+let coq_Rle = lazy (constant "Rle")
+let coq_Rge = lazy (constant "Rge")
+let coq_Rlt = lazy (constant "Rlt")
+let coq_Rplus = lazy (constant "Rplus")
+let coq_Rmult = lazy (constant "Rmult")
+let coq_Ropp = lazy (constant "Ropp")
+let coq_Rminus = lazy (constant "Rminus")
+let coq_Rdiv = lazy (constant "Rdiv")
+let coq_powerRZ = lazy (constant "powerRZ")
+
+(* 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_subscript 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.basename_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 () -> ()) }
+
+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 big_two = Big_int.succ_big_int Big_int.unit_big_int
+
+let rec tr_positive p = match kind_of_term p with
+  | Term.Construct _ when p = Lazy.force coq_xH ->
+      Big_int.unit_big_int
+  | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
+(*
+      Plus (Mult (Cst 2, tr_positive a), Cst 1)
+*)
+      Big_int.succ_big_int (Big_int.mult_big_int big_two (tr_positive a))
+  | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
+(*
+      Mult (Cst 2, tr_positive a)
+*)
+      Big_int.mult_big_int big_two (tr_positive a)
+  | Term.Cast (p, _, _) ->
+      tr_positive p
+  | _ ->
+      raise NotArithConstant
+
+(* translates a closed Coq term t:Z or R into a FOL term of type int or real *)
+let rec tr_arith_constant t = match kind_of_term t with
+  | Term.Construct _ when t = Lazy.force coq_Z0 ->
+      Cst Big_int.zero_big_int
+  | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos ->
+      Cst (tr_positive a)
+  | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg ->
+      Cst (Big_int.minus_big_int (tr_positive a))
+  | Term.Const _ when t = Lazy.force coq_R0 ->
+      RCst Big_int.zero_big_int
+  | Term.Const _ when t = Lazy.force coq_R1 ->
+      RCst Big_int.unit_big_int
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus ->
+      let ta = tr_arith_constant a in
+      let tb = tr_arith_constant b in
+      begin match ta,tb with
+        | RCst na, RCst nb -> RCst (Big_int.add_big_int na nb)
+        | _ -> raise NotArithConstant
+      end
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult ->
+      let ta = tr_arith_constant a in
+      let tb = tr_arith_constant b in
+      begin match ta,tb with
+        | RCst na, RCst nb -> RCst (Big_int.mult_big_int na nb)
+        | _ -> raise NotArithConstant
+      end
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_powerRZ ->
+      tr_powerRZ a b
+  | Term.Cast (t, _, _) ->
+      tr_arith_constant t
+  | _ ->
+      raise NotArithConstant
+
+(* translates a constant of the form (powerRZ 2 int_constant) *)
+and tr_powerRZ a b =
+  (* checking first that a is (R1 + R1) *)
+  match kind_of_term a with
+  | Term.App (f, [|c;d|]) when f = Lazy.force coq_Rplus ->
+      begin
+      match kind_of_term c,kind_of_term d with
+        | Term.Const _, Term.Const _
+            when c = Lazy.force coq_R1 && d = Lazy.force coq_R1 ->
+            begin
+              match tr_arith_constant b with
+                | Cst n -> Power2 n
+                | _ -> raise NotArithConstant
+            end
+        | _ -> raise NotArithConstant
+      end
+  | _ -> 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 if t = Lazy.force coq_R then
+    Tid ("real", [])
+  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 ->
+        raise NotFO
+        (* [CM 07/09/2009] deactivated because it generates
+           unbound identifiers 'abstraction_<number>'
+	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 =
+      try
+	tr_arith_constant t
+      with NotArithConstant ->
+  match kind_of_term t with
+    (* binary operations on integers *)
+  | 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.App (f, [|a|]) when f = Lazy.force coq_Zopp ->
+      Opp (tr_term tv bv env a)
+    (* binary operations on reals *)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus ->
+      Plus (tr_term tv bv env a, tr_term tv bv env b)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rminus ->
+      Moins (tr_term tv bv env a, tr_term tv bv env b)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult ->
+      Mult (tr_term tv bv env a, tr_term tv bv env b)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rdiv ->
+      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, [])
+  | _ ->
+	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
+          (* comparisons on integers *)
+    | _, [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))
+          (* comparisons on reals *)
+    | _, [a;b] when c = Lazy.force coq_Rle ->
+	Fatom (Le (tr_term tv bv env a, tr_term tv bv env b))
+    | _, [a;b] when c = Lazy.force coq_Rlt ->
+	Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b))
+    | _, [a;b] when c = Lazy.force coq_Rge ->
+	Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b))
+    | _, [a;b] when c = Lazy.force coq_Rgt ->
+	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 | CVC3 | Z3
+
+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 call_prover ?(opt="") file =
+  if !debug then Format.eprintf "calling prover on %s@." file;
+  let out = Filename.temp_file "out" "" in
+  let cmd =
+    sprintf "why-dp -timeout %d -batch %s > %s 2>&1" !timeout file out in
+  match Sys.command cmd with
+      0 -> Valid None
+    | 1 -> Failure (sprintf "could not run why-dp\n%s" (file_contents out))
+    | 2 -> Invalid
+    | 3 -> DontKnow
+    | 4 -> Timeout
+    | 5 -> Failure (sprintf "prover failed:\n%s" (file_contents out))
+    | n -> Failure (sprintf "Unknown exit status of why-dp: %d" n)
+
+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)}
+
+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
+*)
+  let r = call_prover fsx 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*)
+  (*NB: why-dp can't handle -cctrace
+  let cmd =
+    if !trace then
+      sprintf "alt-ergo -cctrace %s %s" ftrace fwhy
+
+    else
+      sprintf "alt-ergo %s" fwhy
+  in*)
+  let r = call_prover fwhy in
+  if not !debug then remove_files [fwhy; (*out*)];
+  r
+
+
+let call_zenon fwhy =
+  let cmd =
+    sprintf "why --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
+(*  why-dp won't let us having coqterm...
+  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 r = call_prover fznn in
+   if not !debug then remove_files [fwhy; fznn];
+   r
+
+let call_smt ~smt 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 opt = "-smt-solver " ^ smt in
+  let r = call_prover ~opt fsmt in
+  if not !debug then remove_files [fwhy; fsmt];
+  r
+
+(*
+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_cvc3 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 cvc3 -lang 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
+*)
+  let r = call_prover fcvc 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];
+*)
+  let r = call_prover frv in
+  if not !debug then remove_files [fwhy; frv];
+  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
+    | CVC3 -> call_smt ~smt:"cvc3" fwhy
+    | Yices -> call_smt ~smt:"yices" fwhy
+    | Z3 -> call_smt ~smt:"z3" 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 cvc3 = tclTHEN intros (dp CVC3)
+let yices = tclTHEN intros (dp Yices)
+let z3 = tclTHEN intros (dp Z3)
+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)}
+
+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)}
+
+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 := []) }
diff --git a/plugins/dp/dp.mli b/plugins/dp/dp.mli
new file mode 100644
index 00000000..f40f8688
--- /dev/null
+++ b/plugins/dp/dp.mli
@@ -0,0 +1,20 @@
+
+open Libnames
+open Proof_type
+
+val simplify : tactic
+val ergo : tactic
+val cvc3 : tactic
+val yices : tactic
+val cvc_lite : tactic
+val harvey : tactic
+val zenon : tactic
+val gwhy : tactic
+val z3: 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/plugins/dp/dp_plugin.mllib b/plugins/dp/dp_plugin.mllib
new file mode 100644
index 00000000..63252d6a
--- /dev/null
+++ b/plugins/dp/dp_plugin.mllib
@@ -0,0 +1,5 @@
+Dp_why
+Dp_zenon
+Dp
+G_dp
+Dp_plugin_mod
diff --git a/plugins/dp/dp_why.ml b/plugins/dp/dp_why.ml
new file mode 100644
index 00000000..9a62f39d
--- /dev/null
+++ b/plugins/dp/dp_why.ml
@@ -0,0 +1,186 @@
+
+(* 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 ("real", []) -> fprintf fmt "real"
+  | 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 print_arg fmt (id,typ) = fprintf fmt "%a: %a" ident id print_typ typ
+
+let rec print_term fmt = function
+  | Cst n ->
+      fprintf fmt "%s" (Big_int.string_of_big_int n)
+  | RCst s ->
+      fprintf fmt "%s.0" (Big_int.string_of_big_int s)
+  | Power2 n ->
+      fprintf fmt "0x1p%s" (Big_int.string_of_big_int 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
+  | Opp (a) ->
+      fprintf fmt "@[(-@ %a)@]" print_term a
+  | 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 rec remove_iff args = function
+    Forall (id,t,p) -> remove_iff ((id,t)::args) p
+  | Iff(_,b) -> List.rev args, b
+  | _ -> raise Not_found
+
+let print_query fmt (decls,concl) =
+  let find_declared_preds l =
+    function
+        DeclPred (id,_,args) -> (id,args) :: l
+      | _ -> l
+  in
+  let find_defined_preds declared l = function
+      Axiom(id,f) ->
+        (try
+           let _decl = List.assoc id declared in
+           (id,remove_iff [] f)::l
+         with Not_found -> l)
+    | _ -> l
+  in
+  let declared_preds =
+    List.fold_left find_declared_preds [] decls in
+  let defined_preds =
+    List.fold_left (find_defined_preds declared_preds) [] decls
+  in
+  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, _, []) when not (List.mem_assoc id defined_preds) ->
+	fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id
+    | DeclPred (id, _, l) when not (List.mem_assoc id defined_preds) ->
+	fprintf fmt "@[logic %a : %a -> prop@]@\n@\n"
+	  ident id (print_list comma print_typ) l
+    | DeclType _ | Axiom _ | DeclPred _ ->
+	()
+  in
+  let print_assert = function
+    | Axiom(id,_) when List.mem_assoc id defined_preds ->
+        let args, def = List.assoc id defined_preds in
+        fprintf fmt "@[predicate %a(%a) =@\n%a@]@\n" ident id
+          (print_list comma print_arg) args print_predicate def  
+    | 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 "include \"real.why\"@.";
+  fprintf fmt "@[%a@]@." print_query q;
+  close_out c
diff --git a/plugins/dp/dp_why.mli b/plugins/dp/dp_why.mli
new file mode 100644
index 00000000..0efa24a2
--- /dev/null
+++ b/plugins/dp/dp_why.mli
@@ -0,0 +1,17 @@
+
+open Fol
+
+(* generation of the Why file *)
+
+val output_file : string -> query -> unit
+
+(* table to translate the proofs back to Coq (used in dp_zenon) *)
+
+type proof =
+  | Immediate of Term.constr
+  | Fun_def of string * (string * typ) list * typ * term
+
+val add_proof : proof -> string
+val find_proof : string -> proof
+
+
diff --git a/plugins/dp/dp_zenon.mli b/plugins/dp/dp_zenon.mli
new file mode 100644
index 00000000..0a727d1f
--- /dev/null
+++ b/plugins/dp/dp_zenon.mli
@@ -0,0 +1,7 @@
+
+open Fol
+
+val set_debug : bool -> unit
+
+val proof_from_file : string -> Proof_type.tactic
+
diff --git a/plugins/dp/dp_zenon.mll b/plugins/dp/dp_zenon.mll
new file mode 100644
index 00000000..949e91e3
--- /dev/null
+++ b/plugins/dp/dp_zenon.mll
@@ -0,0 +1,189 @@
+
+{
+
+  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 "%s" (Big_int.string_of_big_int n)
+      | RCst s ->
+          fprintf fmt "%s" (Big_int.string_of_big_int s)
+      | Power2 n ->
+          fprintf fmt "@[(powerRZ 2 %s)@]" (Big_int.string_of_big_int n)
+
+          (* TODO: bug, it might be operations on reals *)
+      | 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
+      | Opp (a) ->
+	  fprintf fmt "@[(Zopp %a)@]" print_term a
+      | 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/plugins/dp/fol.mli b/plugins/dp/fol.mli
new file mode 100644
index 00000000..4fb763a6
--- /dev/null
+++ b/plugins/dp/fol.mli
@@ -0,0 +1,58 @@
+
+(* Polymorphic First-Order Logic (that is Why's input logic) *)
+
+type typ =
+  | Tvar of string
+  | Tid of string * typ list
+
+type term =
+  | Cst of Big_int.big_int
+  | RCst of Big_int.big_int
+  | Power2 of Big_int.big_int
+  | Plus of term * term
+  | Moins of term * term
+  | Mult of term * term
+  | Div of term * term
+  | Opp of 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/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4
new file mode 100644
index 00000000..82f86cd8
--- /dev/null
+++ b/plugins/dp/g_dp.ml4
@@ -0,0 +1,79 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Dp
+
+TACTIC EXTEND Simplify
+  [ "simplify" ] -> [ simplify ]
+END
+
+TACTIC EXTEND Ergo
+  [ "ergo" ] -> [ ergo ]
+END
+
+TACTIC EXTEND Yices
+  [ "yices" ] -> [ yices ]
+END
+
+TACTIC EXTEND CVC3
+  [ "cvc3" ] -> [ cvc3 ]
+END
+
+TACTIC EXTEND Z3
+  [ "z3" ] -> [ z3 ]
+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
+
+(* 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/plugins/dp/test2.v b/plugins/dp/test2.v
new file mode 100644
index 00000000..0940b135
--- /dev/null
+++ b/plugins/dp/test2.v
@@ -0,0 +1,80 @@
+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/plugins/dp/tests.v b/plugins/dp/tests.v
new file mode 100644
index 00000000..dc85d2ee
--- /dev/null
+++ b/plugins/dp/tests.v
@@ -0,0 +1,300 @@
+
+Require Import ZArith.
+Require Import Classical.
+Require Export Reals.
+
+
+(* real numbers *)
+
+Lemma real_expr: (0 <= 9 * 4)%R.
+ergo.
+Qed.
+
+Lemma powerRZ_translation: (powerRZ 2 15 < powerRZ 2 17)%R.
+ergo.
+Qed.
+
+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 dp/injection 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/plugins/dp/vo.itarget b/plugins/dp/vo.itarget
new file mode 100644
index 00000000..4d282709
--- /dev/null
+++ b/plugins/dp/vo.itarget
@@ -0,0 +1 @@
+Dp.vo
diff --git a/plugins/dp/zenon.v b/plugins/dp/zenon.v
new file mode 100644
index 00000000..502465c6
--- /dev/null
+++ b/plugins/dp/zenon.v
@@ -0,0 +1,94 @@
+(*  Copyright 2004 INRIA  *)
+(*  $Id$  *)
+
+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/plugins/extraction/CHANGES b/plugins/extraction/CHANGES
new file mode 100644
index 00000000..fbcd01a1
--- /dev/null
+++ b/plugins/extraction/CHANGES
@@ -0,0 +1,414 @@
+8.0 -> today
+
+See the main CHANGES file in the archive
+
+
+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: 
+     * plugins/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/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v
new file mode 100644
index 00000000..f0135221
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlBasic.v
@@ -0,0 +1,33 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Extraction to Ocaml : use of basic Ocaml types *)
+
+Extract Inductive bool => bool [ true false ].
+Extract Inductive option => option [ Some None ].
+Extract Inductive unit => unit [ "()" ].
+Extract Inductive list => list [ "[]" "( :: )" ].
+Extract Inductive prod => "( * )" [ "" ].
+
+(** NB: The "" above is a hack, but produce nicer code than "(,)" *)
+
+(** Mapping sumbool to bool and sumor to option is not always nicer,
+    but it helps when realizing stuff like [lt_eq_lt_dec] *)
+
+Extract Inductive sumbool => bool [ true false ].
+Extract Inductive sumor => option [ Some None ].
+
+(** Restore lazyness of andb, orb.
+    NB: without these Extract Constant, andb/orb would be inlined
+    by extraction in order to have lazyness, producing inelegant
+    (if ... then ... else false) and (if ... then true else ...).
+*)
+
+Extract Inlined Constant andb => "(&&)".
+Extract Inlined Constant orb => "(||)".
+
diff --git a/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v
new file mode 100644
index 00000000..b4490545
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlBigIntConv.v
@@ -0,0 +1,108 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Extraction to Ocaml: conversion from/to [big_int] *)
+
+(** NB: The extracted code should be linked with [nums.cm(x)a]
+    from ocaml's stdlib and with the wrapper [big.ml] that
+    simlifies the use of [Big_int] (it could be found in the sources
+    of Coq). *)
+
+Require Import Arith ZArith.
+
+Parameter bigint : Type.
+Parameter bigint_zero : bigint.
+Parameter bigint_succ : bigint -> bigint.
+Parameter bigint_opp : bigint -> bigint.
+Parameter bigint_twice : bigint -> bigint.
+
+Extract Inlined Constant bigint => "Big.big_int".
+Extract Inlined Constant bigint_zero => "Big.zero".
+Extract Inlined Constant bigint_succ => "Big.succ".
+Extract Inlined Constant bigint_opp => "Big.opp".
+Extract Inlined Constant bigint_twice => "Big.double".
+
+Definition bigint_of_nat : nat -> bigint :=
+ (fix loop acc n :=
+  match n with
+   | O => acc
+   | S n => loop (bigint_succ acc) n
+  end) bigint_zero.
+
+Fixpoint bigint_of_pos p :=
+ match p with
+  | xH => bigint_succ bigint_zero
+  | xO p => bigint_twice (bigint_of_pos p)
+  | xI p => bigint_succ (bigint_twice (bigint_of_pos p))
+ end.
+
+Fixpoint bigint_of_z z :=
+ match z with
+  | Z0 => bigint_zero
+  | Zpos p => bigint_of_pos p
+  | Zneg p => bigint_opp (bigint_of_pos p)
+ end.
+
+Fixpoint bigint_of_n n :=
+ match n with
+  | N0 => bigint_zero
+  | Npos p => bigint_of_pos p
+ end.
+
+(** NB: as for [pred] or [minus], [nat_of_bigint], [n_of_bigint] and
+    [pos_of_bigint] are total and return zero (resp. one) for
+    non-positive inputs. *)
+
+Parameter bigint_natlike_rec : forall A, A -> (A->A) -> bigint -> A.
+Extract Constant bigint_natlike_rec => "Big.nat_rec".
+
+Definition nat_of_bigint : bigint -> nat := bigint_natlike_rec _ O S.
+
+Parameter bigint_poslike_rec : forall A, (A->A) -> (A->A) -> A -> bigint -> A.
+Extract Constant bigint_poslike_rec => "Big.positive_rec".
+
+Definition pos_of_bigint : bigint -> positive := bigint_poslike_rec _ xI xO xH.
+
+Parameter bigint_zlike_case :
+ forall A, A -> (bigint->A) -> (bigint->A) -> bigint -> A.
+Extract Constant bigint_zlike_case => "Big.z_rec".
+
+Definition z_of_bigint : bigint -> Z :=
+ bigint_zlike_case _ Z0 (fun i => Zpos (pos_of_bigint i))
+                        (fun i => Zneg (pos_of_bigint i)).
+
+Definition n_of_bigint : bigint -> N :=
+ bigint_zlike_case _ N0 (fun i => Npos (pos_of_bigint i)) (fun _ => N0).
+
+(* Tests:
+
+Definition small := 1234%nat.
+Definition big := 12345678901234567890%positive.
+
+Definition nat_0 := nat_of_bigint (bigint_of_nat 0).
+Definition nat_1 := nat_of_bigint (bigint_of_nat small).
+Definition pos_1 := pos_of_bigint (bigint_of_pos 1).
+Definition pos_2 := pos_of_bigint (bigint_of_pos big).
+Definition n_0 := n_of_bigint (bigint_of_n 0).
+Definition n_1 := n_of_bigint (bigint_of_n 1).
+Definition n_2 := n_of_bigint (bigint_of_n (Npos big)).
+Definition z_0 := z_of_bigint (bigint_of_z 0).
+Definition z_1 := z_of_bigint (bigint_of_z 1).
+Definition z_2 := z_of_bigint (bigint_of_z (Zpos big)).
+Definition z_m1 := z_of_bigint (bigint_of_z (-1)).
+Definition z_m2 := z_of_bigint (bigint_of_z (Zneg big)).
+
+Definition test :=
+ (nat_0, nat_1, pos_1, pos_2, n_0, n_1, n_2, z_0, z_1, z_2, z_m1, z_m2).
+Definition check :=
+ (O, small, xH, big, 0%N, 1%N, Npos big, 0%Z, 1%Z, Zpos big, (-1)%Z, Zneg big).
+
+Extraction "/tmp/test.ml" check test.
+
+... and we check that test=check
+*)
\ No newline at end of file
diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v
new file mode 100644
index 00000000..e729d9ca
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlIntConv.v
@@ -0,0 +1,97 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Extraction to Ocaml: conversion from/to [int]
+
+    Nota: no check that [int] values aren't generating overflows *)
+
+Require Import Arith ZArith.
+
+Parameter int : Type.
+Parameter int_zero : int.
+Parameter int_succ : int -> int.
+Parameter int_opp : int -> int.
+Parameter int_twice : int -> int.
+
+Extract Inlined Constant int => int.
+Extract Inlined Constant int_zero => "0".
+Extract Inlined Constant int_succ => "succ".
+Extract Inlined Constant int_opp => "-".
+Extract Inlined Constant int_twice => "2 *".
+
+Definition int_of_nat : nat -> int :=
+ (fix loop acc n :=
+  match n with
+   | O => acc
+   | S n => loop (int_succ acc) n
+  end) int_zero.
+
+Fixpoint int_of_pos p :=
+ match p with
+  | xH => int_succ int_zero
+  | xO p => int_twice (int_of_pos p)
+  | xI p => int_succ (int_twice (int_of_pos p))
+ end.
+
+Fixpoint int_of_z z :=
+ match z with
+  | Z0 => int_zero
+  | Zpos p => int_of_pos p
+  | Zneg p => int_opp (int_of_pos p)
+ end.
+
+Fixpoint int_of_n n :=
+ match n with
+  | N0 => int_zero
+  | Npos p => int_of_pos p
+ end.
+
+(** NB: as for [pred] or [minus], [nat_of_int], [n_of_int] and
+    [pos_of_int] are total and return zero (resp. one) for
+    non-positive inputs. *)
+
+Parameter int_natlike_rec : forall A, A -> (A->A) -> int -> A.
+Extract Constant int_natlike_rec =>
+"fun fO fS ->
+ let rec loop acc i = if i <= 0 then acc else loop (fS acc) (i-1)
+ in loop fO".
+
+Definition nat_of_int : int -> nat := int_natlike_rec _ O S.
+
+Parameter int_poslike_rec : forall A, A -> (A->A) -> (A->A) -> int -> A.
+Extract Constant int_poslike_rec =>
+"fun f1 f2x f2x1 ->
+ let rec loop i = if i <= 1 then f1 else
+  if i land 1 = 0 then f2x (loop (i lsr 1)) else f2x1 (loop (i lsr 1))
+ in loop".
+
+Definition pos_of_int : int -> positive := int_poslike_rec _ xH xO xI.
+
+Parameter int_zlike_case : forall A, A -> (int->A) -> (int->A) -> int -> A.
+Extract Constant int_zlike_case =>
+"fun f0 fpos fneg i ->
+ if i = 0 then f0 else if i>0 then fpos i else fneg (-i)".
+
+Definition z_of_int : int -> Z :=
+ int_zlike_case _ Z0 (fun i => Zpos (pos_of_int i))
+                     (fun i => Zneg (pos_of_int i)).
+
+Definition n_of_int : int -> N :=
+ int_zlike_case _ N0 (fun i => Npos (pos_of_int i)) (fun _ => N0).
+
+(** Warning: [z_of_int] is currently wrong for Ocaml's [min_int],
+    since [min_int] has no positive opposite ([-min_int = min_int]).
+*)
+
+(*
+Extraction "/tmp/test.ml"
+  nat_of_int int_of_nat
+  pos_of_int int_of_pos
+  z_of_int int_of_z
+  n_of_int int_of_n.
+*)
\ No newline at end of file
diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v
new file mode 100644
index 00000000..491e0258
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlNatBigInt.v
@@ -0,0 +1,69 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Extraction of [nat] into Ocaml's [big_int] *)
+
+Require Import Arith Even Div2 EqNat MinMax Euclid.
+Require Import ExtrOcamlBasic.
+
+(** NB: The extracted code should be linked with [nums.cm(x)a]
+    from ocaml's stdlib and with the wrapper [big.ml] that
+    simlifies the use of [Big_int] (it could be found in the sources
+    of Coq). *)
+
+(** Disclaimer: trying to obtain efficient certified programs
+    by extracting [nat] into [big_int] isn't necessarily a good idea.
+    See comments in [ExtrOcamlNatInt.v].
+*)
+
+
+(** Mapping of [nat] into [big_int]. The last string corresponds to
+    a [nat_case], see documentation of [Extract Inductive]. *)
+
+Extract Inductive nat => "Big.big_int" [ "Big.zero" "Big.succ" ]
+ "Big.nat_case".
+
+(** Efficient (but uncertified) versions for usual [nat] functions *)
+
+Extract Constant plus => "Big.add".
+Extract Constant mult => "Big.mult".
+Extract Constant pred => "fun n -> Big.max Big.zero (Big.pred n)".
+Extract Constant minus => "fun n m -> Big.max Big.zero (Big.sub n m)".
+Extract Constant max => "Big.max".
+Extract Constant min => "Big.min".
+Extract Constant nat_beq => "Big.eq".
+Extract Constant EqNat.beq_nat => "Big.eq".
+Extract Constant EqNat.eq_nat_decide => "Big.eq".
+
+Extract Constant Peano_dec.eq_nat_dec => "Big.eq".
+
+Extract Constant Compare_dec.nat_compare =>
+ "Big.compare_case Eq Lt Gt".
+
+Extract Constant Compare_dec.leb => "Big.le".
+Extract Constant Compare_dec.le_lt_dec => "Big.le".
+Extract Constant Compare_dec.lt_eq_lt_dec =>
+ "Big.compare_case (Some false) (Some true) None".
+
+Extract Constant Even.even_odd_dec =>
+ "fun n -> Big.sign (Big.mod n Big.two) = 0".
+Extract Constant Div2.div2 => "fun n -> Big.div n Big.two".
+
+Extract Inductive Euclid.diveucl => "(Big.big_int * Big.big_int)" [""].
+Extract Constant Euclid.eucl_dev => "fun n m -> Big.quomod m n".
+Extract Constant Euclid.quotient => "fun n m -> Big.div m n".
+Extract Constant Euclid.modulo => "fun n m -> Big.modulo m n".
+
+(*
+Require Import Euclid.
+Definition test n m (H:m>0) :=
+ let (q,r,_,_) := eucl_dev m H n in
+ nat_compare n (q*m+r).
+
+Extraction "/tmp/test.ml" test fact pred minus max min Div2.div2.
+*)
diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v
new file mode 100644
index 00000000..fe03bc60
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlNatInt.v
@@ -0,0 +1,75 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Extraction of [nat] into Ocaml's [int] *)
+
+Require Import Arith Even Div2 EqNat MinMax Euclid.
+Require Import ExtrOcamlBasic.
+
+(** Disclaimer: trying to obtain efficient certified programs
+    by extracting [nat] into [int] is definitively *not* a good idea:
+
+    - Since [int] is bounded while [nat] is (theoretically) infinite,
+    you have to make sure by yourself that your program will not
+    manipulate numbers greater than [max_int]. Otherwise you should
+    consider the translation of [nat] into [big_int].
+
+    - Moreover, the mere translation of [nat] into [int] does not
+    change the complexity of functions. For instance, [mult] stays
+    quadratic. To mitigate this, we propose here a few efficient (but
+    uncertified) realizers for some common functions over [nat].
+
+    This file is hence provided mainly for testing / prototyping
+    purpose. For serious use of numbers in extracted programs,
+    you are advised to use either coq advanced representations
+    (positive, Z, N, BigN, BigZ) or modular/axiomatic representation.
+*)
+
+
+(** Mapping of [nat] into [int]. The last string corresponds to
+    a [nat_case], see documentation of [Extract Inductive]. *)
+
+Extract Inductive nat => int [ "0" "succ" ]
+ "(fun fO fS n -> if n=0 then fO () else fS (n-1))".
+
+(** Efficient (but uncertified) versions for usual [nat] functions *)
+
+Extract Constant plus => "(+)".
+Extract Constant pred => "fun n -> max 0 (n-1)".
+Extract Constant minus => "fun n m -> max 0 (n-m)".
+Extract Constant mult => "( * )".
+Extract Inlined Constant max => max.
+Extract Inlined Constant min => min.
+Extract Inlined Constant nat_beq => "(=)".
+Extract Inlined Constant EqNat.beq_nat => "(=)".
+Extract Inlined Constant EqNat.eq_nat_decide => "(=)".
+
+Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)".
+
+Extract Constant Compare_dec.nat_compare =>
+ "fun n m -> if n=m then Eq else if n<m then Lt else Gt".
+Extract Inlined Constant Compare_dec.leb => "(<=)".
+Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)".
+Extract Constant Compare_dec.lt_eq_lt_dec =>
+ "fun n m -> if n>m then None else Some (n<m)".
+
+Extract Constant Even.even_odd_dec => "fun n -> n mod 2 = 0".
+Extract Constant Div2.div2 => "fun n -> n/2".
+
+Extract Inductive Euclid.diveucl => "(int * int)" [ "" ].
+Extract Constant Euclid.eucl_dev => "fun n m -> (m/n, m mod n)".
+Extract Constant Euclid.quotient => "fun n m -> m/n".
+Extract Constant Euclid.modulo => "fun n m -> m mod n".
+
+(*
+Definition test n m (H:m>0) :=
+ let (q,r,_,_) := eucl_dev m H n in
+ nat_compare n (q*m+r).
+
+Recursive Extraction test fact.
+*)
\ No newline at end of file
diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v
new file mode 100644
index 00000000..3fcd01b0
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlString.v
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* Extraction to Ocaml : special handling of ascii and strings *)
+
+Require Import Ascii String.
+
+Extract Inductive ascii => char
+[
+"(* If this appears, you're using Ascii internals. Please don't *)
+ (fun (b0,b1,b2,b3,b4,b5,b6,b7) ->
+  let f b i = if b then 1 lsl i else 0 in
+  Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))"
+]
+"(* If this appears, you're using Ascii internals. Please don't *)
+ (fun f c ->
+  let n = Char.code c in
+  let h i = (n land (1 lsl i)) <> 0 in
+  f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))".
+
+Extract Constant zero => "'\000'".
+Extract Constant one => "'\001'".
+Extract Constant shift =>
+ "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)".
+
+Extract Inlined Constant ascii_dec => "(=)".
+
+Extract Inductive string => "char list" [ "[]" "(::)" ].
+
+(*
+Definition test := "ceci est un test"%string.
+Recursive Extraction test Ascii.zero Ascii.one.
+*)
diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v
new file mode 100644
index 00000000..08f43d3f
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlZBigInt.v
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Extraction of [positive], [N] and [Z] into Ocaml's [big_int] *)
+
+Require Import ZArith NArith ZOdiv_def.
+Require Import ExtrOcamlBasic.
+
+(** NB: The extracted code should be linked with [nums.cm(x)a]
+    from ocaml's stdlib and with the wrapper [big.ml] that
+    simlifies the use of [Big_int] (it could be found in the sources
+    of Coq). *)
+
+(** Disclaimer: trying to obtain efficient certified programs
+    by extracting [Z] into [big_int] isn't necessarily a good idea.
+    See the Disclaimer in [ExtrOcamlNatInt]. *)
+
+(** Mapping of [positive], [Z], [N] into [big_int]. The last strings
+    emulate the matching, see documentation of [Extract Inductive]. *)
+
+Extract Inductive positive => "Big.big_int"
+ [ "Big.doubleplusone" "Big.double" "Big.one" ] "Big.positive_case".
+
+Extract Inductive Z => "Big.big_int"
+ [ "Big.zero" "" "Big.opp" ] "Big.z_case".
+
+Extract Inductive N => "Big.big_int"
+ [ "Big.zero" "" ] "Big.n_case".
+
+(** Nota: the "" above is used as an identity function "(fun p->p)" *)
+
+(** Efficient (but uncertified) versions for usual functions *)
+
+Extract Constant Pplus => "Big.add".
+Extract Constant Psucc => "Big.succ".
+Extract Constant Ppred => "fun n -> Big.max Big.one (Big.pred n)".
+Extract Constant Pminus => "fun n m -> Big.max Big.one (Big.sub n m)".
+Extract Constant Pmult => "Big.mult".
+Extract Constant Pmin => "Big.min".
+Extract Constant Pmax => "Big.max".
+Extract Constant Pcompare =>
+ "fun x y c -> Big.compare_case c Lt Gt x y".
+
+Extract Constant Nplus => "Big.add".
+Extract Constant Nsucc => "Big.succ".
+Extract Constant Npred => "fun n -> Big.max Big.zero (Big.pred n)".
+Extract Constant Nminus => "fun n m -> Big.max Big.zero (Big.sub n m)".
+Extract Constant Nmult => "Big.mult".
+Extract Constant Nmin => "Big.min".
+Extract Constant Nmax => "Big.max".
+Extract Constant Ndiv =>
+ "fun a b -> if Big.eq b Big.zero then Big.zero else Big.div a b".
+Extract Constant Nmod =>
+ "fun a b -> if Big.eq b Big.zero then Big.zero else Big.modulo a b".
+Extract Constant Ncompare => "Big.compare_case Eq Lt Gt".
+
+Extract Constant Zplus => "Big.add".
+Extract Constant Zsucc => "Big.succ".
+Extract Constant Zpred => "Big.pred".
+Extract Constant Zminus => "Big.sub".
+Extract Constant Zmult => "Big.mult".
+Extract Constant Zopp => "Big.opp".
+Extract Constant Zabs => "Big.abs".
+Extract Constant Zmin => "Big.min".
+Extract Constant Zmax => "Big.max".
+Extract Constant Zcompare => "Big.compare_case Eq Lt Gt".
+
+Extract Constant Z_of_N => "fun p -> p".
+Extract Constant Zabs_N => "Big.abs".
+
+(** Zdiv and Zmod are quite complex to define in terms of (/) and (mod).
+    For the moment we don't even try *)
+
+(** Test:
+Require Import ZArith NArith.
+
+Extraction "/tmp/test.ml"
+ Pplus Ppred Pminus Pmult Pcompare Npred Nminus Ndiv Nmod Ncompare
+ Zplus Zmult BinInt.Zcompare Z_of_N Zabs_N Zdiv.Zdiv Zmod.
+*)
diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v
new file mode 100644
index 00000000..d3ea7372
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlZInt.v
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Extraction of [positive], [N] and [Z] into Ocaml's [int] *)
+
+Require Import ZArith NArith ZOdiv_def.
+Require Import ExtrOcamlBasic.
+
+(** Disclaimer: trying to obtain efficient certified programs
+    by extracting [Z] into [int] is definitively *not* a good idea.
+    See the Disclaimer in [ExtrOcamlNatInt]. *)
+
+(** Mapping of [positive], [Z], [N] into [int]. The last strings
+    emulate the matching, see documentation of [Extract Inductive]. *)
+
+Extract Inductive positive => int
+[ "(fun p->1+2*p)" "(fun p->2*p)" "1" ]
+"(fun f2p1 f2p f1 p ->
+  if p<=1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))".
+
+Extract Inductive Z => int [ "0" "" "(~-)" ]
+"(fun f0 fp fn z -> if z=0 then f0 () else if z>0 then fp z else fn (-z))".
+
+Extract Inductive N => int [ "0" "" ]
+"(fun f0 fp n -> if n=0 then f0 () else fp n)".
+
+(** Nota: the "" above is used as an identity function "(fun p->p)" *)
+
+(** Efficient (but uncertified) versions for usual functions *)
+
+Extract Constant Pplus => "(+)".
+Extract Constant Psucc => "succ".
+Extract Constant Ppred => "fun n -> max 1 (n-1)".
+Extract Constant Pminus => "fun n m -> max 1 (n-m)".
+Extract Constant Pmult => "( * )".
+Extract Constant Pmin => "min".
+Extract Constant Pmax => "max".
+Extract Constant Pcompare =>
+ "fun x y c -> if x=y then c else if x<y then Lt else Gt".
+
+
+Extract Constant Nplus => "(+)".
+Extract Constant Nsucc => "succ".
+Extract Constant Npred => "fun n -> max 0 (n-1)".
+Extract Constant Nminus => "fun n m -> max 0 (n-m)".
+Extract Constant Nmult => "( * )".
+Extract Constant Nmin => "min".
+Extract Constant Nmax => "max".
+Extract Constant Ndiv => "fun a b -> if b=0 then 0 else a/b".
+Extract Constant Nmod => "fun a b -> if b=0 then a else a mod b".
+Extract Constant Ncompare =>
+ "fun x y -> if x=y then Eq else if x<y then Lt else Gt".
+
+
+Extract Constant Zplus => "(+)".
+Extract Constant Zsucc => "succ".
+Extract Constant Zpred => "pred".
+Extract Constant Zminus => "(-)".
+Extract Constant Zmult => "( * )".
+Extract Constant Zopp => "(~-)".
+Extract Constant Zabs => "abs".
+Extract Constant Zmin => "min".
+Extract Constant Zmax => "max".
+Extract Constant Zcompare =>
+ "fun x y -> if x=y then Eq else if x<y then Lt else Gt".
+
+Extract Constant Z_of_N => "fun p -> p".
+Extract Constant Zabs_N => "abs".
+
+(** Zdiv and Zmod are quite complex to define in terms of (/) and (mod).
+    For the moment we don't even try *)
+
+
diff --git a/plugins/extraction/README b/plugins/extraction/README
new file mode 100644
index 00000000..64c871fd
--- /dev/null
+++ b/plugins/extraction/README
@@ -0,0 +1,147 @@
+
+          Coq Extraction
+          ==============
+
+
+What is it ?
+------------
+
+The extraction is a mechanism allowing to produce functional code
+(Ocaml/Haskell/Scheme) out of any Coq terms (either programs or
+proofs).
+
+Who did it ?
+------------
+
+The current implementation (from version 7.0 up to now) has been done
+by P. Letouzey during his PhD, helped by J.C. Filliâtre and supervised
+by C. Paulin. 
+
+An earlier implementation (versions 6.x) was due to B. Werner and
+C. Paulin.
+
+
+Where can we find more information ?
+------------------------------------
+
+- Coq Reference Manual includes a full chapter about extraction
+- P. Letouzey's PhD thesis [3] forms a complete document about
+  both theory and implementation and test-cases of Coq-extraction
+- A more recent article [4] proposes a short overview of extraction
+- earlier documents [1] [2] may also be useful.
+
+
+Why a complete re-implementation ?
+----------------------------------
+
+Extraction code has been completely rewritten since version V6.3. 
+
+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 [1] and [2].
+
+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. 
+
+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, with either "Obj.magic" in Ocaml or "unsafeCoerce" 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 Library 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 or Scheme. 
+
+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, 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 ..." 
+
+
+
+
+
+[1]:
+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.pps.jussieu.fr/~letouzey/download/rapport_dea.ps.gz
+
+[2]: 
+A New Extraction for Coq, Pierre Letouzey, 
+Types 2002 Post-Workshop Proceedings. 
+http://www.pps.jussieu.fr/~letouzey/download/extraction2002.ps.gz
+
+[3]: 
+Programmation fonctionnelle certifiée: l'extraction de programmes
+dans l'assistant Coq. Pierre Letouzey, PhD thesis, 2004.
+http://www.pps.jussieu.fr/~letouzey/download/these_letouzey.ps.gz
+http://www.pps.jussieu.fr/~letouzey/download/these_letouzey_English.ps.gz
+
+[4]:
+Coq Extraction, An overview. Pierre Letouzey. CiE2008.
+http://www.pps.jussieu.fr/~letouzey/download/letouzey_extr_cie08.pdf
+
+
+
+
+
+
+
+
diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml
new file mode 100644
index 00000000..9a5bf56b
--- /dev/null
+++ b/plugins/extraction/big.ml
@@ -0,0 +1,154 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** [Big] : a wrapper around ocaml [Big_int] with nicer names,
+    and a few extraction-specific constructions *)
+
+(** To be linked with [nums.(cma|cmxa)] *)
+
+open Big_int
+
+type big_int = Big_int.big_int
+    (** The type of big integers. *)
+
+let zero = zero_big_int
+        (** The big integer [0]. *)
+let one = unit_big_int
+        (** The big integer [1]. *)
+let two = big_int_of_int 2
+        (** The big integer [2]. *)
+
+(** {6 Arithmetic operations} *)
+
+let opp = minus_big_int
+        (** Unary negation. *)
+let abs = abs_big_int
+        (** Absolute value. *)
+let add = add_big_int
+        (** Addition. *)
+let succ = succ_big_int
+        (** Successor (add 1). *)
+let add_int = add_int_big_int
+        (** Addition of a small integer to a big integer. *)
+let sub = sub_big_int
+        (** Subtraction. *)
+let pred = pred_big_int
+        (** Predecessor (subtract 1). *)
+let mult = mult_big_int
+        (** Multiplication of two big integers. *)
+let mult_int = mult_int_big_int
+        (** Multiplication of a big integer by a small integer *)
+let square = square_big_int
+        (** Return the square of the given big integer *)
+let sqrt = sqrt_big_int
+        (** [sqrt_big_int a] returns the integer square root of [a],
+           that is, the largest big integer [r] such that [r * r <= a].
+           Raise [Invalid_argument] if [a] is negative. *)
+let quomod = quomod_big_int
+        (** Euclidean division of two big integers.
+           The first part of the result is the quotient,
+           the second part is the remainder.
+           Writing [(q,r) = quomod_big_int a b], we have
+           [a = q * b + r] and [0 <= r < |b|].
+           Raise [Division_by_zero] if the divisor is zero. *)
+let div = div_big_int
+        (** Euclidean quotient of two big integers.
+           This is the first result [q] of [quomod_big_int] (see above). *)
+let modulo = mod_big_int
+        (** Euclidean modulus of two big integers.
+           This is the second result [r] of [quomod_big_int] (see above). *)
+let gcd = gcd_big_int
+        (** Greatest common divisor of two big integers. *)
+let power = power_big_int_positive_big_int
+        (** Exponentiation functions.  Return the big integer
+           representing the first argument [a] raised to the power [b]
+           (the second argument).  Depending
+           on the function, [a] and [b] can be either small integers
+           or big integers.  Raise [Invalid_argument] if [b] is negative. *)
+
+(** {6 Comparisons and tests} *)
+
+let sign = sign_big_int
+        (** Return [0] if the given big integer is zero,
+           [1] if it is positive, and [-1] if it is negative. *)
+let compare = compare_big_int
+        (** [compare_big_int a b] returns [0] if [a] and [b] are equal,
+           [1] if [a] is greater than [b], and [-1] if [a] is smaller
+           than [b]. *)
+let eq = eq_big_int
+let le = le_big_int
+let ge = ge_big_int
+let lt = lt_big_int
+let gt = gt_big_int
+        (** Usual boolean comparisons between two big integers. *)
+let max = max_big_int
+        (** Return the greater of its two arguments. *)
+let min = min_big_int
+        (** Return the smaller of its two arguments. *)
+
+(** {6 Conversions to and from strings} *)
+
+let to_string = string_of_big_int
+        (** Return the string representation of the given big integer,
+           in decimal (base 10). *)
+let of_string = big_int_of_string
+        (** Convert a string to a big integer, in decimal.
+           The string consists of an optional [-] or [+] sign,
+           followed by one or several decimal digits. *)
+
+(** {6 Conversions to and from other numerical types} *)
+
+let of_int = big_int_of_int
+        (** Convert a small integer to a big integer. *)
+let is_int = is_int_big_int
+        (** Test whether the given big integer is small enough to
+           be representable as a small integer (type [int])
+           without loss of precision.  On a 32-bit platform,
+           [is_int_big_int a] returns [true] if and only if
+           [a] is between 2{^30} and 2{^30}-1.  On a 64-bit platform,
+           [is_int_big_int a] returns [true] if and only if
+           [a] is between -2{^62} and 2{^62}-1. *)
+let to_int = int_of_big_int
+        (** Convert a big integer to a small integer (type [int]).
+           Raises [Failure "int_of_big_int"] if the big integer
+           is not representable as a small integer. *)
+
+(** Functions used by extraction *)
+
+let double x = mult_int 2 x
+let doubleplusone x = succ (double x)
+
+let nat_case fO fS n = if sign n <= 0 then fO () else fS (pred n)
+
+let positive_case f2p1 f2p f1 p =
+ if le p one then f1 () else
+   let (q,r) = quomod p two in if eq r zero then f2p q else f2p1 q
+
+let n_case fO fp n = if sign n <= 0 then fO () else fp n
+
+let z_case fO fp fn z =
+  let s = sign z in
+  if s = 0 then fO () else if s > 0 then fp z else fn (opp z)
+
+let compare_case e l g x y =
+  let s = compare x y in if s = 0 then e else if s<0 then l else g
+
+let nat_rec fO fS =
+  let rec loop acc n =
+    if sign n <= 0 then acc else loop (fS acc) (pred n)
+  in loop fO
+
+let positive_rec f2p1 f2p f1 =
+  let rec loop n =
+    if le n one then f1
+    else
+      let (q,r) = quomod n two in
+      if eq r zero then f2p (loop q) else f2p1 (loop q)
+  in loop
+
+let z_rec fO fp fn = z_case (fun _ -> fO) fp fn
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
new file mode 100644
index 00000000..1db1c786
--- /dev/null
+++ b/plugins/extraction/common.ml
@@ -0,0 +1,535 @@
+(************************************************************************)
+(*  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$ i*)
+
+open Pp
+open Util
+open Names
+open Term
+open Declarations
+open Namegen
+open Nameops
+open Libnames
+open Table
+open Miniml
+open Mlutil
+open Modutil
+open Mod_subst
+
+let string_of_id id =
+  let s = Names.string_of_id id in
+  for i = 0 to String.length s - 2 do
+    if s.[i] = '_' && s.[i+1] = '_' then warning_id s
+  done;
+  ascii_of_ident s
+
+let is_mp_bound = function MPbound _ -> true | _ -> false
+
+(*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 qualify delim = function
+  | [] -> assert false
+  | [s] -> s
+  | ""::l -> qualify delim l
+  | s::l -> s^delim^(qualify delim l)
+
+let dottify = qualify "."
+let pseudo_qualify = qualify "__"
+
+(*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_subscript 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 List of module parameters that we should alpha-rename *)
+
+let params_ren_add, params_ren_mem =
+  let m = ref MPset.empty in
+  let add mp = m:=MPset.add mp !m
+  and mem mp = MPset.mem mp !m
+  and clear () = m:=MPset.empty
+  in
+  register_cleanup clear;
+  (add,mem)
+
+(*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:
+  a [MPfile] at the beginning, and then more and more [MPdot]
+  over this [MPfile], or [MPbound] when inside the type of a
+  module parameter.
+
+  - the [params] are the [MPbound] when [mp] is a functor,
+    the innermost [MPbound] coming first in the list.
+
+  - The [content] part is used to record all the names already
+  seen at this level.
+*)
+
+type visible_layer = { mp : module_path;
+		       params : module_path list;
+		       content : ((kind*string),label) Hashtbl.t }
+
+let pop_visible, push_visible, get_visible =
+  let vis = ref [] in
+  register_cleanup (fun () -> vis := []);
+  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
+  and push mp mps =
+    vis := { mp = mp; params = mps; content = Hashtbl.create 97 } :: !vis
+  and get () = !vis
+  in (pop,push,get)
+
+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 l = Hashtbl.add (top_visible ()).content ks l
+
+(* 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 (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
+  | MPbound mbid ->
+      let s = modular_rename Mod (id_of_mbid mbid) in
+      if not (params_ren_mem mp) then [s]
+      else let i,_,_ = repr_mbid mbid in [s^"__"^string_of_int i]
+  | 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 if is_mp_bound (base_mp x) then raise Not_found; 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 = modpath_of_r r in
+  let l = mp_renaming mp in
+  let l = if lang () <> Ocaml && not (modular ()) then [""] else l 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_basename_of_global r)) globs in
+      string_of_id id
+    else modular_rename k (safe_basename_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 if is_mp_bound (base_mp (modpath_of_r (snd x))) then raise Not_found; 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 rec params_lookup mp0 ks = function
+  | [] -> false
+  | param :: _ when mp0 = param -> true
+  | param :: params ->
+      if ks = (Mod, List.hd (mp_renaming param)) then params_ren_add param;
+      params_lookup mp0 ks params
+
+let visible_clash mp0 ks =
+  let rec clash = function
+    | [] -> false
+    | v :: _ when v.mp = mp0 -> false
+    | v :: vis ->
+	let b = Hashtbl.mem v.content ks in
+	if b && not (is_mp_bound mp0) then true
+	else begin
+	  if b then params_ren_add mp0;
+	  if params_lookup mp0 ks v.params then false
+	  else clash vis
+	end
+  in clash (get_visible ())
+
+(* Same, but with verbose output (and mp0 shouldn't be a MPbound) *)
+
+let visible_clash_dbg mp0 ks =
+  let rec clash = function
+    | [] -> None
+    | v :: _ when v.mp = mp0 -> None
+    | v :: vis ->
+	try Some (v.mp,Hashtbl.find v.content ks)
+	with Not_found ->
+	  if params_lookup mp0 ks v.params then None
+	  else 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.
+   [rls] is the string list giving the qualified name, short name at the end.
+   Invariant: [List.length rls >= 2], simpler situations are handled elsewhere. *)
+
+(* In Coq, we can qualify [M.t] even if we are inside [M], but in Ocaml we
+   cannot do that. So, if [t] gets hidden and we need a long name for it,
+   we duplicate the _definition_ of t in a Coq__XXX module, and similarly
+   for a sub-module [M.N] *)
+
+let pp_duplicate k' prefix mp rls olab =
+  let rls', lbl =
+    if k'<>Mod then
+      (* Here rls=[s], the ref to print is <prefix>.<s>, and olab<>None *)
+      rls, Option.get olab
+    else
+      (* Here rls=s::rls', we search the label for s inside mp *)
+      List.tl rls, get_nth_label_mp (mp_length mp - mp_length prefix) mp
+  in
+  try dottify (check_duplicate prefix lbl :: rls')
+  with Not_found ->
+    assert (get_phase () = Pre); (* otherwise it's too late *)
+    add_duplicate prefix lbl; dottify rls
+
+let fstlev_ks k = function
+  | [] -> assert false
+  | [s] -> k,s
+  | s::_ -> Mod,s
+
+(* [pp_ocaml_local] : [mp] has something in common with [top_visible ()]
+   but isn't equal to it *)
+
+let pp_ocaml_local k prefix mp rls olab =
+  (* what is the largest prefix of [mp] that belongs to [visible]? *)
+  assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *)
+  let rls' = list_skipn (mp_length prefix) rls in
+  let k's = fstlev_ks k rls' in
+  (* Reference r / module path mp is of the form [<prefix>.s.<...>]. *)
+  if not (visible_clash prefix k's) then dottify rls'
+  else pp_duplicate (fst k's) prefix mp rls' olab
+
+(* [pp_ocaml_bound] : [mp] starts with a [MPbound], and we are not inside
+   (i.e. we are not printing the type of the module parameter) *)
+
+let pp_ocaml_bound base rls =
+  (* clash with a MPbound will be detected and fixed by renaming this MPbound *)
+  if get_phase () = Pre then ignore (visible_clash base (Mod,List.hd rls));
+  dottify rls
+
+(* [pp_ocaml_extern] : [mp] isn't local, it is defined in another [MPfile]. *)
+
+let pp_ocaml_extern k base rls = match rls with
+  | [] | [_] -> assert false
+  | base_s :: rls' ->
+      let k's = fstlev_ks k rls' 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 rls'
+      else match visible_clash_dbg base (Mod,base_s) with
+	| None -> dottify rls
+	| Some (mp,l) -> error_module_clash base (MPdot (mp,l))
+
+(* [pp_ocaml_gen] : choosing between [pp_ocaml_extern] or [pp_ocaml_extern] *)
+
+let pp_ocaml_gen k mp rls olab =
+  match common_prefix_from_list mp (get_visible_mps ()) with
+    | Some prefix -> pp_ocaml_local k prefix mp rls olab
+    | None ->
+	let base = base_mp mp in
+	if is_mp_bound base then pp_ocaml_bound base rls
+	else pp_ocaml_extern k base rls
+
+(* For Haskell, things are simplier: we have removed (almost) all structures *)
+
+let pp_haskell_gen k mp rls = match rls with
+  | [] -> assert false
+  | s::rls' ->
+      (if base_mp mp <> top_visible_mp () then s ^ "." else "") ^
+	(if upperkind k then "" else "_") ^ pseudo_qualify rls'
+
+(* Main name printing function for a reference *)
+
+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,_,l = repr_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) l; unquote s)
+  else
+    let rls = List.rev ls in (* for what come next it's easier this way *)
+    match lang () with
+      | Scheme -> unquote s (* no modular Scheme extraction... *)
+      | Haskell -> if modular () then pp_haskell_gen k mp rls else s
+      | Ocaml -> pp_ocaml_gen k mp rls (Some l)
+
+(* The next function is used only in Ocaml extraction...*)
+
+let pp_module mp =
+  let ls = mp_renaming mp in
+  match mp with
+    | MPdot (mp0,l) 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) l; s
+    | _ -> pp_ocaml_gen Mod mp (List.rev ls) None
+
+
diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli
new file mode 100644
index 00000000..93be15d1
--- /dev/null
+++ b/plugins/extraction/common.mli
@@ -0,0 +1,59 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ 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
+(* In [push_visible], the [module_path list] corresponds to
+   module parameters, the innermost one coming first in the list *)
+val push_visible : module_path -> module_path list -> 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/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
new file mode 100644
index 00000000..ab9c242a
--- /dev/null
+++ b/plugins/extraction/extract_env.ml
@@ -0,0 +1,540 @@
+(************************************************************************)
+(*  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$ 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 (mind_of_kn 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
+    | _ -> SEBstruct (List.rev (map_succeed get_reference seg))
+ 
+
+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 : mutual_inductive -> 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 : mutual_inductive -> 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 : Mindset.t; mutable con : Cset.t; mutable mp : MPset.t }
+  (* the imperative internal visit lists *)
+  let v = { kn = Mindset.empty ; con = Cset.empty ; mp = MPset.empty }
+  (* the accessor functions *)
+  let reset () = v.kn <- Mindset.empty; v.con <- Cset.empty; v.mp <- MPset.empty
+  let needed_kn kn = Mindset.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 <- Mindset.add kn v.kn; add_mp (mind_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
+
+(** Expanding a [struct_expr_body] into a version without abbreviations
+    or functor applications. This is done via a detour to entries
+    (hack proposed by Elie)
+*)
+
+let rec seb2mse = function
+  | SEBapply (s,s',_) -> Entries.MSEapply(seb2mse s, seb2mse s')
+  | SEBident mp -> Entries.MSEident mp
+  | _ -> failwith "seb2mse: received a non-atomic seb"
+
+let expand_seb env mp seb =
+  let seb,_,_,_ =
+    Mod_typing.translate_struct_module_entry env mp true (seb2mse seb)
+  in seb
+
+(** When possible, we use the nicer, shorter, algebraic type structures
+    instead of the expanded ones. *)
+
+let my_type_of_mb mb =
+  let m0 = mb.mod_type in
+  match mb.mod_type_alg with Some m -> m0,m | None -> m0,m0
+
+let my_type_of_mtb mtb =
+  let m0 = mtb.typ_expr in
+  match mtb.typ_expr_alg with Some m -> m0,m | None -> m0,m0
+
+(** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def].
+    To check with Elie. *)
+
+let rec msid_of_seb = function
+  | SEBident mp -> mp
+  | SEBwith (seb,_) -> msid_of_seb seb
+  | _ -> assert false
+
+let env_for_mtb_with env mp seb idl =
+  let sig_b = match seb with
+    | SEBstruct(sig_b) -> sig_b
+    | _ -> assert false
+  in
+  let l = label_of_id (List.hd idl) in
+  let before = fst (list_split_when (fun (l',_) -> l=l') sig_b) in
+  Modops.add_signature mp before empty_delta_resolver 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 mind = mind_of_kn kn in
+      let s = Sind (kn, extract_inductive env mind) 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 mb.mod_mp (my_type_of_mb mb) in
+      (l,Smodule spec) :: specs
+  | (l,SFBmodtype mtb) :: msig ->
+      let specs = extract_sfb_spec env mp msig in
+      let spec = extract_seb_spec env mtb.typ_mp (my_type_of_mtb mtb) in
+      (l,Smodtype spec) :: specs
+
+(* 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, or their [_alg] counterparts.
+   This way, any encountered [SEBident] should be a true module type.
+*)
+
+and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with
+  | SEBident mp -> Visit.add_mp mp; MTident mp
+  | SEBwith(seb',With_definition_body(idl,cb))->
+      let env' = env_for_mtb_with env (msid_of_seb seb') seb idl in
+      let mt = extract_seb_spec env mp1 (seb,seb') in
+      (match extract_with_type env' cb with (* cb peut contenir des kn  *)
+	 | None -> mt
+	 | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ)))
+  | SEBwith(seb',With_module_body(idl,mp))->
+      Visit.add_mp mp;
+      MTwith(extract_seb_spec env mp1 (seb,seb'),
+	     ML_With_module(idl,mp))
+  | SEBfunctor (mbid, mtb, seb_alg') ->
+      let seb' = match seb with
+	| SEBfunctor (mbid',_,seb') when mbid' = mbid -> seb'
+	| _ -> assert false
+      in
+      let mp = MPbound mbid in
+      let env' = Modops.add_module (Modops.module_body_of_type mp mtb) env in
+      MTfunsig (mbid, extract_seb_spec env mp (my_type_of_mtb mtb),
+		extract_seb_spec env' mp1 (seb',seb_alg'))
+  | SEBstruct (msig) ->
+      let env' = Modops.add_signature mp1 msig empty_delta_resolver env in
+      MTsig (mp1, extract_sfb_spec env' mp1 msig)
+  | SEBapply _ ->
+      if seb <> seb_alg then extract_seb_spec env mp1 (seb,seb)
+      else assert false
+
+
+
+(* 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 mind = mind_of_kn kn in
+      let b = Visit.needed_kn mind in
+      if all || b then
+	let d = Dind (kn, extract_inductive env mind) 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 mp (my_type_of_mtb mtb))) :: ms
+      else ms
+
+(* From [struct_expr_body] to implementations *)
+
+and extract_seb env mp all = function
+  | (SEBident _ | SEBapply _) as seb when lang () <> Ocaml ->
+      (* in Haskell/Scheme, we expand everything *)
+      extract_seb env mp all (expand_seb env mp seb)
+  | 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 mp true meb,
+	       extract_seb env mp true meb')
+  | SEBfunctor (mbid, mtb, meb) ->
+      let mp1 = MPbound mbid in
+      let env' = Modops.add_module (Modops.module_body_of_type  mp1 mtb)
+	env  in
+      MEfunctor (mbid, extract_seb_spec env mp1 (my_type_of_mtb mtb),
+		 extract_seb env' mp true meb)
+  | SEBstruct (msb) ->
+      let env' = Modops.add_signature mp msb empty_delta_resolver env in
+      MEstruct (mp,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 mp all (Option.get mb.mod_expr);
+    ml_mod_type = extract_seb_spec env mp (my_type_of_mb 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 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 mp =
+  let f = file_of_modfile mp in
+  let d = descr () in
+  Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id_of_string f
+
+(*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 [];
+  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 = qualid_of_ident 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 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
+	print_structure_to_file (module_filename mp) dry [e]
+    | _ -> assert false
+  in
+  List.iter print struc;
+  reset ()
diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli
new file mode 100644
index 00000000..dcb4601e
--- /dev/null
+++ b/plugins/extraction/extract_env.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ 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/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
new file mode 100644
index 00000000..99682ae6
--- /dev/null
+++ b/plugins/extraction/extraction.ml
@@ -0,0 +1,982 @@
+(************************************************************************)
+(*  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$ 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 Namegen
+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
+
+(* Enriching a signature with implicit information *)
+
+let sign_with_implicits r s =
+  let implicits = implicits_of_global r in
+  let rec add_impl i = function
+    | [] -> []
+    | sign::s ->
+	let sign' =
+	  if sign = Keep && List.mem i implicits then Kill Kother else sign
+	in sign' :: add_impl (succ i) s
+  in
+  add_impl 1 s
+
+(* Enriching a exception message *)
+
+let rec handle_exn r n fn_name = function
+  | MLexn s ->
+      (try Scanf.sscanf s "UNBOUND %d"
+	 (fun i ->
+	    assert ((0 < i) && (i <= n));
+	    MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i)))
+       with _ -> MLexn s)
+  | a -> ast_map (handle_exn r n fn_name) a
+
+(*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. *)
+    let equiv = 
+      if (canonical_mind kn) = (user_mind kn) then
+	NoEquiv
+      else
+	begin
+	  ignore (extract_ind env (mind_of_kn (canonical_mind kn)));
+	  Equiv (canonical_mind kn)
+	end
+    in
+    (* 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;
+	     ip_optim_id_ok = None })
+	mib.mind_packets
+    in
+
+    add_ind kn mib
+      {ind_info = Standard;
+       ind_nparams = npar;
+       ind_packets = packets;
+       ind_equiv = equiv
+      };
+    (* 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_mind 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 List.for_all ((=) Keep) (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 = equiv }
+    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.
+
+   - [db] is a context for translating Coq [Rel] into ML type [Tvar]
+   - [dbmap] is a translation map (produced by a call to [parse_in_args])
+   - [i] is the rank of the current product (initially [params_nb+1])
+*)
+
+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)
+let type_expunge_from_sign env = type_expunge_from_sign (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 id, new_meta()
+		 with NotDefault d -> Dummy, 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 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
+  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 rec f = function
+    | [], [], _ -> []
+    | a::la, t::lt, [] -> extract_maybe_term env e t a :: (f (la,lt,[]))
+    | a::la, t::lt, Keep::s -> extract_maybe_term env e t a :: (f (la,lt,s))
+    | _::la, _::lt, _::s -> f (la,lt,s)
+    | _ -> assert false
+  in f (args,typs,s)
+
+(*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_full = type2signature env (snd schema) in
+  let s_full = sign_with_implicits (ConstRef kn) s_full in
+  let s = sign_no_final_keeps s_full in
+  let ls = List.length s in
+  let la = List.length args in
+  (* The ml arguments, already expunged from known logical ones *)
+  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
+  (* For strict languages, purely logical signatures with at least
+     one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left
+     accordingly. *)
+  let optdummy = match sign_kind s_full with
+    | UnsafeLogicalSig when lang () <> Haskell -> [MLdummy]
+    | _ -> []
+  in
+  (* Different situations depending of the number of arguments: *)
+  if la >= ls
+  then
+    (* Enough args, cleanup already done in [mla], we only add the
+       additionnal dummy if needed. *)
+    put_magic_if (magic2 && not magic1) (mlapp head (optdummy @ mla))
+  else
+    (* Partially applied function with some logical arg missing.
+       We complete via eta and expunge logical args. *)
+    let ls' = ls-la in
+    let s' = list_skipn la s in
+    let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
+    let e = anonym_or_dummy_lams (mlapp head mla) s' in
+    put_magic_if magic2 (remove_n_lams (List.length optdummy) e)
+
+(*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 s = sign_with_implicits (ConstructRef cp) s 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 =
+	let r = ConstructRef (ip,i+1) in
+	(* 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
+	let s = sign_with_implicits r s 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
+	let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in
+	(r, 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 (tmp_id (List.hd ids),a,e')
+	end
+      else
+	(* Standard case: we apply [extract_branch]. *)
+	MLcase ((mi.ind_info,BranchNone), 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 m env c t =
+  let rels = fst (splay_prod_n env none n t) in
+  let rels = List.map (fun (id,_,c) -> (id,c)) rels in
+  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 products, 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
+  (* Check for user-declared implicit information *)
+  let s = sign_with_implicits (ConstRef kn) s in
+  (* Decomposing the top level lambdas of [body].
+     If there isn't enough, it's ok, as long as remaining args
+     aren't to be pruned (and initial lambdas aren't to be all
+     removed if the target language is strict). In other situations,
+     eta-expansions create artificially enough lams (but that may
+     break user's clever let-ins and partial applications). *)
+  let rels, c =
+    let n = List.length s
+    and m = nb_lam body in
+    if n <= m then decompose_lam_n n body
+    else
+      let s,s' = list_split_at m s in
+      if List.for_all ((=) Keep) s' &&
+	(lang () = Haskell || sign_kind s <> UnsafeLogicalSig)
+      then decompose_lam_n m body
+      else decomp_lams_eta_n n m env body typ
+  in
+  let n = List.length rels in
+  let s = list_firstn n s in
+  let l,l' = list_split_at n l in
+  let t' = type_recomp (l',t') in
+  (* The initial ML environment. *)
+  let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in
+  (* The lambdas names. *)
+  let ids = List.map (fun (n,_) -> Id (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. *)
+  let trm = term_expunge s (ids,e) in
+  let trm = handle_exn (ConstRef kn) n (fun i -> fst (List.nth rels (i-1))) trm
+  in
+  trm, type_expunge_from_sign env s 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_name::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 i j l =
+    let implicits = implicits_of_global (ConstructRef ((kn,i),j+1)) in
+    let rec filter i = function
+      | [] -> []
+      | t::l ->
+	  let l' = filter (succ i) l in
+	  if isDummy (expand env t) || List.mem i implicits then l'
+	  else t::l'
+    in filter 1 l
+  in
+  let packets =
+    Array.mapi (fun i p -> { p with ip_types = Array.mapi (f i) 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/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli
new file mode 100644
index 00000000..6bcd2476
--- /dev/null
+++ b/plugins/extraction/extraction.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  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$ 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 -> mutual_inductive -> 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/plugins/extraction/extraction_plugin.mllib b/plugins/extraction/extraction_plugin.mllib
new file mode 100644
index 00000000..b7f45861
--- /dev/null
+++ b/plugins/extraction/extraction_plugin.mllib
@@ -0,0 +1,11 @@
+Table
+Mlutil
+Modutil
+Extraction
+Common
+Ocaml
+Haskell
+Scheme
+Extract_env
+G_extraction
+Extraction_plugin_mod
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
new file mode 100644
index 00000000..18828241
--- /dev/null
+++ b/plugins/extraction/g_extraction.ml4
@@ -0,0 +1,142 @@
+(************************************************************************)
+(*  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
+open Names
+open Nameops
+open Table
+open Extract_env
+
+let pr_mlname _ _ _ s = spc () ++ qs s
+
+ARGUMENT EXTEND mlname
+  TYPED AS string
+  PRINTED BY pr_mlname
+| [ preident(id) ] -> [ id ]
+| [ string(s) ] -> [ s ]
+END
+
+let pr_int_or_id _ _ _ = function
+  | ArgInt i -> int i
+  | ArgId id -> pr_id id
+
+ARGUMENT EXTEND int_or_id
+  TYPED AS int_or_id
+  PRINTED BY pr_int_or_id
+| [ preident(id) ] -> [ ArgId (id_of_string id) ]
+| [ integer(i) ] -> [ ArgInt i ]
+END
+
+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 ExtractionImplicit
+(* Custom implicit arguments of some csts/inds/constructors *)
+| [ "Extraction" "Implicit" global(r) "[" int_or_id_list(l) "]" ]
+  -> [ extraction_implicit r l ]
+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) "]" string_opt(o) ]
+  -> [ extract_inductive x id idl o ]
+END
diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml
new file mode 100644
index 00000000..bb1dbd48
--- /dev/null
+++ b/plugins/extraction/haskell.ml
@@ -0,0 +1,357 @@
+(************************************************************************)
+(*  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$ 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 (mind_of_kn 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 (List.map id_of_mlid 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_of_mlid 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 (_,t, pv) when is_custom_match pv ->
+	let mkfun (_,ids,e) =
+	  if ids <> [] then named_lams (List.rev ids) e
+	  else dummy_lams (ast_lift 1 e) 1
+	in
+	hov 2 (str (find_custom_match pv) ++ fnl () ++
+		 prvect (fun tr -> pp_expr true env [] (mkfun tr) ++ fnl ()) pv
+	       ++ pp_expr true env [] t)
+    | 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_map id_of_mlid 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
+  let factor_br, factor_l = try match factors with
+    | BranchFun (i::_ as l) -> check_function_branch pv.(i), l
+    | BranchCst (i::_ as l) -> ast_pop (check_constant_branch pv.(i)), l
+    | _ -> MLdummy, []
+  with Impossible -> MLdummy, []
+  in
+  let par = expr_needs_par factor_br in
+  let last = Array.length pv - 1 in
+  prvecti
+    (fun i x -> if List.mem i factor_l then mt () else
+       (pp_one_pat pv.(i) ++
+       if i = last && factor_l = [] then mt () else
+       fnl () ++ str "  ")) pv
+  ++
+  if factor_l = [] then mt () else match factors with
+    | BranchFun _ ->
+	let ids, env' = push_vars [anonymous_name] env in
+	pr_id (List.hd ids) ++ str " ->" ++ spc () ++
+	pp_expr par env' [] factor_br
+    | BranchCst _ ->
+	str "_ ->" ++ spc () ++ pp_expr par env [] factor_br
+    | BranchNone -> mt ()
+
+(*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 (List.map id_of_mlid 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 (mind_of_kn kn) i.ind_packets.(0) ++ fnl ()
+  | Dind (kn,i) -> hov 0 (pp_ind true (mind_of_kn 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 rec pp_structure_elem = function
+  | (l,SEdecl d) -> pp_decl d
+  | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr
+  | (l,SEmodtype m) -> mt ()
+      (* for the moment we simply discard module type *)
+
+and pp_module_expr = function
+  | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel
+  | MEfunctor _ -> mt ()
+      (* for the moment we simply discard unapplied functors *)
+  | MEident _ | MEapply _ -> assert false
+      (* should be expansed in extract_env *)
+
+let pp_struct =
+  let pp_sel (mp,sel) =
+    push_visible mp [];
+    let p = prlist_strict pp_structure_elem sel in
+    pop_visible (); p
+  in
+  prlist_strict pp_sel
+
+
+let haskell_descr = {
+  keywords = keywords;
+  file_suffix = ".hs";
+  preamble = preamble;
+  pp_struct = pp_struct;
+  sig_suffix = None;
+  sig_preamble = (fun _ _ _ -> mt ());
+  pp_sig = (fun _ -> mt ());
+  pp_decl = pp_decl;
+}
diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli
new file mode 100644
index 00000000..1b5dbc71
--- /dev/null
+++ b/plugins/extraction/haskell.mli
@@ -0,0 +1,12 @@
+(************************************************************************)
+(*  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$ i*)
+
+val haskell_descr : Miniml.language_descr
+
diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli
new file mode 100644
index 00000000..61b3fc13
--- /dev/null
+++ b/plugins/extraction/miniml.mli
@@ -0,0 +1,201 @@
+(************************************************************************)
+(*  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$ 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 other reasons
+   (for instance user-declared implicit arguments w.r.t. extraction). *)
+
+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
+
+(* 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;
+  mutable ip_optim_id_ok : bool option
+}
+
+(* [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_ident =
+  | Dummy
+  | Id of identifier
+  | Tmp of identifier
+
+(* list of branches to merge in a common pattern *)
+
+type case_info =
+  | BranchNone
+  | BranchFun of int list
+  | BranchCst of int list
+
+type ml_branch = global_reference * ml_ident list * ml_ast
+
+and ml_ast =
+  | MLrel    of int
+  | MLapp    of ml_ast * ml_ast list
+  | MLlam    of ml_ident * ml_ast
+  | MLletin  of ml_ident * 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 * ml_branch 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 module_path * 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 module_path * 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;
+  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/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml
new file mode 100644
index 00000000..6dd43c44
--- /dev/null
+++ b/plugins/extraction/mlutil.ml
@@ -0,0 +1,1293 @@
+(************************************************************************)
+(*  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$ 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_name = id_of_string "x"
+let dummy_name = id_of_string "_"
+
+let anonymous = Id anonymous_name
+
+let id_of_name = function
+  | Anonymous -> anonymous_name
+  | Name id when id = dummy_name -> anonymous_name
+  | Name id -> id
+
+let id_of_mlid = function
+  | Dummy -> dummy_name
+  | Id id -> id
+  | Tmp id -> id
+
+let tmp_id = function
+  | Id id -> Tmp id
+  | a -> a
+
+let is_tmp = function Tmp _ -> true | _ -> false
+
+(*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 What are the type variables occurring in [t]. *)
+
+let intset_union_map_list f l =
+  List.fold_left (fun s t -> Intset.union s (f t)) Intset.empty l
+
+let intset_union_map_array f a =
+  Array.fold_left (fun s t -> Intset.union s (f t)) Intset.empty a
+
+let rec type_listvar = function
+  | Tmeta {contents = Some t} -> type_listvar t
+  | Tvar i | Tvar' i -> Intset.singleton i
+  | Tarr (a,b) -> Intset.union (type_listvar a) (type_listvar b)
+  | Tglob (_,l) -> intset_union_map_list type_listvar l
+  | _ -> Intset.empty
+
+(*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 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 = function
+  | Dummy -> Kill Kother
+  | _ -> Keep
+
+(* Classification of signatures *)
+
+type sign_kind =
+  | EmptySig
+  | NonLogicalSig (* at least a [Keep] *)
+  | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *)
+  | SafeLogicalSig (* only [Kill Ktype] *)
+
+let rec sign_kind = function
+  | [] -> EmptySig
+  | Keep :: _ -> NonLogicalSig
+  | Kill k :: s ->
+      match sign_kind s with
+	| NonLogicalSig -> NonLogicalSig
+	| UnsafeLogicalSig -> UnsafeLogicalSig
+	| SafeLogicalSig | EmptySig ->
+	    if k = Kother then UnsafeLogicalSig else SafeLogicalSig
+
+(* Removing the final [Keep] in a signature *)
+
+let rec sign_no_final_keeps = function
+  | [] -> []
+  | k :: s ->
+      let s' = k :: sign_no_final_keeps s in
+      if s' = [Keep] then [] else s'
+
+(*s Removing [Tdummy] from the top level of a ML type. *)
+
+let type_expunge_from_sign env s t =
+  let rec expunge s t =
+    if s = [] then t else match t with
+      | Tmeta {contents = Some t} -> expunge s t
+      | Tarr (a,b) ->
+	  let t = expunge (List.tl s) b in
+	  if List.hd s = Keep then Tarr (a, t) else t
+      | Tglob (r,l) ->
+	  (match env r with
+	     | Some mlt -> expunge s (type_subst_list l mlt)
+	     | None -> assert false)
+      | _ -> assert false
+  in
+  let t = expunge (sign_no_final_keeps s) t in
+  if lang () <> Haskell && sign_kind s = UnsafeLogicalSig then
+    Tarr (Tdummy Kother, t)
+  else t
+
+let type_expunge env t =
+  type_expunge_from_sign env (type_to_signature env t) t
+
+(*S Generic functions over ML ast terms. *)
+
+let mlapp f a = if a = [] then f else MLapp (f,a)
+
+(*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] (resp. [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
+	  match v.(i'-1) with
+	    | None -> MLexn ("UNBOUND " ^ string_of_int i')
+	    | Some u -> ast_lift n u
+	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 for a specific identifier (resp. anonymous, dummy) *)
+
+let rec many_lams id a = function
+  | 0 -> a
+  | n -> many_lams id (MLlam (id,a)) (pred n)
+
+let anonym_lams a n = many_lams anonymous a n
+let anonym_tmp_lams a n = many_lams (Tmp anonymous_name) a n
+let dummy_lams a n = many_lams Dummy a 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, 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)
+
+let rec tmp_head_lams = function
+  | MLlam (id, t) -> MLlam (tmp_id id, tmp_head_lams t)
+  | e -> e
+
+(*s Applies a substitution [s] of constants by their body, plus
+  linear beta reductions at modified positions.
+  Moreover, we mark some lambdas as suitable for later linear
+  reduction (this helps the inlining of recursors).
+*)
+
+let rec ast_glob_subst s t = match t with
+  | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) ->
+      let a = List.map (fun e -> tmp_head_lams (ast_glob_subst s e)) 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_function_branch (r,l,c)] checks if branch [c] can be seen
+  as a function [f] applied to [MLcons(r,l)]. For that it transforms
+  any [MLcons(r,l)] in [MLrel 1] and raises [Impossible] if any
+  variable in [l] occurs outside such a [MLcons] *)
+
+let check_function_branch (r,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=r' && (test_eta_args_lift n nargs args) ->
+	MLrel (n+1)
+    | a -> ast_map_lift genrec n a
+  in genrec 0 c
+
+(*s [check_constant_branch (r,l,c)] checks if branch [c] is independent
+   from the pattern [MLcons(r,l)]. For that is raises [Impossible] if any
+   variable in [l] occurs in [c], and otherwise returns [c] lifted to
+   appear like a function with one arg (for uniformity with the
+   branch-as-function optimization) *)
+
+let check_constant_branch (_,l,c) =
+  let n = List.length l in
+  if ast_occurs_itvl 1 n c then raise Impossible;
+  ast_lift (1-n) c
+
+(* The following structure allows to record which element occurred
+   at what position, and then finally return the most frequent
+   element and its positions. *)
+
+let census_add, census_max, census_clean =
+  let h = Hashtbl.create 13 in
+  let clear () = Hashtbl.clear h in
+  let add e i =
+    let l = try Hashtbl.find h e with Not_found -> [] in
+    Hashtbl.replace h e (i::l)
+  in
+  let max e0 =
+    let len = ref 0 and lst = ref [] and elm = ref e0 in
+    Hashtbl.iter
+      (fun e l ->
+	 let n = List.length l in
+	 if n > !len then begin len := n; lst := l; elm := e end)
+      h;
+    (!elm,!lst)
+  in
+  (add,max,clear)
+
+(* Given an abstraction function [abstr] (one of [check_*_branch]),
+   return the longest possible list of branches that have the
+   same abstraction, along with this abstraction. *)
+
+let factor_branches abstr br =
+  census_clean ();
+  for i = 0 to Array.length br - 1 do
+    try census_add (abstr br.(i)) i with Impossible -> ()
+  done;
+  let br_factor, br_list = census_max MLdummy in
+  if br_list = [] then None
+  else if Array.length br >= 2 && List.length br_list < 2 then None
+  else Some (br_factor, br_list)
+
+(*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 both the identity case optimization and the constant case optimisation
+  ([f] can be a constant function) *)
+
+(* The optimisation [factor_branches check_function_branch] breaks types
+   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].
+   We check first that there isn't such phantom variable in the inductive type
+   we're considering. *)
+
+let check_optim_id br =
+  let (kn,i) =
+    match br.(0) with (ConstructRef (c,_),_,_) -> c | _ -> assert false
+  in
+  let ip = (snd (lookup_ind kn)).ind_packets.(i) in
+  match ip.ip_optim_id_ok with
+    | Some ok -> ok
+    | None ->
+	let tvars =
+	  intset_union_map_array (intset_union_map_list type_listvar)
+	    ip.ip_types
+	in
+	let ok = (Intset.cardinal tvars = List.length ip.ip_vars) in
+	ip.ip_optim_id_ok <- Some ok;
+	ok
+
+(*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 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
+
+let is_imm_apply = function MLapp (MLrel 1, _) -> 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(Dummy,_,e) -> simpl o (ast_pop e)
+  | MLletin(id,c,e) ->
+      let e = simpl o e in
+      if
+	(is_atomic c) || (is_atomic e) ||
+	(let n = nb_occur_match e in
+	 (n = 0 || (n=1 && (is_tmp id || is_imm_apply e || 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
+
+(* invariant : list [a] of arguments is non-empty *)
+
+and simpl_app o a = function
+  | MLapp (f',a') -> simpl_app o (a'@a) f'
+  | MLlam (Dummy,t) ->
+      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 (is_tmp id || 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)
+
+(* Invariant : all empty matches should now be [MLexn] *)
+
+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
+    (* Swap the case and the lam if possible *)
+    let ids,br = if o.opt_case_fun then permut_case_fun br [] else [],br in
+    let n = List.length ids in
+    if n <> 0 then
+      simpl o (named_lams ids (MLcase (i,ast_lift n e, br)))
+    else
+      (* Does a term [f] exist such that many branches are [(f e)] ? *)
+      let opt1 =
+	if o.opt_case_idr && (o.opt_case_idg || check_optim_id br) then
+	  factor_branches check_function_branch br
+	else None
+      in
+      (* Detect common constant branches. Often a particular case of
+	 branch-as-function optim, but not always (e.g. A->A|B->A) *)
+      let opt2 =
+	if opt1 = None && o.opt_case_cst then
+	  factor_branches check_constant_branch br
+	else opt1
+      in
+      match opt2 with
+	| Some (f,ints) when List.length ints = Array.length br ->
+	    (* if all branches have been factorized, we remove the match *)
+	    simpl o (MLletin (Tmp anonymous_name, e, f))
+	| Some (f,ints) ->
+	    let ci = if ast_occurs 1 f then BranchFun ints else BranchCst ints
+	    in MLcase ((fst i,ci), e, br)
+	| None -> MLcase (i, e, br)
+
+(*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 None in
+    let rec parse_ids i j = function
+      | [] -> ()
+      | Keep :: l -> v.(i) <- Some (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 :: 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 and the target language is strict. *)
+
+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 = [] && lang () <> Haskell && List.mem (Kill Kother) s then
+      MLlam (Dummy, 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 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) ->
+      let a = List.map kill_dummy a in
+      (try
+	 let ids,c = kill_dummy_fix i c in
+	 let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in
+	 let fake' = kill_dummy_args ids (MLrel 1) fake in
+	 ast_subst (MLfix (i,fi,c)) fake'
+       with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a))
+  | MLletin(id, MLfix (i,fi,c),e) ->
+      (try
+	 let ids,c = kill_dummy_fix i 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 (kill_dummy_hd c) in
+	 let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in
+	 let c = eta_red (kill_dummy c) in
+	 if is_atomic c then ast_subst c e else MLletin (id, c, e)
+       with Impossible -> MLletin(id,kill_dummy c,kill_dummy e))
+  | a -> ast_map kill_dummy a
+
+(* Similar function, but acting only on head lambdas and let-ins *)
+
+and kill_dummy_hd = function
+  | MLlam(id,e) -> MLlam(id, kill_dummy_hd e)
+  | MLletin(id,c,e) ->
+      (try
+	 let ids,c = kill_dummy_lams (kill_dummy_hd c) in
+	 let e = kill_dummy_hd (kill_dummy_args ids (MLrel 1) e) in
+	 let c = eta_red (kill_dummy c) in
+	 if is_atomic c then ast_subst c e else MLletin (id, c, e)
+       with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e))
+  | a -> a
+
+and kill_dummy_fix i c =
+  let n = Array.length c in
+  let ids,ci = kill_dummy_lams (kill_dummy_hd 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 rec norm a =
+    let a' = if o.opt_kill_dum then kill_dummy (simpl o a) else simpl o a in
+    if a = a' then a else norm a'
+  in norm 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_tmp_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 (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.
+
+   Moreover, as mentionned by X. Leroy (bug #2241),
+   inling a constant from inside an opaque module might
+   break types. To avoid that, we require below that
+   both [r] and its body are globally visible. This isn't
+   fully satisfactory, since [r] might not be visible (functor),
+   and anyway it might be interesting to inline [r] at least
+   inside its own structure. But to be safe, we adopt this
+   restriction for the moment.
+*)
+
+open Declarations
+
+let inline_test r t =
+  if not (auto_inline ()) then false
+  else
+    let c = match r with ConstRef c -> c | _ -> assert false in
+    let body = try (Global.lookup_constant c).const_body with _ -> None in
+    if body = None then false
+    else
+      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 con_of_string s =
+  let null = empty_dirpath in
+  match repr_dirpath (dirpath_of_string s) with
+    | id :: d -> make_con (MPfile (make_dirpath d)) null (label_of_id id)
+    | [] -> assert false
+
+let manual_inline_set =
+  List.fold_right (fun x -> Cset.add (con_of_string x))
+    [ "Coq.Init.Wf.well_founded_induction_type";
+      "Coq.Init.Wf.well_founded_induction";
+      "Coq.Init.Wf.Acc_iter";
+      "Coq.Init.Wf.Fix_F";
+      "Coq.Init.Wf.Fix";
+      "Coq.Init.Datatypes.andb";
+      "Coq.Init.Datatypes.orb";
+      "Coq.Init.Logic.eq_rec_r";
+      "Coq.Init.Logic.eq_rect_r";
+      "Coq.Init.Specif.proj1_sig";
+    ]
+    Cset.empty
+
+let manual_inline = function
+  | ConstRef c -> Cset.mem c manual_inline_set
+  | _ -> 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 *)
+     || (lang () <> Haskell && not (is_projection r) &&
+         (is_recursor r || manual_inline r || inline_test r t)))
+
diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli
new file mode 100644
index 00000000..deaacc3f
--- /dev/null
+++ b/plugins/extraction/mlutil.mli
@@ -0,0 +1,131 @@
+(************************************************************************)
+(*  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$ 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 : mutual_inductive -> 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 type_expunge_from_sign : abbrev_map -> signature -> ml_type -> ml_type
+
+val isDummy : ml_type -> bool
+val isKill : sign -> bool
+
+val case_expunge : signature -> ml_ast -> ml_ident list * ml_ast
+val term_expunge : signature -> ml_ident 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_name : identifier
+val dummy_name : identifier
+val id_of_name : name -> identifier
+val id_of_mlid : ml_ident -> identifier
+val tmp_id : ml_ident -> ml_ident
+
+(*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns
+    the list [idn;...;id1] and the term [t]. *)
+
+val collect_lams : ml_ast -> ml_ident list * ml_ast
+val collect_n_lams : int -> ml_ast -> ml_ident list * ml_ast
+val remove_n_lams : int -> ml_ast -> ml_ast
+val nb_lams : ml_ast -> int
+val named_lams : ml_ident list -> ml_ast -> ml_ast
+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 mlapp : ml_ast -> ml_ast list -> ml_ast
+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
+
+exception Impossible
+val check_function_branch : ml_branch -> ml_ast
+val check_constant_branch : ml_branch -> ml_ast
+
+(* Classification of signatures *)
+
+type sign_kind =
+  | EmptySig
+  | NonLogicalSig (* at least a [Keep] *)
+  | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *)
+  | SafeLogicalSig (* only [Kill Ktype] *)
+
+val sign_kind : signature -> sign_kind
+
+val sign_no_final_keeps : signature -> signature
diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml
new file mode 100644
index 00000000..a7f0c017
--- /dev/null
+++ b/plugins/extraction/modutil.ml
@@ -0,0 +1,375 @@
+(************************************************************************)
+(*  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$ 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 -> mp
+  | 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
+	 | Miniml.Equiv kne -> do_type (IndRef (mind_of_kn 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 
+	(mind_of_kn 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 (mind_of_kn 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 ->
+    anomaly "reference not found in extracted structure"
+
+
+(*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 (mind_of_kn 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 (mind_of_kn 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 check_implicits = function
+  | MLexn s ->
+      if String.length s > 8 && (s.[0] = 'U' || s.[0] = 'I') then
+	begin
+	  if String.sub s 0 7 = "UNBOUND" then assert false;
+	  if String.sub s 0 8 = "IMPLICIT" then
+	    error_non_implicit (String.sub s 9 (String.length s - 9));
+	end;
+      false
+  | _ -> false
+
+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
+  ignore (struct_ast_search check_implicits opt_struc);
+  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/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli
new file mode 100644
index 00000000..8e04a368
--- /dev/null
+++ b/plugins/extraction/modutil.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  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$ 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/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
new file mode 100644
index 00000000..30004677
--- /dev/null
+++ b/plugins/extraction/ocaml.ml
@@ -0,0 +1,759 @@
+(************************************************************************)
+(*  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$ 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 str_global k r =
+  if is_inline_custom r then find_custom r else Common.pp_global k r
+
+let pp_global k r = str (str_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 mk_ind path s =
+  make_mind (MPfile (dirpath_of_string path)) empty_dirpath (mk_label s)
+
+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 ++ str (get_infix r) ++ pp_rec true a2)
+    | Tglob (r,[]) -> pp_global Type r
+    | Tglob (IndRef(kn,0),l) when kn = mk_ind "Coq.Init.Specif" "sig" ->
+	pp_tuple_light pp_rec l
+    | Tglob (r,l) ->
+	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
+
+
+(** Special hack for constants of type Ascii.ascii : if an
+    [Extract Inductive ascii => char] has been declared, then
+    the constants are directly turned into chars *)
+
+let ind_ascii = mk_ind "Coq.Strings.Ascii" "ascii"
+
+let check_extract_ascii () =
+  try find_custom (IndRef (ind_ascii,0)) = "char" with Not_found -> false
+
+let is_list_cons l =
+ List.for_all (function MLcons (_,ConstructRef(_,_),[]) -> true | _ -> false) l
+
+let pp_char l =
+  let rec cumul = function
+    | [] -> 0
+    | MLcons(_,ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l)
+    | _ -> assert false
+  in str ("'"^Char.escaped (Char.chr (cumul l))^"'")
+
+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 = List.map id_of_mlid fl 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_of_mlid 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(_,ConstructRef ((kn,0),1),l)
+        when kn = ind_ascii && check_extract_ascii () & is_list_cons l ->
+	assert (args=[]);
+	pp_char l
+    | 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) ++ str (get_infix r) ++
+	   (pp_expr true env [] arg2))
+    | MLcons (_,r,args') ->
+	assert (args=[]);
+	let tuple = pp_tuple (pp_expr true env []) args' in
+	if str_global Cons r = "" (* hack Extract Inductive prod *)
+	then tuple
+	else pp_par par (pp_global Cons r ++ spc () ++ tuple)
+    | MLcase (_, t, pv) when is_custom_match pv ->
+	let mkfun (_,ids,e) =
+	  if ids <> [] then named_lams (List.rev ids) e
+	  else dummy_lams (ast_lift 1 e) 1
+	in
+	hov 2 (str (find_custom_match pv) ++ fnl () ++
+		 prvect (fun tr -> pp_expr true env [] (mkfun tr) ++ fnl ()) pv
+	       ++ pp_expr true env [] t)
+    | 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_map id_of_mlid 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_map id_of_mlid 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 (get_infix r) ++ pr_id i2
+      | [] -> pp_global Cons r
+      | ids ->
+	  (* hack Extract Inductive prod *)
+	  (if str_global Cons r = "" then mt () else pp_global Cons r ++ spc ())
+	   ++ pp_boxed_tuple pr_id ids),
+    expr
+
+and pp_pat env (info,factors) pv =
+  let factor_br, factor_l = try match factors with
+    | BranchFun (i::_ as l) -> check_function_branch pv.(i), l
+    | BranchCst (i::_ as l) -> ast_pop (check_constant_branch pv.(i)), l
+    | _ -> MLdummy, []
+  with Impossible -> MLdummy, []
+  in
+  let par = expr_needs_par factor_br in
+  let last = Array.length pv - 1 in
+  prvecti
+    (fun i x -> if List.mem i factor_l then mt () else
+       let s1,s2 = pp_one_pat env info x in
+       hov 2 (s1 ++ str " ->" ++ spc () ++ s2) ++
+       if i = last && factor_l = [] then mt () else
+       fnl () ++ str "  | ") pv
+  ++
+  if factor_l = [] then mt () else match factors with
+    | BranchFun _ ->
+	let ids, env' = push_vars [anonymous_name] env in
+	hov 2 (pr_id (List.hd ids) ++ str " ->" ++ spc () ++
+	       pp_expr par env' [] factor_br)
+    | BranchCst _ ->
+	hov 2 (str "_ ->" ++ spc () ++ pp_expr par env [] factor_br)
+    | BranchNone -> mt ()
+
+and pp_function env t =
+  let bl,t' = collect_lams t in
+  let bl,env' = push_vars (List.map id_of_mlid bl) env in
+  match t' with
+    | MLcase(i,MLrel 1,pv) when fst i=Standard && not (is_custom_match pv) ->
+	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 (mind_of_kn 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 (mind_of_kn 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 (mind_of_kn 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 (mind_of_kn 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 ((mind_of_kn 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 = (mind_of_kn 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 [] mt in
+      let def' = pp_module_type [] 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 [] 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 params = function
+  | MTident kn ->
+      pp_modname kn
+  | MTfunsig (mbid, mt, mt') ->
+      let typ = pp_module_type [] mt in
+      let name = pp_modname (MPbound mbid) in
+      let def = pp_module_type (MPbound mbid :: params) mt' in
+      str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
+  | MTsig (mp, sign) ->
+      push_visible mp params;
+      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 [];
+      let pp_w = str " with type " ++ ids ++ pp_global Type r in
+      pop_visible();
+      pp_module_type [] mt ++ pp_w ++ str " = " ++ 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 [];
+      let pp_w = str " with module " ++ pp_modname mp_w in
+      pop_visible ();
+      pp_module_type [] mt ++ pp_w ++ 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 [] m.ml_mod_type
+	else mt ()
+      in
+      let def = pp_module_expr [] 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 [] 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 params = function
+  | MEident mp -> pp_modname mp
+  | MEapply (me, me') ->
+      pp_module_expr [] me ++ str "(" ++ pp_module_expr [] me' ++ str ")"
+  | MEfunctor (mbid, mt, me) ->
+      let name = pp_modname (MPbound mbid) in
+      let typ = pp_module_type [] mt in
+      let def = pp_module_expr (MPbound mbid :: params) me in
+      str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
+  | MEstruct (mp, sel) ->
+      push_visible mp params;
+      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 [];
+    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";
+  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/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli
new file mode 100644
index 00000000..4a1c1778
--- /dev/null
+++ b/plugins/extraction/ocaml.mli
@@ -0,0 +1,12 @@
+(************************************************************************)
+(*  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$ i*)
+
+val ocaml_descr : Miniml.language_descr
+
diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
new file mode 100644
index 00000000..108d3685
--- /dev/null
+++ b/plugins/extraction/scheme.ml
@@ -0,0 +1,215 @@
+(************************************************************************)
+(*  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$ 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 (List.map id_of_mlid fl) env in
+	apply (pp_abst (pp_expr env' [] a') (List.rev fl))
+    | MLletin (id,a1,a2) ->
+	let i,env' = push_vars [id_of_mlid 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 (_,t,pv) when is_custom_match pv ->
+	let mkfun (_,ids,e) =
+	  if ids <> [] then named_lams (List.rev ids) e
+	  else dummy_lams (ast_lift 1 e) 1
+	in
+	hov 2 (str (find_custom_match pv) ++ fnl () ++
+		 prvect (fun tr -> pp_expr env [] (mkfun tr) ++ fnl ()) pv
+	       ++ pp_expr env [] t)
+     | 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_map id_of_mlid 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 rec pp_structure_elem = function
+  | (l,SEdecl d) -> pp_decl d
+  | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr
+  | (l,SEmodtype m) -> mt ()
+      (* for the moment we simply discard module type *)
+
+and pp_module_expr = function
+  | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel
+  | MEfunctor _ -> mt ()
+      (* for the moment we simply discard unapplied functors *)
+  | MEident _ | MEapply _ -> assert false
+      (* should be expansed in extract_env *)
+
+let pp_struct =
+  let pp_sel (mp,sel) =
+    push_visible mp [];
+    let p = prlist_strict pp_structure_elem sel in
+    pop_visible (); p
+  in
+  prlist_strict pp_sel
+
+let scheme_descr = {
+  keywords = keywords;
+  file_suffix = ".scm";
+  preamble = preamble;
+  pp_struct = pp_struct;
+  sig_suffix = None;
+  sig_preamble = (fun _ _ _ -> mt ());
+  pp_sig = (fun _ -> mt ());
+  pp_decl = pp_decl;
+}
diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli
new file mode 100644
index 00000000..b0fa395c
--- /dev/null
+++ b/plugins/extraction/scheme.mli
@@ -0,0 +1,11 @@
+(************************************************************************)
+(*  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$ i*)
+
+val scheme_descr : Miniml.language_descr
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
new file mode 100644
index 00000000..685b84fc
--- /dev/null
+++ b/plugins/extraction/table.ml
@@ -0,0 +1,767 @@
+(************************************************************************)
+(*  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$ i*)
+
+open Names
+open Term
+open Declarations
+open Nameops
+open Namegen
+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 repr_of_r = function
+  | ConstRef kn -> repr_con kn
+  | IndRef (kn,_)
+  | ConstructRef ((kn,_),_) -> repr_mind kn
+  | VarRef _ -> assert false
+
+let modpath_of_r r =
+  let mp,_,_ = repr_of_r r in mp
+
+let label_of_r r =
+  let _,_,l = repr_of_r r in l
+
+let rec base_mp = function
+  | MPdot (mp,l) -> base_mp mp
+  | mp -> mp
+
+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 rec mp_length mp =
+  let mp0 = current_toplevel () in
+  let rec len = function
+    | mp when mp = mp0 -> 1
+    | MPdot (mp,_) -> 1 + len mp
+    | _ -> 1
+  in len mp
+
+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
+    | [] -> None
+    | mp :: l -> if MPset.mem mp prefixes then Some 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 rec parse_labels2 ll mp1 = function
+  | mp when mp1=mp -> mp,ll
+  | MPdot (mp,l) -> parse_labels2 (l::ll) mp1 mp
+  | mp -> mp,ll
+
+let labels_of_ref r =
+  let mp_top = current_toplevel () in
+  let mp,_,l = repr_of_r r in
+  parse_labels2 [l] mp_top 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 (Mindmap.empty : (mutual_inductive_body * ml_ind) Mindmap.t)
+let init_inductives () = inductives := Mindmap.empty
+let add_ind kn mib ml_ind = inductives := Mindmap.add kn (mib,ml_ind) !inductives
+let lookup_ind kn = Mindmap.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 (mind_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_basename_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 string_of_global r =
+ try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r)
+ with _ -> string_of_id (safe_basename_of_global r)
+
+let safe_pr_global r = str (string_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.dirpath_of_module mp) in
+  str (String.concat "." (List.map string_of_id (List.rev lid)))
+
+let pr_long_global ref = pr_path (Nametab.path_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 warning_id s =
+  msg_warning (str ("The identifier "^s^
+		    " contains __ which is reserved for the extraction"))
+
+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 mp1 mp2 =
+  err (str "The Coq modules " ++ pr_long_mp mp1 ++ str " and " ++
+       pr_long_mp mp2 ++ str " have the same ML name.\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.\n" ++
+       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 msg_non_implicit r n id =
+  let name = match id with
+    | Anonymous -> ""
+    | Name id -> "(" ^ string_of_id id ^ ") "
+  in
+  "The " ^ (ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r)
+
+let error_non_implicit msg =
+  err (str (msg ^ " still occurs after extraction.") ++
+       fnl () ++ str "Please check the Extraction Implicit declarations.")
+
+let check_loaded_modfile mp = match base_mp mp with
+  | MPfile dp ->
+      if not (Library.library_is_loaded dp) then begin
+	match base_mp (current_toplevel ()) with
+	  | MPfile dp' when dp<>dp' ->
+	      err (str ("Please load library "^(string_of_dirpath dp^" first.")))
+	  | _ -> ()
+      end
+  | _ -> ()
+
+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 false
+
+let auto_inline () = !auto_inline_ref
+
+let _ = declare_bool_option
+	  {optsync = true;
+	   optname = "Extraction AutoInline";
+	   optkey = ["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 = ["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]
+   - the linear let and beta reduction [opt_lin_let] and [opt_lin_beta]
+     (may lead to complexity blow-up, subsumed by finer reductions
+      when inlining recursors).
+*)
+
+let int_flag_init = 1 + 2 + 4 + 8 (*+ 16*) + 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 = ["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 = ["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)}
+
+let _ = declare_summary "Extraction Lang"
+	  { freeze_function = (fun () -> !lang_ref);
+	    unfreeze_function = ((:=) lang_ref);
+	    init_function = (fun () -> lang_ref := Ocaml) }
+
+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);
+       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) }
+
+(* 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)}
+
+let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ())
+
+(*s Extraction Implicit *)
+
+type int_or_id = ArgInt of int | ArgId of identifier
+
+let implicits_table = ref Refmap.empty
+
+let implicits_of_global r =
+ try Refmap.find r !implicits_table with Not_found -> []
+
+let add_implicits r l =
+  let typ = Global.type_of_global r in
+  let rels,_ =
+    decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in
+  let names = List.rev_map fst rels in
+  let n = List.length names in
+  let check = function
+    | ArgInt i ->
+	if 1 <= i && i <= n then i
+	else err (int i ++ str " is not a valid argument number for " ++
+		  safe_pr_global r)
+    | ArgId id ->
+	(try list_index (Name id) names
+	 with Not_found ->
+	   err (str "No argument " ++ pr_id id ++ str " for " ++
+		safe_pr_global r))
+  in
+  let l' = List.map check l in
+  implicits_table := Refmap.add r l' !implicits_table
+
+(* Registration of operations for rollback. *)
+
+let (implicit_extraction,_) =
+  declare_object
+    {(default_object "Extraction Implicit") with
+       cache_function = (fun (_,(r,l)) -> add_implicits r l);
+       load_function = (fun _ (_,(r,l)) -> add_implicits r l);
+       classify_function = (fun o -> Substitute o);
+       subst_function = (fun (s,(r,l)) -> (fst (subst_global s r), l))
+    }
+
+let _ = declare_summary "Extraction Implicit"
+	  { freeze_function = (fun () -> !implicits_table);
+	    unfreeze_function = ((:=) implicits_table);
+	    init_function = (fun () -> implicits_table := Refmap.empty) }
+
+(* Grammar entries. *)
+
+let extraction_implicit r l =
+  check_inside_section ();
+  Lib.add_anonymous_leaf (implicit_extraction (Nametab.global r,l))
+
+
+(*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'
+
+(* same as [string_of_modfile], but preserves the capital/uncapital 1st char *)
+
+let file_of_modfile mp =
+  let s0 = match mp with
+    | MPfile f -> string_of_id (List.hd (repr_dirpath f))
+    | _ -> assert false
+  in
+  let s = String.copy (string_of_modfile mp) in
+  if s.[0] <> s0.[0] then s.[0] <- s0.[0];
+  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);
+       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) }
+
+(* 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)}
+
+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
+
+let custom_matchs = ref Refmap.empty
+
+let add_custom_match r s =
+  custom_matchs := Refmap.add r s !custom_matchs
+
+let indref_of_match pv =
+  if Array.length pv = 0 then raise Not_found;
+  match pv.(0) with
+    | (ConstructRef (ip,_), _, _) -> IndRef ip
+    | _ -> raise Not_found
+
+let is_custom_match pv =
+  try Refmap.mem (indref_of_match pv) !custom_matchs
+  with Not_found -> false
+
+let find_custom_match pv =
+  Refmap.find (indref_of_match pv) !custom_matchs
+
+(* 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);
+       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) }
+
+let (in_custom_matchs,_) =
+  declare_object
+    {(default_object "ML extractions custom matchs") with
+       cache_function = (fun (_,(r,s)) -> add_custom_match r s);
+       load_function = (fun _ (_,(r,s)) -> add_custom_match r s);
+       classify_function = (fun o -> Substitute o);
+       subst_function = (fun (subs,(r,s)) -> (fst (subst_global subs r), s))
+    }
+
+let _ = declare_summary "ML extractions custom match"
+	  { freeze_function = (fun () -> !custom_matchs);
+	    unfreeze_function = ((:=) custom_matchs);
+	    init_function = (fun () -> custom_matchs := Refmap.empty) }
+
+(* 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 optstr =
+  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));
+	Option.iter (fun s -> Lib.add_anonymous_leaf (in_custom_matchs (g,s)))
+	  optstr;
+	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/plugins/extraction/table.mli b/plugins/extraction/table.mli
new file mode 100644
index 00000000..ae46233d
--- /dev/null
+++ b/plugins/extraction/table.mli
@@ -0,0 +1,167 @@
+(************************************************************************)
+(*  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$ i*)
+
+open Names
+open Libnames
+open Miniml
+open Declarations
+
+val safe_basename_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 warning_id : string -> 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 : module_path -> module_path -> '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 msg_non_implicit : global_reference -> int -> name -> string
+val error_non_implicit : string -> 'a
+
+val info_file : string -> unit
+
+(*s utilities about [module_path] and [kernel_names] and [global_reference] *)
+
+val occur_kn_in_ref : mutual_inductive -> global_reference -> bool
+val repr_of_r : global_reference -> module_path * dir_path * label
+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 file_of_modfile : module_path -> string
+val is_toplevel : module_path -> bool
+val at_toplevel : module_path -> 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 option
+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 : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit
+val lookup_ind : mutual_inductive -> mutual_inductive_body * ml_ind
+
+val add_recursors : Environ.env -> mutual_inductive -> 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 implicits arguments *)
+
+val implicits_of_global : global_reference -> int list
+
+(*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
+
+val is_custom_match : ml_branch array -> bool
+val find_custom_match : ml_branch array -> 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 -> string option -> unit
+
+type int_or_id = ArgInt of int | ArgId of identifier
+val extraction_implicit : reference -> int_or_id 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/plugins/extraction/vo.itarget b/plugins/extraction/vo.itarget
new file mode 100644
index 00000000..1fe09f6f
--- /dev/null
+++ b/plugins/extraction/vo.itarget
@@ -0,0 +1,8 @@
+ExtrOcamlBasic.vo
+ExtrOcamlIntConv.vo
+ExtrOcamlBigIntConv.vo
+ExtrOcamlNatInt.vo
+ExtrOcamlNatBigInt.vo
+ExtrOcamlZInt.vo
+ExtrOcamlZBigInt.vo
+ExtrOcamlString.vo
\ No newline at end of file
diff --git a/plugins/field/LegacyField.v b/plugins/field/LegacyField.v
new file mode 100644
index 00000000..efa53b4e
--- /dev/null
+++ b/plugins/field/LegacyField.v
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Export LegacyField_Compl.
+Require Export LegacyField_Theory.
+Require Export LegacyField_Tactic.
+Declare ML Module "field_plugin".
+
+(* Command declarations are moved to the ML side *)
diff --git a/plugins/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v
new file mode 100644
index 00000000..d4a39296
--- /dev/null
+++ b/plugins/field/LegacyField_Compl.v
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v
new file mode 100644
index 00000000..5c1f228a
--- /dev/null
+++ b/plugins/field/LegacyField_Tactic.v
@@ -0,0 +1,433 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v
new file mode 100644
index 00000000..cc8b043f
--- /dev/null
+++ b/plugins/field/LegacyField_Theory.v
@@ -0,0 +1,650 @@
+(************************************************************************)
+(*  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$ *)
+
+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 |- *; exfalso; 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/plugins/field/field.ml4 b/plugins/field/field.ml4
new file mode 100644
index 00000000..238b4c1e
--- /dev/null
+++ b/plugins/field/field.ml4
@@ -0,0 +1,191 @@
+(************************************************************************)
+(*  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$ *)
+
+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 }
+
+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')
+
+(* 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)}
+
+(* 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 =
+    try match Hipattern.match_with_equation (pf_concl g) with
+      | _,_,Hipattern.PolymorphicLeibnizEq (t,_,_) -> t
+      | _ -> raise Exit
+    with Hipattern.NoEquationFound | Exit ->
+      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/plugins/field/field_plugin.mllib b/plugins/field/field_plugin.mllib
new file mode 100644
index 00000000..3c3e87af
--- /dev/null
+++ b/plugins/field/field_plugin.mllib
@@ -0,0 +1,2 @@
+Field
+Field_plugin_mod
diff --git a/plugins/field/vo.itarget b/plugins/field/vo.itarget
new file mode 100644
index 00000000..22b56f33
--- /dev/null
+++ b/plugins/field/vo.itarget
@@ -0,0 +1,4 @@
+LegacyField_Compl.vo
+LegacyField_Tactic.vo
+LegacyField_Theory.vo
+LegacyField.vo
diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml
new file mode 100644
index 00000000..45365cb2
--- /dev/null
+++ b/plugins/firstorder/formula.ml
@@ -0,0 +1,270 @@
+(************************************************************************)
+(*  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$ *)
+
+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 (decompose_prod_n_assum nevar t1) in
+      fst (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/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli
new file mode 100644
index 00000000..2e89ddb0
--- /dev/null
+++ b/plugins/firstorder/formula.mli
@@ -0,0 +1,77 @@
+(************************************************************************)
+(*  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$ *)
+
+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 -> 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/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
new file mode 100644
index 00000000..9080e7db
--- /dev/null
+++ b/plugins/firstorder/g_ground.ml4
@@ -0,0 +1,148 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma"  i*)
+
+(* $Id$ *)
+
+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=["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=["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")
+
+let gen_ground_tac flag taco ids bases gl=
+  let backup= !qflag in
+    try
+      qflag:=flag;
+      let solver=
+	match taco with
+	    Some tac-> tac
+	  | None-> default_solver in
+      let startseq gl=
+	let seq=empty_seq !ground_depth in
+	extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl 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=
+  onAllHypsAndConcl
+    (function
+	 None->unfold_in_concl (Lazy.force defined_connectives)
+       | Some id->
+	   unfold_in_hyp (Lazy.force defined_connectives)
+	   (Tacexpr.InHypType id)) *)
+
+open Genarg
+open Ppconstr
+open Printer
+let pr_firstorder_using_raw _ _ _ = prlist_with_sep pr_comma pr_reference
+let pr_firstorder_using_glob _ _ _ = prlist_with_sep pr_comma (pr_or_var (pr_located pr_global))
+let pr_firstorder_using_typed _ _ _ = prlist_with_sep pr_comma pr_global
+
+ARGUMENT EXTEND firstorder_using
+  TYPED AS reference_list
+  PRINTED BY pr_firstorder_using_typed
+  RAW_TYPED AS reference_list
+  RAW_PRINTED BY pr_firstorder_using_raw
+  GLOB_TYPED AS reference_list
+  GLOB_PRINTED BY pr_firstorder_using_glob
+| [ "using" reference(a) ] -> [ [a] ]
+| [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> [ a::l ]
+| [ "using" reference(a) reference(b) reference_list(l) ] -> [
+    Flags.if_verbose
+      Pp.msg_warning (Pp.str "Deprecated syntax; use \",\" as separator");
+    a::b::l
+  ]
+| [ ] -> [ [] ]
+END
+
+TACTIC EXTEND firstorder
+    [ "firstorder" tactic_opt(t) firstorder_using(l) ] ->
+      [ gen_ground_tac true (Option.map eval_tactic t) l [] ]
+|   [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] ->
+      [ gen_ground_tac true (Option.map eval_tactic t) [] l ]
+|   [ "firstorder" tactic_opt(t) firstorder_using(l)
+       "with" ne_preident_list(l') ] ->
+      [ gen_ground_tac true (Option.map eval_tactic t) l l' ]
+|   [ "firstorder" tactic_opt(t) ] ->
+      [ gen_ground_tac true (Option.map eval_tactic t) [] [] ]
+END
+
+TACTIC EXTEND gintuition
+  [ "gintuition" tactic_opt(t) ] ->
+     [ gen_ground_tac false (Option.map eval_tactic t) [] [] ]
+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 [])))
+       [] []) gls
+
+
+
+let () =
+  Decl_proof_instr.register_automation_tac default_declarative_automation
+
diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml
new file mode 100644
index 00000000..8a0f02d2
--- /dev/null
+++ b/plugins/firstorder/ground.ml
@@ -0,0 +1,152 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+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/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli
new file mode 100644
index 00000000..3c0e903f
--- /dev/null
+++ b/plugins/firstorder/ground.mli
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  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$ *)
+
+val ground_tac:     Tacmach.tactic ->
+  (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic
+
diff --git a/plugins/firstorder/ground_plugin.mllib b/plugins/firstorder/ground_plugin.mllib
new file mode 100644
index 00000000..447a1fb5
--- /dev/null
+++ b/plugins/firstorder/ground_plugin.mllib
@@ -0,0 +1,8 @@
+Formula
+Unify
+Sequent
+Rules
+Instances
+Ground
+G_ground
+Ground_plugin_mod
diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml
new file mode 100644
index 00000000..810262a6
--- /dev/null
+++ b/plugins/firstorder/instances.ml
@@ -0,0 +1,206 @@
+(************************************************************************)
+(*  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$ 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
+    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/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli
new file mode 100644
index 00000000..95dd22ea
--- /dev/null
+++ b/plugins/firstorder/instances.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  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$ 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/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml
new file mode 100644
index 00000000..515efea7
--- /dev/null
+++ b/plugins/firstorder/rules.ml
@@ -0,0 +1,215 @@
+(************************************************************************)
+(*  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$ *)
+
+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 basename_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
+	 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=
+  onAllHypsAndConcl
+    (function
+	 None->unfold_in_concl (Lazy.force defined_connectives)
+       | Some id ->
+	   unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly))
diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli
new file mode 100644
index 00000000..fc32621c
--- /dev/null
+++ b/plugins/firstorder/rules.mli
@@ -0,0 +1,54 @@
+(************************************************************************)
+(*  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$ *)
+
+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 basename_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/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml
new file mode 100644
index 00000000..685d44a8
--- /dev/null
+++ b/plugins/firstorder/sequent.ml
@@ -0,0 +1,312 @@
+(************************************************************************)
+(*  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$ *)
+
+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 expand_constructor_hints =
+  list_map_append (function
+    | IndRef ind ->
+	list_tabulate (fun i -> ConstructRef (ind,i+1))
+	  (Inductiveops.nconstructors ind)
+    | gr ->
+	[gr])
+
+let extend_with_ref_list l seq gl=
+  let l = expand_constructor_hints l in
+  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 seq
+
+open Auto
+
+let extend_with_auto_hints l seq gl=
+  let seqref=ref seq 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/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli
new file mode 100644
index 00000000..ce0eddcc
--- /dev/null
+++ b/plugins/firstorder/sequent.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+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 extend_with_ref_list : global_reference list ->
+  t -> Proof_type.goal sigma -> t
+
+val extend_with_auto_hints : Auto.hint_db_name list ->
+  t -> Proof_type.goal sigma -> t
+
+val print_cmap: global_reference list CM.t -> unit
diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml
new file mode 100644
index 00000000..e3a4c6a5
--- /dev/null
+++ b/plugins/firstorder/unify.ml
@@ -0,0 +1,143 @@
+(************************************************************************)
+(*  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$ 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/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli
new file mode 100644
index 00000000..d6cb3a08
--- /dev/null
+++ b/plugins/firstorder/unify.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+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/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v
new file mode 100644
index 00000000..07b2973a
--- /dev/null
+++ b/plugins/fourier/Fourier.v
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  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's method to solve linear inequations/equations systems.".*)
+
+Require Export LegacyRing.
+Require Export LegacyField.
+Require Export DiscrR.
+Require Export Fourier_util.
+Declare ML Module "fourier_plugin".
+
+Ltac fourier := abstract (fourierz; field; discrR).
+
+Ltac fourier_eq := apply Rge_antisym; fourier.
diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v
new file mode 100644
index 00000000..0fd92d60
--- /dev/null
+++ b/plugins/fourier/Fourier_util.v
@@ -0,0 +1,222 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml
new file mode 100644
index 00000000..73fb4929
--- /dev/null
+++ b/plugins/fourier/fourier.ml
@@ -0,0 +1,205 @@
+(************************************************************************)
+(*  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$ *)
+
+(* 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/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
new file mode 100644
index 00000000..3f490bab
--- /dev/null
+++ b/plugins/fourier/fourierR.ml
@@ -0,0 +1,629 @@
+(************************************************************************)
+(*  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$ *)
+
+
+
+(* 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_eq_sym ())
+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/plugins/fourier/fourier_plugin.mllib b/plugins/fourier/fourier_plugin.mllib
new file mode 100644
index 00000000..0383b1a8
--- /dev/null
+++ b/plugins/fourier/fourier_plugin.mllib
@@ -0,0 +1,4 @@
+Fourier
+FourierR
+G_fourier
+Fourier_plugin_mod
diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4
new file mode 100644
index 00000000..b952851f
--- /dev/null
+++ b/plugins/fourier/g_fourier.ml4
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  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$ *)
+
+open FourierR
+
+TACTIC EXTEND fourier
+  [ "fourierz" ] -> [ fourier ]
+END
diff --git a/plugins/fourier/vo.itarget b/plugins/fourier/vo.itarget
new file mode 100644
index 00000000..87d82dac
--- /dev/null
+++ b/plugins/fourier/vo.itarget
@@ -0,0 +1,2 @@
+Fourier_util.vo
+Fourier.vo
diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v
new file mode 100644
index 00000000..00302a74
--- /dev/null
+++ b/plugins/funind/Recdef.v
@@ -0,0 +1,48 @@
+(************************************************************************)
+(*  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/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
new file mode 100644
index 00000000..e2cad944
--- /dev/null
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -0,0 +1,1710 @@
+open Printer
+open Util
+open Term
+open Termops
+open Namegen
+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 constructor type_of_t t  =
+(*   let refl_equal_term = Lazy.force refl_equal in *)
+  mkApp(constructor,[|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 =
+  let res =   try
+    begin
+      match kind_of_term t with
+	| App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
+	    eq_constr t1 t2
+	| App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ())  ->
+	    eq_constr t1 t2 && eq_constr a1 a2
+	| _ -> false
+    end
+  with _ -> false
+  in
+(*   observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *)
+  res
+
+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 =
+  let res =
+    try
+      match kind_of_term t with
+	| App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
+	    incompatible_constructor_terms t1 t2
+	| App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) ->
+	    (eq_constr u1 u2 &&
+	       incompatible_constructor_terms t1 t2)
+	| _ -> false
+    with _ -> false
+  in
+  if res then   observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t);
+  res
+
+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 (constructor,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(constructor,[|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 find_rectype env c =
+  let (t, l) = decompose_app (Reduction.whd_betadeltaiota env c) in
+  match kind_of_term t with
+  | Ind ind -> (t, l)
+  | Construct _ -> (t,l)
+  | _ -> raise Not_found
+
+
+let isAppConstruct ?(env=Global.env ()) t =
+  try
+    let t',l = find_rectype (Global.env ()) t in
+    observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist  (t',l)));
+    true
+  with Not_found -> 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:rel_context) x t end_of_type  =
+  let nochange ?t' msg  =
+    begin
+      observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t  ++ str "    " ++ match t' with None -> str "" | Some t -> Printer.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
+    let constructor,t1,t2,t1_typ =
+      try
+	if (eq_constr f_eq (Lazy.force eq))
+	then
+	  let t1 = (args.(1),args.(0))
+	  and t2 = (args.(2),args.(0))
+	  and t1_typ = args.(0)
+	  in
+	  (Lazy.force refl_equal,t1,t2,t1_typ)
+	else
+	  if (eq_constr f_eq (jmeq ()))
+	  then
+	    (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0))
+	  else nochange "not an equality"
+      with _ -> nochange "not an equality"
+    in
+    if not ((closed0 (fst t1)) && (closed0 (snd 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 =  find_rectype env t1
+	  and c2,args2 = find_rectype env t2
+	  in
+	  if not (eq_constr c1 c2) then nochange "cannot solve (diff)";
+	  List.fold_left2 compute_substitution sub args1 args2
+	end
+      else
+	if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2)  "cannot solve (diff)"
+    in
+    let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in
+    let sub = compute_substitution sub (fst t1) (fst 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 constructor t1_typ (fst 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 =
+      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 =
+	 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 hd,args = destApp t_x in
+	  let get_args hd args =
+	    if eq_constr hd (Lazy.force eq)
+	    then (Lazy.force refl_equal,args.(0),args.(1))
+	    else (jmeq_refl (),args.(0),args.(1))
+	  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 (get_args hd args)));
+	      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 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 *)
+	intro_using heq_id;
+	onLastHypId (fun heq_id -> tclTHENLIST [
+	(* 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 (Lazy.force refl_equal) 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;
+		      (fun g -> observe_tac "toto" (
+			 tclTHENSEQ [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
+		      )
+		    ]
+		    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 ((strip_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 = 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
+  Lemmas.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);
+  Lemmas.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 (qualid_of_ident 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 = nLastDecls 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 =  (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 = nLastDecls 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 = nLastDecls 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_ident_away_in_goal 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 (* dep proofs also: *) true 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_ident_away_in_goal
+	  (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/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli
new file mode 100644
index 00000000..ff98f2b9
--- /dev/null
+++ b/plugins/funind/functional_principles_proofs.mli
@@ -0,0 +1,19 @@
+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/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
new file mode 100644
index 00000000..b756492b
--- /dev/null
+++ b/plugins/funind/functional_principles_types.ml
@@ -0,0 +1,737 @@
+open Printer
+open Util
+open Term
+open Termops
+open Namegen
+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:rel_context)  : rel_context =
+    match predicates with
+    | [] -> []
+    |(Name x,v,t)::predicates ->
+       let id =  Namegen.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
+    Lemmas.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_ident_away_in_goal (id_of_string "___________princ_________") []
+  in
+  begin
+    Lemmas.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 ((strip_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
+	 ind,true,prop_sort
+      )
+      funs_indexes
+  in
+  let l_schemes =
+    List.map
+      (Typing.type_of env sigma)
+      (Indrec.build_mutual_induction_scheme 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 = 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 = (strip_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 =  (strip_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 =
+  Dumpglob.pause ();
+  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;
+    Dumpglob.continue ()
+
+
+
+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.build_case_analysis_scheme_default 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 _ =
+  (*  Pp.msgnl (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/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli
new file mode 100644
index 00000000..fb04c6ec
--- /dev/null
+++ b/plugins/funind/functional_principles_types.mli
@@ -0,0 +1,34 @@
+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/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
new file mode 100644
index 00000000..bc400ae1
--- /dev/null
+++ b/plugins/funind/g_indfun.ml4
@@ -0,0 +1,524 @@
+(************************************************************************)
+(*  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 b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc 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 prc prlc bl)
+
+let pr_fun_ind_using_typed prc prlc _ opt_c =
+  match opt_c with
+    | None -> mt ()
+    | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b.Evd.it)
+
+
+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
+       Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ]
+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
+       Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ]
+END
+
+
+let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_comma 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 allHypsAndConcl)
+    (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 = Namegen.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/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
new file mode 100644
index 00000000..38f42844
--- /dev/null
+++ b/plugins/funind/indfun.ml
@@ -0,0 +1,776 @@
+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 =
+	it_mkProd_or_LetIn mkProp (fst (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 =
+  Dumpglob.pause ();
+  let res = 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_gen (do_rewrite_dependent ()) [id])) idl )
+	  (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl)
+	  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
+  in
+    Dumpglob.continue ();
+    res
+
+
+
+
+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
+    ~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 = Topconstr.prod_constr_expr arityc bl in
+        let arity = Constrintern.interp_type sigma env0 arityc in
+	let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in
+        (Environ.push_named (recname,None,arity) env, (recname,impl) :: impls))
+      (env0,[]) lnameargsardef in
+  let rec_impls = Constrintern.set_internalization_env_params rec_impls [] 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 rec local_binders_length = function
+  (* Assume that no `{ ... } contexts occur *)
+  | [] -> 0
+  | Topconstr.LocalRawDef _::bl -> 1 + local_binders_length bl
+  | Topconstr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
+
+let prepare_body (name,annot,args,types,body) rt =
+  let n = 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 =
+  let e_explain e =
+    match e with
+      | ToShow e -> spc () ++ Cerrors.explain_exn e
+      | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()
+  in
+  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) ++
+	     e_explain e)
+    | Defining_principle e ->
+	Pp.msg_warning
+	  (str "Cannot define principle(s) for "++
+	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+	     e_explain e)
+    | _ -> anomaly ""
+
+let error_error names e =
+  let e_explain e =
+    match e with
+      | ToShow e -> spc () ++ Cerrors.explain_exn e
+      | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()
+  in
+  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) ++
+	     e_explain e)
+    | _ -> 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 ->
+	let ce,imps =
+	  Command.interp_definition
+	    (Flags.boxed_definitions ()) bl None body (Some ret_type)
+	in
+	Command.declare_definition
+	  fname (Decl_kinds.Global,Decl_kinds.Definition)
+	  ce imps (fun _ _ -> ())
+    | _ ->
+        let fixpoint_exprl =
+          List.map (fun ((name,annot,bl,types,body),ntn) ->
+            ((name,annot,bl,types,Some body),ntn)) fixpoint_exprl in
+	Command.do_fixpoint 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 = Topconstr.prod_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 = Topconstr.prod_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_path
+      (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),([]:Vernacexpr.decl_notation list)
+		 | (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),
+		     ([]:Vernacexpr.decl_notation list)
+		 | (_,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 (loc, w, pars) ->
+      CRecord (loc,
+	       (match w with Some w -> Some (add_args id new_args w) | _ -> None),
+	       List.map (fun (e,o) -> e, add_args id new_args o) pars)
+  | 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
+   Dumpglob.pause ();
+  (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);
+  Dumpglob.continue ()
+
+
+(* let make_graph _ = assert false	 *)
+
+let do_generate_principle = do_generate_principle warning_error true
+
+
diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml
new file mode 100644
index 00000000..0f048f59
--- /dev/null
+++ b/plugins/funind/indfun_common.ml
@@ -0,0 +1,558 @@
+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 = Namegen.next_ident_away_in_goal (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 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 "eq_refl")
+
+(*****************************************************************)
+(* 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_ind 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 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.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 }
+
+let find_or_none id =
+  try Some
+    (match Nametab.locate (qualid_of_ident 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 (qualid_of_ident (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 functional_induction_rewrite_dependent_proofs = ref true
+let function_debug = ref false
+open Goptions
+
+let functional_induction_rewrite_dependent_proofs_sig = 
+  {
+    optsync = false;
+    optname = "Functional Induction Rewrite Dependent";
+    optkey =  ["Functional";"Induction";"Rewrite";"Dependent"];
+    optread = (fun () -> !functional_induction_rewrite_dependent_proofs);
+    optwrite = (fun b -> functional_induction_rewrite_dependent_proofs := b)
+  }
+let _ = declare_bool_option functional_induction_rewrite_dependent_proofs_sig
+
+let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = true
+
+let function_debug_sig =
+  {
+    optsync = false;
+    optname = "Function debug";
+    optkey =  ["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
+
+
+
+let strict_tcc = ref false
+let is_strict_tcc () = !strict_tcc
+let strict_tcc_sig =
+  {
+    optsync = false;
+    optname = "Raw Function Tcc";
+    optkey =  ["Function_raw_tcc"];
+    optread = (fun () -> !strict_tcc);
+    optwrite = (fun b -> strict_tcc := b)
+  }
+
+let _ = declare_bool_option strict_tcc_sig
+
+
+exception Building_graph of exn
+exception Defining_principle of exn
+exception ToShow of exn
+
+let init_constant dir s =
+  try
+    Coqlib.gen_constant "Function" dir s
+  with e -> raise (ToShow e)
+
+let jmeq () =
+  try
+    (Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+     init_constant ["Logic";"JMeq"] "JMeq")
+  with e -> raise (ToShow e)
+
+let jmeq_rec () =
+  try
+    Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+	  init_constant ["Logic";"JMeq"] "JMeq_rec"
+  with e -> raise (ToShow e)
+
+let jmeq_refl () =
+  try
+    Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+    init_constant ["Logic";"JMeq"] "JMeq_refl"
+  with e -> raise (ToShow e)
diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli
new file mode 100644
index 00000000..6f6607fc
--- /dev/null
+++ b/plugins/funind/indfun_common.mli
@@ -0,0 +1,121 @@
+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
+val jmeq : unit -> Term.constr
+val jmeq_refl : unit -> Term.constr
+
+(* [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
+val do_rewrite_dependent : unit -> bool
+
+(* To localize pb *)
+exception Building_graph of exn
+exception Defining_principle of exn
+exception ToShow of exn
+
+val is_strict_tcc : unit -> bool
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
new file mode 100644
index 00000000..8c22265d
--- /dev/null
+++ b/plugins/funind/invfun.ml
@@ -0,0 +1,1020 @@
+(************************************************************************)
+(*  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 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_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 =
+    Namegen.next_ident_away_in_goal
+      (id_of_string "res")
+      (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt)
+  in
+  let fv_id =
+    Namegen.next_ident_away_in_goal
+      (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 = Namegen.next_ident_away_in_goal 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 = Namegen.next_ident_away_in_goal (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 = Namegen.next_ident_away (Nameops.out_name x) avoid in
+	     (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid
+	  )
+	  ([],pf_ids_of_hyps g)
+	  princ_infos.params
+	  (List.rev params)
+      in
+      let lemmas_bindings =
+	List.rev (fst  (List.fold_left2
+	  (fun (bindings,avoid) (x,_,_) p ->
+	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
+	     (dummy_loc,Rawterm.NamedHyp id,(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.onAllHypsAndConcl (
+       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 () = Lemmas.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
+	 Lemmas.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_induction_scheme (Global.env ()) Evd.empty
+	   (Array.to_list
+	      (Array.mapi
+		 (fun i _ -> (kn,i),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
+	 Lemmas.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/plugins/funind/merge.ml b/plugins/funind/merge.ml
new file mode 100644
index 00000000..f596e2d7
--- /dev/null
+++ b/plugins/funind/merge.ml
@@ -0,0 +1,1032 @@
+(************************************************************************)
+(*  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_subscript !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_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 *)
+  let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in
+  let mie,impls = Command.interp_mutual_inductive indl [] true (* means: not coinductive *) in
+  (* Declare the mutual inductive block with its associated schemes *)
+  ignore (Command.declare_mutual_inductive_with_eliminations Declare.UserVerbose mie impls)
+
+
+(* 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_i (fun i x -> x=c) args1 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 ../.. plugins/funind/merge.cmo" ***
+*** indent-tabs-mode: nil ***
+*** End: ***
+*)
diff --git a/plugins/funind/rawterm_to_relation.ml b/plugins/funind/rawterm_to_relation.ml
new file mode 100644
index 00000000..3c3a36f0
--- /dev/null
+++ b/plugins/funind/rawterm_to_relation.ml
@@ -0,0 +1,1419 @@
+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 = Namegen.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 = Namegen.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
+	    | RLambda _  -> 
+		let rec aux t l = 
+		  match l with 
+		    | [] -> t
+		    | u::l -> 
+			match t with 
+			  | RLambda(loc,na,_,nat,b) -> 
+			      RLetIn(dummy_loc,na,u,aux b l)
+			  | _ -> 
+			      RApp(dummy_loc,t,l)
+		in
+		build_entry_lc env funnames avoid (aux f args)
+	    | 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 = Namegen.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 _  | 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
+	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
+	(****** The next works only if the match is not dependent ****)
+	let results =
+	  List.map
+	    (fun ca ->
+	       let res = build_entry_lc_from_case_term
+	       env types
+	       funname (make_discr)
+	       []  brl
+	       case_resl.to_avoid
+	       ca
+	       in
+	       res
+	    )
+	    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
+
+
+exception Continue
+(*
+   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 env nb_args relname args crossed_types depth rt =
+  observe (str "rebuilding : " ++ pr_rawconstr 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' ->
+			(*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
+			let t' = Pretyping.Default.understand Evd.empty env new_t in
+			let new_env = Environ.push_rel (n,None,t') env in
+			let new_b,id_to_exclude =
+			  rebuild_cons new_env
+			    nb_args relname
+			    args new_crossed_types
+			    (depth + 1) b
+			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(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt])
+		when  eq_as_ref = Lazy.force Coqlib.coq_eq_ref  && n = Anonymous
+		  ->
+		begin
+		  try
+		    observe (str "computing new type for eq : " ++ pr_rawconstr rt);
+		    let t' =
+		      try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue
+		    in
+		    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_env = Environ.push_rel (n,None,t') env in
+		    let new_b,id_to_exclude =
+		      rebuild_cons
+			new_env
+			nb_args relname
+			new_args new_crossed_types
+			(depth + 1) subst_b
+		    in
+		    mkRProd(n,t,new_b),id_to_exclude
+		  with Continue ->
+		    let jmeq = Libnames.IndRef (destInd (jmeq ())) in
+		    let ty' = Pretyping.Default.understand Evd.empty env ty in
+		    let ind,args' = Inductive.find_inductive env ty' in
+		    let mib,_ = Global.lookup_inductive ind in
+		    let nparam = mib.Declarations.mind_nparams in
+		    let params,arg' =
+		      ((Util.list_chop nparam args'))
+		    in
+		    let rt_typ =
+		       RApp(Util.dummy_loc,
+			    RRef (Util.dummy_loc,Libnames.IndRef ind),
+			    (List.map
+			      (fun p -> Detyping.detype false []
+				 (Termops.names_of_rel_context env)
+				 p) params)@(Array.to_list
+				      (Array.make
+					 (List.length args' - nparam)
+					 (mkRHole ()))))
+		    in
+		    let eq' =
+		      RApp(loc1,RRef(loc2,jmeq),[ty;RVar(loc3,id);rt_typ;rt])
+		    in
+		    observe (str "computing new type for jmeq : " ++ pr_rawconstr eq');
+		    let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in
+		    observe (str " computing new type for jmeq : done") ;
+		    let new_args =
+		      match kind_of_term eq'_as_constr with
+			| App(_,[|_;_;ty;_|]) ->
+			    let ty = Array.to_list (snd (destApp ty)) in
+			    let ty' = snd (Util.list_chop nparam ty) in
+			    List.fold_left2
+			      (fun acc var_as_constr arg ->
+				 if isRel var_as_constr
+				 then
+				   let (na,_,_) =
+				     Environ.lookup_rel (destRel var_as_constr) env
+				   in
+				   match na with
+				     | Anonymous -> acc
+				     | Name id' ->
+					 (id',Detyping.detype false []
+					    (Termops.names_of_rel_context env)
+					    arg)::acc
+				 else if isVar var_as_constr
+				 then (destVar var_as_constr,Detyping.detype false []
+					 (Termops.names_of_rel_context env)
+					 arg)::acc
+				 else acc
+			      )
+			      []
+			      arg'
+			      ty'
+			| _ -> assert false
+		    in
+		    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.fold_left
+			(fun args (id,rt) ->
+			   List.map (replace_var_by_term id rt) args
+			)
+			args
+			((id,rt)::new_args)
+		    in
+		    let subst_b =
+		     if is_in_b then b else  replace_var_by_term id rt b
+		    in
+		    let new_env =
+		      let t' = Pretyping.Default.understand Evd.empty env eq' in
+		      Environ.push_rel (n,None,t') env
+		    in
+		    let new_b,id_to_exclude =
+		      rebuild_cons
+			new_env
+			nb_args relname
+			new_args new_crossed_types
+			(depth + 1) subst_b
+		    in
+		    mkRProd(n,eq',new_b),id_to_exclude
+		end
+		  (* 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
+		  *)
+	    | _ ->
+		observe (str "computing new type for prod : " ++ pr_rawconstr rt);
+		let t' = Pretyping.Default.understand Evd.empty env t in
+		let new_env = Environ.push_rel (n,None,t') env in
+		let new_b,id_to_exclude =
+		  rebuild_cons new_env
+		    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
+	  observe (str "computing new type for lambda : " ++ pr_rawconstr rt);
+	  let t' = Pretyping.Default.understand Evd.empty env t in
+	  match n with
+	    | Name id ->
+		let new_env = Environ.push_rel (n,None,t') env in
+		let new_b,id_to_exclude =
+		  rebuild_cons new_env
+		    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 t' = Pretyping.Default.understand Evd.empty env t in
+	  let type_t' = Typing.type_of env Evd.empty t' in
+	  let new_env = Environ.push_rel (n,Some t',type_t') env in
+	  let new_b,id_to_exclude =
+	    rebuild_cons new_env
+	      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 env
+	      nb_args
+	      relname
+	      args (crossed_types)
+	      depth t
+	  in
+	  let t' = Pretyping.Default.understand Evd.empty env new_t in
+	  let new_env = Environ.push_rel (na,None,t') env in
+	  let new_b,id_to_exclude =
+	    rebuild_cons new_env
+	      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 env 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 env 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
+  let env_with_graphs =
+    let rel_arity i funargs =  (* Reduilding arities (with parameters) *)
+      let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list  =
+	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
+    Util.array_fold_left2 (fun env rel_name rel_ar ->
+			     Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities
+  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 env_with_graphs 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),[]
+  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.do_mutual_inductive 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,false,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,false,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/plugins/funind/rawterm_to_relation.mli b/plugins/funind/rawterm_to_relation.mli
new file mode 100644
index 00000000..a314050f
--- /dev/null
+++ b/plugins/funind/rawterm_to_relation.mli
@@ -0,0 +1,16 @@
+
+
+
+(*
+  [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/plugins/funind/rawtermops.ml b/plugins/funind/rawtermops.ml
new file mode 100644
index 00000000..e31f1452
--- /dev/null
+++ b/plugins/funind/rawtermops.ml
@@ -0,0 +1,718 @@
+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 = Namegen.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 = Namegen.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 = Namegen.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 = Namegen.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 = Namegen.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 = Namegen.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 = Namegen.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/plugins/funind/rawtermops.mli b/plugins/funind/rawtermops.mli
new file mode 100644
index 00000000..455e7c89
--- /dev/null
+++ b/plugins/funind/rawtermops.mli
@@ -0,0 +1,126 @@
+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/plugins/funind/recdef.ml b/plugins/funind/recdef.ml
new file mode 100644
index 00000000..3b0b8628
--- /dev/null
+++ b/plugins/funind/recdef.ml
@@ -0,0 +1,1473 @@
+(************************************************************************)
+(*  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$ *)
+
+open Term
+open Termops
+open Namegen
+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_vars_as_displayed [] (pf_type_of gls c)
+
+let qed () = Lemmas.save_named true
+let defined () = Lemmas.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 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 debug_queue = Queue.create ()
+
+
+let rec print_debug_queue e = 
+  let lmsg,goal = Queue.pop debug_queue in 
+  if Queue.is_empty debug_queue 
+  then 
+    msgnl (lmsg ++ (str " raised exception " ++ Cerrors.explain_exn e) ++ str " on goal " ++ goal)
+  else
+    begin
+      print_debug_queue e;
+      msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal);
+    end
+  
+
+let do_observe_tac s tac g = 
+  let goal = Printer.pr_goal (sig_it g) in
+  let lmsg = (str "recdef ") ++ (str s) in 
+  Queue.add (lmsg,goal) debug_queue;
+  try 
+    let v = tac g in 
+    ignore(Queue.pop debug_queue);
+    v
+  with e -> 
+    if not (Queue.is_empty debug_queue)
+    then
+      print_debug_queue e;
+    raise e
+
+(*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 coq_base_constant s =
+  Coqlib.gen_constant_in_modules "RecursiveDefinition"
+    (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) 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_base_constant "le_lt_n_Sm")
+
+let le_trans = function () -> (coq_base_constant "le_trans")
+let le_lt_trans = function () -> (coq_base_constant "le_lt_trans")
+let lt_S_n = function () -> (coq_base_constant "lt_S_n")
+let le_n = function () -> (coq_base_constant "le_n")
+let refl_equal = function () -> (coq_base_constant "eq_refl")
+let eq = function () -> (coq_base_constant "eq")
+let ex = function () -> (coq_base_constant "ex")
+let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig")
+let coq_sig = function () -> (coq_base_constant "sig")
+let coq_O = function () -> (coq_base_constant "O")
+let coq_S = function () -> (coq_base_constant "S")
+
+let gt_antirefl = function () -> (coq_constant "gt_irrefl")
+let lt_n_O = function () -> (coq_base_constant "lt_n_O")
+let lt_n_Sn = function () -> (coq_base_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_base_constant "nat")
+let lt = function () -> (coq_base_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 =
+  observe_tac "mk_intros_and_continue" (
+  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 (* deps proofs also: *) true 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
+		)
+	      ]
+	      
+	else
+	  tclTHENSEQ[
+	    thin thin_intros;
+	    h_intros thin_intros;
+	    cont_function eqs expr
+	  ] 
+  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)) 
+      | _ ->
+	  assert false) g
+(* 	  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
+	      (* dep proofs also: *) true
+	      (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_ident_away_in_goal k_id ids in
+        let ids = k::ids in
+	let h' = next_ident_away_in_goal (h'_id) ids in
+        let ids = h'::ids in
+	let def = next_ident_away_in_goal 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_ident_away_in_goal p_id ids in
+        let ids = p::ids in
+	let pmax = next_ident_away_in_goal pmax_id ids in
+        let ids = pmax::ids in
+	let hle1 = next_ident_away_in_goal hle_id ids in
+        let ids = hle1::ids in
+	let hle2 = next_ident_away_in_goal  hle_id ids in
+	let ids = hle2::ids in
+	let heq = next_ident_away_in_goal 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_ident_away_in_goal rec_res_id ids in
+        let ids = rec_res::ids in
+	let hspec = next_ident_away_in_goal 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_ident_away_in_goal (id_of_string ("wf_R")) ids in
+      let wf_rec_arg =
+	next_ident_away_in_goal
+	  (id_of_string ("Acc_"^(string_of_id rec_arg_id)))
+	  (wf_thm::ids)
+      in
+      let hrec = next_ident_away_in_goal 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"
+		  (onNLastHypsId (nargs+1)
+		     (tclMAP (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_ident_away_in_goal 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_ident_away_in_goal 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
+  (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
+  let sub_gls_types = clear_goals sub_gls_types in
+  (* Pp.msgnl (str "sub_gls_types2 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
+  let res = build_and_l sub_gls_types in
+  res
+
+let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal)   =
+  (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *)
+  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 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_ident_away_in_goal 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)
+;
+    Lemmas.save_named opacity;
+  in
+  start_proof
+    na
+    (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma)
+    sign
+    gls_type
+    hook ;
+  if Indfun_common.is_strict_tcc  ()
+  then
+    by (tclIDTAC)
+  else 
+    begin
+      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)
+    end;
+  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) = Lemmas.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_ident_away_in_goal 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_ident_away_in_goal 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_ident_away_in_goal k_id ids in
+  let p = next_ident_away_in_goal p_id (k::ids) in
+  let v = next_ident_away_in_goal v_id (p::k::ids) in
+  let heq = next_ident_away_in_goal heq_id (v::p::k::ids) in
+  let heq1 = next_ident_away_in_goal heq_id (heq::v::p::k::ids) in
+  let hex = next_ident_away_in_goal 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)]);
+      observe_tac "list_revrite" (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_ident_away_in_goal 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))]
+             (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
+		(* dep proofs also: *) true (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_ident_away_in_goal v_id ids in
+        let ids = v'::ids in
+	let hex' = next_ident_away_in_goal hex_id ids in
+        let ids = hex'::ids in
+	let p' = next_ident_away_in_goal p_id ids in
+        let ids = p'::ids in
+	let new_pmax = next_ident_away_in_goal pmax_id ids in
+        let ids = pmax::ids in
+	let hle1 = next_ident_away_in_goal hle_id ids in
+        let ids = hle1::ids in
+	let hle2 = next_ident_away_in_goal hle_id ids in
+        let ids = hle2::ids in
+	let heq = next_ident_away_in_goal heq_id ids in
+        let ids = heq::ids in
+	let heq2 = next_ident_away_in_goal 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 (* dep proofs also: *) true
+							       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_ident_away_in_goal p_id ids in
+  let ids = p::ids in
+  let v = next_ident_away_in_goal v_id ids in
+  let ids = v::ids in
+  let hex = next_ident_away_in_goal hex_id ids in
+  let ids = hex::ids in
+  let heq1 = next_ident_away_in_goal heq_id ids in
+  let ids = heq1::ids in
+  let hle1 = next_ident_away_in_goal 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 *)
+  observe_tac "prove_eq"  (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
+		_,[] -> observe_tac "base_leaf_eq(1)" (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))
+       | _ ->
+	   (match find_call_occs 0 f expr with
+		_,[] -> observe_tac "base_leaf_eq(2)" ( 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) = Lemmas.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 () -> Lemmas.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 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 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 = 
+    nf_betaiotazeta
+      (interp_gen (OfType None) Evd.empty env ~impls:rec_impls eq) 
+  in
+(*  Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *)
+  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 (qualid_of_ident 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 (qualid_of_ident 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/plugins/funind/recdef_plugin.mllib b/plugins/funind/recdef_plugin.mllib
new file mode 100644
index 00000000..31818c39
--- /dev/null
+++ b/plugins/funind/recdef_plugin.mllib
@@ -0,0 +1,11 @@
+Indfun_common
+Rawtermops
+Recdef
+Rawterm_to_relation
+Functional_principles_proofs
+Functional_principles_types
+Invfun
+Indfun
+Merge
+G_indfun
+Recdef_plugin_mod
diff --git a/plugins/funind/vo.itarget b/plugins/funind/vo.itarget
new file mode 100644
index 00000000..33c96830
--- /dev/null
+++ b/plugins/funind/vo.itarget
@@ -0,0 +1 @@
+Recdef.vo
diff --git a/plugins/micromega/CheckerMaker.v b/plugins/micromega/CheckerMaker.v
new file mode 100644
index 00000000..93b4d213
--- /dev/null
+++ b/plugins/micromega/CheckerMaker.v
@@ -0,0 +1,129 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import Setoid.
+Require Import Decidable.
+Require Import List.
+Require Import Refl.
+
+Set Implicit Arguments.
+
+Section CheckerMaker.
+
+(* 'Formula' is a syntactic representation of a certain kind of propositions. *)
+Variable Formula : Type.
+
+Variable Env : Type.
+
+Variable eval : Env -> Formula -> Prop.
+
+Variable Formula' : Type.
+
+Variable eval' : Env -> Formula' -> Prop.
+
+Variable normalise : Formula -> Formula'.
+
+Variable negate : Formula -> Formula'.
+
+Hypothesis normalise_sound :
+  forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t).
+
+Hypothesis negate_correct :
+  forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)).
+
+Variable Witness : Type.
+
+Variable check_formulas' : list Formula' -> Witness -> bool.
+
+Hypothesis check_formulas'_sound :
+  forall (l : list Formula') (w : Witness),
+    check_formulas' l w = true ->
+      forall env : Env, make_impl (eval' env) l False.
+
+Definition normalise_list : list Formula -> list Formula' := map normalise.
+Definition negate_list : list Formula -> list Formula' := map negate.
+
+Definition check_formulas (l : list Formula) (w : Witness) : bool :=
+  check_formulas' (map normalise l) w.
+
+(* Contraposition of normalise_sound for lists *)
+Lemma normalise_sound_contr : forall (env : Env) (l : list Formula),
+  make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False.
+Proof.
+intros env l; induction l as [| t l IH]; simpl in *.
+trivial.
+intros H1 H2. apply IH. apply H1. now apply normalise_sound.
+Qed.
+
+Theorem check_formulas_sound :
+  forall (l : list Formula) (w : Witness),
+    check_formulas l w = true -> forall env : Env, make_impl (eval env) l False.
+Proof.
+unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *.
+pose proof (check_formulas'_sound H env) as H1; now simpl in H1.
+intro H1. apply normalise_sound in H1.
+pose proof (check_formulas'_sound H env) as H2; simpl in H2.
+apply H2 in H1. now apply normalise_sound_contr.
+Qed.
+
+(* In check_conj_formulas', t2 is supposed to be a list of negations of
+formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then
+check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is
+inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that
+A1 /\ A2 -> B1 /\ B2. *)
+
+Fixpoint check_conj_formulas'
+  (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool :=
+match t2 with
+| nil => true
+| t':: rt2 =>
+  match wits with
+  | nil => false
+  | w :: rwits =>
+    match check_formulas' (t':: t1) w with
+    | true => check_conj_formulas' t1 rwits rt2
+    | false => false
+    end
+  end
+end.
+
+(* checks whether the conjunction of t1 implies the conjunction of t2 *)
+
+Definition check_conj_formulas
+  (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool :=
+    check_conj_formulas' (normalise_list t1) wits (negate_list t2).
+
+Theorem check_conj_formulas_sound :
+  forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness),
+    check_conj_formulas t1 wits t2 = true ->
+      forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2).
+Proof.
+intro t1; induction t2 as [| a2 t2' IH].
+intros; apply make_impl_true.
+intros wits H env.
+unfold check_conj_formulas in H; simpl in H.
+destruct wits as [| w ws]; simpl in H. discriminate.
+case_eq (check_formulas' (negate a2 :: normalise_list t1) w);
+intro H1; rewrite H1 in H; [| discriminate].
+assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by
+now apply check_formulas'_sound with (w := w). clear H1.
+pose proof (IH ws H env) as H1. simpl in H2.
+assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False)
+by auto using normalise_sound_contr. clear H2.
+rewrite <- make_conj_impl in *.
+rewrite make_conj_cons. intro H2. split.
+apply <- negate_correct. intro; now elim H3. exact (H1 H2).
+Qed.
+
+End CheckerMaker.
diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v
new file mode 100644
index 00000000..231004bc
--- /dev/null
+++ b/plugins/micromega/Env.v
@@ -0,0 +1,182 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import ZArith.
+Require Import Coq.Arith.Max.
+Require Import List.
+Set Implicit Arguments.
+
+(* I have addded a Leaf constructor to the varmap data structure (/plugins/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/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v
new file mode 100644
index 00000000..e58f8e68
--- /dev/null
+++ b/plugins/micromega/EnvRing.v
@@ -0,0 +1,1403 @@
+(************************************************************************)
+(*  V      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(* F. Besson: to evaluate polynomials, the original code is using a list.
+   For big polynomials, this is inefficient -- linear access.
+   I have modified the code to use binary trees -- logarithmic access.  *)
+
+
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinList.
+Require Import Env.
+Require Import BinPos.
+Require Import BinNat.
+Require Import BinInt.
+Require Export Ring_theory.
+
+Open Local Scope positive_scope.
+Import RingSyntax.
+
+Section MakeRingPol.
+
+ (* Ring elements *)
+ Variable R:Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
+ Variable req : R -> R -> Prop.
+
+ (* Ring properties *)
+ Variable Rsth : Setoid_Theory R req.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
+
+ (* Coefficients *)
+ Variable C: Type.
+ Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
+ Variable ceqb : C->C->bool.
+ Variable phi : C -> R.
+ Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
+                                cO cI cadd cmul csub copp ceqb phi.
+
+  (* Power coefficients *)
+ Variable Cpow : Set.
+ Variable Cp_phi : N -> Cpow.
+ Variable rpow : R -> Cpow -> R.
+ Variable pow_th : power_theory rI rmul req Cp_phi rpow.
+
+
+ (* R notations *)
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ Notation "x == y" := (req x y).
+
+ (* C notations *)
+ Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
+ Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
+ Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+
+ (* Usefull tactics *)
+  Add Setoid R req Rsth as R_set1.
+ Ltac rrefl := gen_reflexivity Rsth.
+  Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
+  Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
+  Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
+  Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
+ Ltac add_push := gen_add_push radd Rsth Reqe ARth.
+ Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth.
+
+ (* Definition of multivariable polynomials with coefficients in C :
+    Type [Pol] represents [X1 ... Xn].
+    The representation is Horner's where a [n] variable polynomial
+    (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients
+    are polynomials with [n-1] variables (C[X2..Xn]).
+    There are several optimisations to make the repr compacter:
+    - [Pc c] is the constant polynomial of value c
+       == c*X1^0*..*Xn^0
+    - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables.
+        variable indices are shifted of j in Q.
+       == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn}
+    - [PX P i Q] is an optimised Horner form of P*X^i + Q
+        with P not the null polynomial
+       == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn}
+
+    In addition:
+    - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden
+      since they can be represented by the simpler form (PX P (i+j) Q)
+    - (Pinj i (Pinj j P)) is (Pinj (i+j) P)
+    - (Pinj i (Pc c)) is (Pc c)
+ *)
+
+ Inductive Pol : Type :=
+  | Pc : C -> Pol
+  | Pinj : positive -> Pol -> Pol
+  | PX : Pol -> positive -> Pol -> Pol.
+
+ Definition P0 := Pc cO.
+ Definition P1 := Pc cI.
+
+ Fixpoint Peq (P P' : Pol) {struct P'} : bool :=
+  match P, P' with
+  | Pc c, Pc c' => c ?=! c'
+  | Pinj j Q, Pinj j' Q' =>
+    match Pcompare j j' Eq with
+    | Eq => Peq Q Q'
+    | _ => false
+    end
+  | PX P i Q, PX P' i' Q' =>
+    match Pcompare i i' Eq with
+    | Eq => if Peq P P' then Peq Q Q' else false
+    | _ => false
+    end
+  | _, _ => false
+  end.
+
+ Notation " P ?== P' " := (Peq P P').
+
+ Definition mkPinj j P :=
+  match P with
+  | Pc _ => P
+  | Pinj j' Q => Pinj ((j + j'):positive) Q
+  | _ => Pinj j P
+  end.
+
+ Definition mkPinj_pred j P:=
+  match j with
+  | xH => P
+  | xO j => Pinj (Pdouble_minus_one j) P
+  | xI j => Pinj (xO j) P
+  end.
+
+ Definition mkPX P i Q :=
+  match P with
+  | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q
+  | Pinj _ _ => PX P i Q
+  | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q
+  end.
+
+ Definition mkXi i := PX P1 i P0.
+
+ Definition mkX := mkXi 1.
+
+ (** Opposite of addition *)
+
+ Fixpoint Popp (P:Pol) : Pol :=
+  match P with
+  | Pc c => Pc (-! c)
+  | Pinj j Q => Pinj j (Popp Q)
+  | PX P i Q => PX (Popp P) i (Popp Q)
+  end.
+
+ Notation "-- P" := (Popp P).
+
+ (** Addition et subtraction *)
+
+ Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol :=
+  match P with
+  | Pc c1 => Pc (c1 +! c)
+  | Pinj j Q => Pinj j (PaddC Q c)
+  | PX P i Q => PX P i (PaddC Q c)
+  end.
+
+ Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol :=
+  match P with
+  | Pc c1 => Pc (c1 -! c)
+  | Pinj j Q => Pinj j (PsubC Q c)
+  | PX P i Q => PX P i (PsubC Q c)
+  end.
+
+ Section PopI.
+
+  Variable Pop : Pol -> Pol -> Pol.
+  Variable Q : Pol.
+
+  Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol :=
+   match P with
+   | Pc c => mkPinj j (PaddC Q c)
+   | Pinj j' Q' =>
+     match ZPminus j' j with
+     | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
+     | Z0 => mkPinj j (Pop Q' Q)
+     | Zneg k => mkPinj j' (PaddI k Q')
+     end
+   | PX P i Q' =>
+     match j with
+     | xH => PX P i (Pop Q' Q)
+     | xO j => PX P i (PaddI (Pdouble_minus_one j) Q')
+     | xI j => PX P i (PaddI (xO j) Q')
+     end
+   end.
+
+  Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol :=
+   match P with
+   | Pc c => mkPinj j (PaddC (--Q) c)
+   | Pinj j' Q' =>
+     match ZPminus j' j with
+     | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
+     | Z0 => mkPinj j (Pop Q' Q)
+     | Zneg k => mkPinj j' (PsubI k Q')
+     end
+   | PX P i Q' =>
+     match j with
+     | xH => PX P i (Pop Q' Q)
+     | xO j => PX P i (PsubI (Pdouble_minus_one j) Q')
+     | xI j => PX P i (PsubI (xO j) Q')
+     end
+   end.
+
+ Variable P' : Pol.
+
+ Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol :=
+  match P with
+  | Pc c => PX P' i' P
+  | Pinj j Q' =>
+    match j with
+    | xH =>  PX P' i' Q'
+    | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q')
+    | xI j => PX P' i' (Pinj (xO j) Q')
+    end
+  | PX P i Q' =>
+    match ZPminus i i' with
+    | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+    | Z0 => mkPX (Pop P P') i Q'
+    | Zneg k => mkPX (PaddX k P) i Q'
+    end
+  end.
+
+ Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol :=
+  match P with
+  | Pc c => PX (--P') i' P
+  | Pinj j Q' =>
+    match j with
+    | xH =>  PX (--P') i' Q'
+    | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q')
+    | xI j => PX (--P') i' (Pinj (xO j) Q')
+    end
+  | PX P i Q' =>
+    match ZPminus i i' with
+    | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+    | Z0 => mkPX (Pop P P') i Q'
+    | Zneg k => mkPX (PsubX k P) i Q'
+    end
+  end.
+
+
+ End PopI.
+
+ Fixpoint Padd (P P': Pol) {struct P'} : Pol :=
+  match P' with
+  | Pc c' => PaddC P c'
+  | Pinj j' Q' => PaddI Padd Q' j' P
+  | PX P' i' Q' =>
+    match P with
+    | Pc c => PX P' i' (PaddC Q' c)
+    | Pinj j Q =>
+      match j with
+      | xH => PX P' i' (Padd Q Q')
+      | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q')
+      | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
+      end
+    | PX P i Q =>
+      match ZPminus i i' with
+      | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q')
+      | Z0 => mkPX (Padd P P') i (Padd Q Q')
+      | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q')
+      end
+    end
+  end.
+ Notation "P ++ P'" := (Padd P P').
+
+ Fixpoint Psub (P P': Pol) {struct P'} : Pol :=
+  match P' with
+  | Pc c' => PsubC P c'
+  | Pinj j' Q' => PsubI Psub Q' j' P
+  | PX P' i' Q' =>
+    match P with
+    | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c)
+    | Pinj j Q =>
+      match j with
+      | xH => PX (--P') i' (Psub Q Q')
+      | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q')
+      | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
+      end
+    | PX P i Q =>
+      match ZPminus i i' with
+      | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q')
+      | Z0 => mkPX (Psub P P') i (Psub Q Q')
+      | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q')
+      end
+    end
+  end.
+ Notation "P -- P'" := (Psub P P').
+
+ (** Multiplication *)
+
+ Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol :=
+  match P with
+  | Pc c' => Pc (c' *! c)
+  | Pinj j Q => mkPinj j (PmulC_aux Q c)
+  | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c)
+  end.
+
+ Definition PmulC P c :=
+  if c ?=! cO then P0 else
+  if c ?=! cI then P else PmulC_aux P c.
+
+ Section PmulI.
+  Variable Pmul : Pol -> Pol -> Pol.
+  Variable Q : Pol.
+  Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol :=
+   match P with
+   | Pc c => mkPinj j (PmulC Q c)
+   | Pinj j' Q' =>
+     match ZPminus j' j with
+     | Zpos k => mkPinj j (Pmul (Pinj k Q') Q)
+     | Z0 => mkPinj j (Pmul Q' Q)
+     | Zneg k => mkPinj j' (PmulI k Q')
+     end
+   | PX P' i' Q' =>
+     match j with
+     | xH => mkPX (PmulI xH P') i' (Pmul Q' Q)
+     | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q')
+     | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
+     end
+   end.
+
+ End PmulI.
+(* A symmetric version of the multiplication *)
+
+ Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol :=
+   match P'' with
+   | Pc c => PmulC P c
+   | Pinj j' Q' => PmulI Pmul Q' j' P
+   | PX P' i' Q' =>
+     match P with
+     | Pc c => PmulC P'' c
+     | Pinj j Q =>
+       let QQ' :=
+         match j with
+         | xH => Pmul Q Q'
+         | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q'
+         | xI j => Pmul (Pinj (xO j) Q) Q'
+         end in
+       mkPX (Pmul P P') i' QQ'
+     | PX P i Q=>
+       let QQ' := Pmul Q Q' in
+       let PQ' := PmulI Pmul Q' xH P in
+       let QP' := Pmul (mkPinj xH Q) P' in
+       let PP' := Pmul P P' in
+       (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ'
+     end
+  end.
+
+(* Non symmetric *)
+(*
+ Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol :=
+  match P' with
+  | Pc c' => PmulC P c'
+  | Pinj j' Q' => PmulI Pmul_aux Q' j' P
+  | PX P' i' Q' =>
+     (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P)
+  end.
+
+ Definition Pmul P P' :=
+  match P with
+  | Pc c => PmulC P' c
+  | Pinj j Q => PmulI Pmul_aux Q j P'
+  | PX P i Q =>
+    (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P')
+  end.
+*)
+ Notation "P ** P'" := (Pmul P P').
+
+ Fixpoint Psquare (P:Pol) : Pol :=
+   match P with
+   | Pc c => Pc (c *! c)
+   | Pinj j Q => Pinj j (Psquare Q)
+   | PX P i Q =>
+     let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in
+     let Q2 := Psquare Q in
+     let P2 := Psquare P in
+     mkPX (mkPX P2 i P0 ++ twoPQ) i Q2
+   end.
+
+ (** Monomial **)
+
+  Inductive Mon: Set :=
+    mon0: Mon
+  | zmon: positive -> Mon -> Mon
+  | vmon: positive -> Mon -> Mon.
+
+ Fixpoint Mphi(l:Env R) (M: Mon) {struct M} : R :=
+  match M with
+     mon0 => rI
+  | zmon j M1  => Mphi (jump j l) M1
+  | vmon i M1 =>
+     let x := hd 0 l in
+     let xi := pow_pos rmul x i in
+    (Mphi (tail l) M1) * xi
+  end.
+
+ Definition mkZmon j M :=
+   match M with mon0 => mon0 | _ => zmon j M end.
+
+ Definition zmon_pred j M :=
+   match j with xH => M | _ => mkZmon (Ppred j) M end.
+
+ Definition mkVmon i M :=
+   match M with
+   | mon0 => vmon i mon0
+   | zmon j m => vmon i (zmon_pred j m)
+   | vmon i' m => vmon (i+i') m
+   end.
+
+ Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol :=
+   match P, M with
+        _, mon0 => (Pc cO, P)
+   | Pc _, _    => (P, Pc cO)
+   | Pinj j1 P1, zmon j2 M1 =>
+      match (j1 ?= j2) Eq with
+        Eq => let (R,S) := MFactor P1 M1 in
+                 (mkPinj j1 R, mkPinj j1 S)
+      | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in
+                 (mkPinj j1 R, mkPinj j1 S)
+      | Gt => (P, Pc cO)
+      end
+  | Pinj _ _, vmon _ _ => (P, Pc cO)
+  | PX P1 i Q1, zmon j M1 =>
+             let M2 := zmon_pred j M1 in
+             let (R1, S1) := MFactor P1 M in
+             let (R2, S2) := MFactor Q1 M2 in
+               (mkPX R1 i R2, mkPX S1 i S2)
+  | PX P1 i Q1, vmon j M1 =>
+      match (i ?= j) Eq with
+        Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+                 (mkPX R1 i Q1, S1)
+      | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in
+                 (mkPX R1 i Q1, S1)
+      | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+                 (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO))
+      end
+   end.
+
+  Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol :=
+    let (Q1,R1) := MFactor P1 M1 in
+    match R1 with
+     (Pc c) => if c ?=! cO then None
+               else Some (Padd Q1 (Pmul P2 R1))
+    | _ => Some (Padd Q1 (Pmul P2 R1))
+    end.
+
+  Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
+    match POneSubst P1 M1 P2 with
+     Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end
+    | _ => P1
+    end.
+
+  Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol :=
+    match POneSubst P1 M1 P2 with
+     Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end
+    | _ => None
+    end.
+
+  Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}:
+     Pol :=
+    match LM1 with
+     cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
+    | _ => P1
+    end.
+
+  Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol :=
+    match LM1 with
+     cons (M1,P2) LM2 =>
+      match PNSubst P1 M1 P2 n with
+        Some P3 => Some (PSubstL1 P3 LM2 n)
+     |  None => PSubstL P1 LM2 n
+     end
+    | _ => None
+    end.
+
+  Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol :=
+    match PSubstL P1 LM1 n with
+     Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
+    | _ => P1
+    end.
+
+ (** Evaluation of a polynomial towards R *)
+
+ Fixpoint Pphi(l:Env R) (P:Pol) {struct P} : R :=
+  match P with
+  | Pc c => [c]
+  | Pinj j Q => Pphi (jump j l) Q
+  | PX P i Q =>
+     let x := hd 0 l in
+     let xi := pow_pos rmul x i in
+    (Pphi l P) * xi + (Pphi (tail l) Q)
+  end.
+
+ Reserved Notation "P @ l " (at level 10, no associativity).
+ Notation "P @ l " := (Pphi l P).
+ (** Proofs *)
+ Lemma ZPminus_spec : forall x y,
+  match ZPminus x y with
+  | Z0 => x = y
+  | Zpos k => x = (y + k)%positive
+  | Zneg k => y = (x + k)%positive
+  end.
+ Proof.
+  induction x;destruct y.
+  replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+  replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial.
+  apply Pplus_xI_double_minus_one.
+  simpl;trivial.
+  replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial.
+  apply Pplus_xI_double_minus_one.
+  replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+  replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial.
+  rewrite <- Pplus_one_succ_l.
+  rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+  replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial.
+  replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial.
+  rewrite <- Pplus_one_succ_l.
+  rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+  simpl;trivial.
+ Qed.
+
+ Lemma Peq_ok : forall P P',
+    (P ?== P') = true -> forall l, P@l == P'@ l.
+ Proof.
+  induction P;destruct P';simpl;intros;try discriminate;trivial.
+  apply (morph_eq CRmorph);trivial.
+  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+   try discriminate H.
+  rewrite (IHP P' H); rewrite H1;trivial;rrefl.
+  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+   try discriminate H.
+  rewrite H1;trivial. clear H1.
+  assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2);
+   destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H]
+                         |discriminate H].
+  rewrite (H1 H);rewrite (H2 H);rrefl.
+ Qed.
+
+ Lemma Pphi0 : forall l, P0@l == 0.
+ Proof.
+  intros;simpl;apply (morph0 CRmorph).
+ Qed.
+
+Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) ->
+ p @ e1 = p @ e2.
+Proof.
+  induction p ; simpl.
+  reflexivity.
+  intros.
+  apply IHp.
+  intros.
+  unfold jump.
+  apply H.
+  intros.
+  rewrite (IHp1 e1 e2) ; auto.
+  rewrite (IHp2 (tail e1) (tail e2)) ; auto.
+  unfold hd. unfold nth.  rewrite H.  reflexivity.
+  unfold tail.  unfold jump. intros ; apply H.
+Qed.
+
+Lemma Pjump_Pplus : forall P i j l, P @ (jump (i + j) l ) = P @ (jump j (jump i l)).
+Proof.
+  intros. apply env_morph. intros. rewrite <- jump_Pplus.
+  rewrite Pplus_comm.
+  reflexivity.
+Qed.
+
+Lemma Pjump_xO_tail : forall P p l,
+  P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l).
+Proof.
+  intros.
+  apply env_morph.
+  intros.
+  rewrite (@jump_simpl R (xI p)).
+  rewrite (@jump_simpl R (xO p)).
+  reflexivity.
+Qed.
+
+Lemma Pjump_Pdouble_minus_one : forall P p l,
+  P @ (jump (Pdouble_minus_one p) (tail l)) = P @ (jump (xO p) l).
+Proof.
+  intros.
+  apply env_morph.
+  intros.
+  rewrite jump_Pdouble_minus_one.
+  rewrite (@jump_simpl R (xO p)).
+  reflexivity.
+Qed.
+
+
+
+ Lemma Pphi1 : forall l,  P1@l == 1.
+ Proof.
+  intros;simpl;apply (morph1 CRmorph).
+ Qed.
+
+ Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l).
+ Proof.
+  intros j l p;destruct p;simpl;rsimpl.
+  rewrite Pjump_Pplus.
+  reflexivity.
+ Qed.
+
+ Let pow_pos_Pplus :=
+    pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc).
+
+ Lemma mkPX_ok : forall l P i Q,
+  (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l).
+ Proof.
+  intros l P i Q;unfold mkPX.
+  destruct P;try (simpl;rrefl).
+  assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl.
+  rewrite (H (refl_equal true));rewrite (morph0 CRmorph).
+  rewrite mkPinj_ok;rsimpl;simpl;rrefl.
+  assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl.
+  rewrite (H (refl_equal true));trivial.
+  rewrite Pphi0.  rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+
+
+ Ltac Esimpl :=
+  repeat (progress (
+   match goal with
+   | |- context [P0@?l] => rewrite (Pphi0 l)
+   | |- context [P1@?l] => rewrite (Pphi1 l)
+   | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P)
+   | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q)
+   | |- context [[cO]] => rewrite (morph0 CRmorph)
+   | |- context [[cI]] => rewrite (morph1 CRmorph)
+   | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y)
+   | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y)
+   | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y)
+   | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x)
+   end));
+  rsimpl; simpl.
+
+ Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c].
+ Proof.
+  induction P;simpl;intros;Esimpl;trivial.
+  rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c].
+ Proof.
+  induction P;simpl;intros.
+  Esimpl.
+  rewrite IHP;rsimpl.
+  rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c].
+ Proof.
+  induction P;simpl;intros;Esimpl;trivial.
+  rewrite IHP1;rewrite IHP2;rsimpl.
+  mul_push ([c]);rrefl.
+ Qed.
+
+ Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c].
+ Proof.
+  intros c P l; unfold PmulC.
+  assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO).
+  rewrite (H (refl_equal true));Esimpl.
+  assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
+  rewrite (H1 (refl_equal true));Esimpl.
+  apply PmulC_aux_ok.
+ Qed.
+
+ Lemma Popp_ok : forall P l, (--P)@l == - P@l.
+ Proof.
+  induction P;simpl;intros.
+  Esimpl.
+  apply IHP.
+  rewrite IHP1;rewrite IHP2;rsimpl.
+ Qed.
+
+ Ltac Esimpl2 :=
+  Esimpl;
+  repeat (progress (
+   match goal with
+   | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l)
+   | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l)
+   | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
+   | |- context [(--?P)@?l] => rewrite (Popp_ok P l)
+   end)); Esimpl.
+
+
+
+
+ Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l.
+ Proof.
+  induction P';simpl;intros;Esimpl2.
+  generalize P p l;clear P p l.
+  induction P;simpl;intros.
+  Esimpl2;apply (ARadd_comm ARth).
+  assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+  rewrite H;Esimpl. rewrite IHP';rrefl.
+  rewrite H;Esimpl. rewrite IHP';Esimpl.
+  rewrite Pjump_Pplus. rrefl.
+  rewrite H;Esimpl. rewrite IHP.
+  rewrite Pjump_Pplus. rrefl.
+  destruct p0;simpl.
+  rewrite IHP2;simpl. rsimpl.
+  rewrite Pjump_xO_tail. Esimpl.
+  rewrite IHP2;simpl.
+  rewrite Pjump_Pdouble_minus_one.
+  rsimpl.
+  rewrite IHP'.
+  rsimpl.
+  destruct P;simpl.
+  Esimpl2;add_push [c];rrefl.
+  destruct p0;simpl;Esimpl2.
+  rewrite IHP'2;simpl.
+  rewrite Pjump_xO_tail.
+  rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+  rewrite IHP'2;simpl.
+  rewrite Pjump_Pdouble_minus_one. rsimpl.
+  add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+  rewrite IHP'2;rsimpl.
+  unfold tail.
+  add_push (P @ (jump 1 l));rrefl.
+  assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
+  rewrite IHP'1;rewrite IHP'2;rsimpl.
+  add_push (P3 @ (tail l));rewrite H;rrefl.
+  rewrite IHP'1;rewrite IHP'2;simpl;Esimpl.
+  rewrite H;rewrite Pplus_comm.
+  rewrite pow_pos_Pplus;rsimpl.
+  add_push (P3 @ (tail l));rrefl.
+  assert (forall P k l,
+           (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k).
+   induction P;simpl;intros;try apply (ARadd_comm ARth).
+   destruct p2; simpl; try apply (ARadd_comm ARth).
+   rewrite Pjump_xO_tail.
+   apply (ARadd_comm ARth).
+   rewrite Pjump_Pdouble_minus_one.
+   apply (ARadd_comm ARth).
+    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
+    rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl.
+    rewrite IHP'1;simpl;Esimpl.
+    rewrite H1;rewrite Pplus_comm.
+    rewrite pow_pos_Pplus;simpl;Esimpl.
+    add_push (P5 @ (tail l0));rrefl.
+    rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+    rewrite pow_pos_Pplus;simpl;rsimpl.
+    add_push (P5 @ (tail l0));rrefl.
+  rewrite H0;rsimpl.
+  add_push (P3 @ (tail l)).
+  rewrite H;rewrite Pplus_comm.
+  rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl.
+  add_push (P3 @ (tail l));rrefl.
+ Qed.
+
+ Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
+ Proof.
+  induction P';simpl;intros;Esimpl2;trivial.
+  generalize P p l;clear P p l.
+  induction P;simpl;intros.
+  Esimpl2;apply (ARadd_comm ARth).
+  assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+  rewrite H;Esimpl. rewrite IHP';rsimpl.
+  rewrite H;Esimpl. rewrite IHP';Esimpl.
+  rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
+  rewrite H;Esimpl. rewrite IHP.
+  rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
+  destruct p0;simpl.
+  rewrite IHP2;simpl; try   rewrite Pjump_xO_tail ; rsimpl.
+  rewrite IHP2;simpl.
+  rewrite Pjump_Pdouble_minus_one;rsimpl.
+  unfold tail ; rsimpl.
+  rewrite IHP';rsimpl.
+  destruct P;simpl.
+  repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl.
+  destruct p0;simpl;Esimpl2.
+  rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial.
+  rewrite Pjump_xO_tail.
+  add_push (P @ ((jump (xI p0) l)));rrefl.
+  rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl.
+  add_push (- (P'1 @ l * pow_pos  rmul (hd 0 l) p));rrefl.
+  unfold tail.
+  rewrite IHP'2;rsimpl;add_push (P @ (jump 1 l));rrefl.
+  assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
+  rewrite IHP'1; rewrite IHP'2;rsimpl.
+  add_push (P3 @ (tail l));rewrite H;rrefl.
+   rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl.
+  rewrite H;rewrite Pplus_comm.
+  rewrite pow_pos_Pplus;rsimpl.
+  add_push (P3 @ (tail l));rrefl.
+  assert (forall P k l,
+           (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k).
+   induction P;simpl;intros.
+   rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial.
+   destruct p2;simpl; rewrite Popp_ok;rsimpl.
+   rewrite Pjump_xO_tail.
+   apply (ARadd_comm ARth);trivial.
+   rewrite Pjump_Pdouble_minus_one.
+   apply (ARadd_comm ARth);trivial.
+   apply (ARadd_comm ARth);trivial.
+    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
+    rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl.
+    rewrite IHP'1;rewrite H1;rewrite Pplus_comm.
+    rewrite pow_pos_Pplus;simpl;Esimpl.
+    add_push (P5 @ (tail l0));rrefl.
+    rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+    rewrite pow_pos_Pplus;simpl;rsimpl.
+    add_push (P5 @ (tail l0));rrefl.
+  rewrite H0;rsimpl.
+  rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)).
+  rewrite H;rewrite Pplus_comm.
+  rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+(* Proof for the symmetric version *)
+
+ Lemma PmulI_ok :
+  forall P',
+   (forall (P : Pol) (l : Env  R), (Pmul P P') @ l == P @ l * P' @ l) ->
+   forall (P : Pol) (p : positive) (l : Env R),
+    (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+  induction P;simpl;intros.
+  Esimpl2;apply (ARmul_comm ARth).
+  assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
+  rewrite H1; rewrite H;rrefl.
+  rewrite H1; rewrite H.
+  rewrite Pjump_Pplus;simpl;rrefl.
+  rewrite H1.
+  rewrite Pjump_Pplus;rewrite IHP;rrefl.
+  destruct p0;Esimpl2.
+  rewrite IHP1;rewrite IHP2;rsimpl.
+  rewrite Pjump_xO_tail.
+  mul_push (pow_pos rmul (hd 0 l) p);rrefl.
+  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p); rewrite Pjump_Pdouble_minus_one.
+  rrefl.
+  rewrite IHP1;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p).
+  rewrite H;rrefl.
+ Qed.
+
+(*
+ Lemma PmulI_ok :
+  forall P',
+   (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) ->
+   forall (P : Pol) (p : positive) (l : list R),
+    (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+  induction P;simpl;intros.
+  Esimpl2;apply (ARmul_comm ARth).
+  assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
+  rewrite H1; rewrite H;rrefl.
+  rewrite H1; rewrite H.
+  rewrite Pplus_comm.
+  rewrite jump_Pplus;simpl;rrefl.
+  rewrite H1;rewrite Pplus_comm.
+  rewrite jump_Pplus;rewrite IHP;rrefl.
+  destruct p0;Esimpl2.
+  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p);rrefl.
+  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
+  rewrite IHP1;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p).
+  rewrite H;rrefl.
+ Qed.
+
+ Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l.
+ Proof.
+  induction P';simpl;intros.
+  Esimpl2;trivial.
+  apply PmulI_ok;trivial.
+  rewrite Padd_ok;Esimpl2.
+  rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl.
+ Qed.
+*)
+
+(* Proof for the symmetric version *)
+ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Proof.
+  intros P P';generalize P;clear P;induction P';simpl;intros.
+  apply PmulC_ok. apply PmulI_ok;trivial.
+  destruct P.
+  rewrite (ARmul_comm ARth);Esimpl2;Esimpl2.
+  Esimpl2. rewrite IHP'1;Esimpl2.
+   assert (match p0 with
+           | xI j => Pinj (xO j) P ** P'2
+           | xO j => Pinj (Pdouble_minus_one j) P ** P'2
+           | 1 => P ** P'2
+           end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)).
+   destruct p0;rewrite IHP'2;Esimpl.
+   rewrite Pjump_xO_tail. reflexivity.
+   rewrite Pjump_Pdouble_minus_one;Esimpl.
+   rewrite H;Esimpl.
+   rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2.
+   repeat (rewrite IHP'1 || rewrite IHP'2);simpl.
+   rewrite PmulI_ok;trivial.
+   unfold tail.
+   mul_push (P'1@l). simpl. mul_push (P'2 @ (jump 1 l)). Esimpl.
+ Qed.
+
+(*
+Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Proof.
+  destruct P;simpl;intros.
+  Esimpl2;apply (ARmul_comm ARth).
+  rewrite (PmulI_ok P (Pmul_aux_ok P)).
+  apply (ARmul_comm ARth).
+  rewrite Padd_ok; Esimpl2.
+  rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial.
+  rewrite Pmul_aux_ok;mul_push (P' @ l).
+  rewrite (ARmul_comm ARth (P' @ l));rrefl.
+ Qed.
+*)
+
+ Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l.
+ Proof.
+  induction P;simpl;intros;Esimpl2.
+  apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2.
+  rewrite IHP1;rewrite IHP2.
+  mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l).
+  rrefl.
+ Qed.
+
+ Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) ->
+   Mphi env P = Mphi env' P.
+ Proof.
+   induction P ; simpl.
+   reflexivity.
+   intros.
+   apply IHP.
+   intros.
+   unfold jump.
+   apply H.
+   (**)
+   intros.
+   replace (Mphi (tail env) P) with (Mphi (tail env') P).
+   unfold hd. unfold nth.
+   rewrite H.
+   reflexivity.
+   apply IHP.
+   unfold tail,jump.
+   intros. symmetry. apply H.
+ Qed.
+
+Lemma Mjump_xO_tail : forall M p l,
+  Mphi  (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M.
+Proof.
+  intros.
+  apply Mphi_morph.
+  intros.
+  rewrite (@jump_simpl R (xI p)).
+  rewrite (@jump_simpl R (xO p)).
+  reflexivity.
+Qed.
+
+Lemma Mjump_Pdouble_minus_one : forall M p l,
+  Mphi (jump (Pdouble_minus_one p) (tail l)) M = Mphi (jump (xO p) l) M.
+Proof.
+  intros.
+  apply Mphi_morph.
+  intros.
+  rewrite jump_Pdouble_minus_one.
+  rewrite (@jump_simpl R (xO p)).
+  reflexivity.
+Qed.
+
+Lemma Mjump_Pplus : forall M i j l, Mphi (jump (i + j) l ) M = Mphi (jump j (jump i l)) M.
+Proof.
+  intros. apply Mphi_morph. intros. rewrite <- jump_Pplus.
+  rewrite Pplus_comm.
+  reflexivity.
+Qed.
+
+
+
+ Lemma mkZmon_ok: forall M j l,
+   Mphi l (mkZmon j M) == Mphi l (zmon j M).
+ intros M j l; case M; simpl; intros; rsimpl.
+ Qed.
+
+ Lemma zmon_pred_ok : forall M j l,
+    Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M).
+ Proof.
+   destruct j; simpl;intros l; rsimpl.
+   rewrite mkZmon_ok;rsimpl.
+   simpl.
+   rewrite Mjump_xO_tail.
+   reflexivity.
+   rewrite mkZmon_ok;simpl.
+   rewrite Mjump_Pdouble_minus_one; rsimpl.
+ Qed.
+
+ Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i.
+ Proof.
+  destruct M;simpl;intros;rsimpl.
+   rewrite zmon_pred_ok;simpl;rsimpl.
+  rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+
+
+ Lemma Mphi_ok: forall P M l,
+    let (Q,R) := MFactor P M in
+      P@l == Q@l + (Mphi l M) * (R@l).
+ Proof.
+ intros P; elim P; simpl; auto; clear P.
+   intros c M l; case M; simpl; auto; try intro p; try intro m;
+   try rewrite (morph0 CRmorph); rsimpl.
+
+   intros i P Hrec M l; case M; simpl; clear M.
+     rewrite (morph0 CRmorph); rsimpl.
+     intros j M.
+     case_eq ((i ?= j) Eq); intros He; simpl.
+       rewrite (Pcompare_Eq_eq _ _ He).
+       generalize (Hrec M (jump j l)); case (MFactor P M);
+        simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+       generalize (Hrec (zmon (j -i) M) (jump i l));
+       case (MFactor P (zmon (j -i) M)); simpl.
+       intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+       rewrite  <- (Pplus_minus _ _ (ZC2 _ _ He)).
+       rewrite Mjump_Pplus; auto.
+       rewrite (morph0 CRmorph); rsimpl.
+       intros P2 m; rewrite (morph0 CRmorph); rsimpl.
+
+   intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto.
+   rewrite (morph0 CRmorph); rsimpl.
+   intros j M1.
+     generalize (Hrec1 (zmon j M1) l);
+     case (MFactor P2 (zmon j M1)).
+     intros R1 S1 H1.
+     generalize (Hrec2 (zmon_pred j M1) (tail l));
+     case (MFactor Q2 (zmon_pred j M1)); simpl.
+     intros R2 S2 H2; rewrite H1; rewrite H2.
+     repeat rewrite mkPX_ok; simpl.
+     rsimpl.
+     apply radd_ext; rsimpl.
+     rewrite (ARadd_comm ARth); rsimpl.
+     apply radd_ext; rsimpl.
+     rewrite (ARadd_comm ARth); rsimpl.
+     rewrite zmon_pred_ok;rsimpl.
+   intros j M1.
+     case_eq ((i ?= j) Eq); intros He; simpl.
+       rewrite (Pcompare_Eq_eq _ _ He).
+       generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       rewrite mkZmon_ok.
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       generalize (Hrec1 (vmon (j - i) M1) l);
+             case (MFactor P2 (vmon (j - i) M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
+       rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       apply rmul_ext; rsimpl.
+       rewrite <- pow_pos_Pplus.
+       rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
+       generalize (Hrec1 (mkZmon 1 M1) l);
+             case (MFactor P2 (mkZmon 1 M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rsimpl.
+       rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       rewrite mkZmon_ok.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       rewrite mkPX_ok; simpl; rsimpl.
+       rewrite (morph0 CRmorph); rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
+       apply rmul_ext; rsimpl.
+       rewrite <- pow_pos_Pplus.
+       rewrite (Pplus_minus _ _ He); rsimpl.
+ Qed.
+
+(* Proof for the symmetric version *)
+
+ Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
+    POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Proof.
+ intros P2 M1 P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
+ intros Q1 R1; case R1.
+   intros c H; rewrite H.
+   generalize (morph_eq CRmorph c cO);
+        case (c ?=! cO); simpl; auto.
+   intros H1 H2; rewrite H1; auto; rsimpl.
+   discriminate.
+   intros _ H1 H2; injection H1; intros; subst.
+   rewrite H2; rsimpl.
+ (* new version *)
+   rewrite Padd_ok; rewrite PmulC_ok; rsimpl.
+ intros i P5 H; rewrite H.
+   intros HH H1; injection HH; intros; subst; rsimpl.
+   rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl.
+ intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+   assert (P4 = Q1 ++ P3 ** PX i P5 P6).
+   injection H2; intros; subst;trivial.
+  rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl.
+Qed.
+(*
+  Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
+    POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+Proof.
+ intros P2 M1 P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
+ intros Q1 R1; case R1.
+   intros c H; rewrite H.
+   generalize (morph_eq CRmorph c cO);
+        case (c ?=! cO); simpl; auto.
+   intros H1 H2; rewrite H1; auto; rsimpl.
+   discriminate.
+   intros _ H1 H2; injection H1; intros; subst.
+   rewrite H2; rsimpl.
+  rewrite Padd_ok; rewrite Pmul_ok; rsimpl.
+  intros i P5 H; rewrite H.
+   intros HH H1; injection HH; intros; subst; rsimpl.
+   rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl.
+   intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+   injection H2; intros; subst; rsimpl.
+   rewrite Padd_ok.
+   rewrite Pmul_ok; rsimpl.
+ Qed.
+*)
+ Lemma PNSubst1_ok: forall n P1 M1 P2 l,
+    Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
+ Proof.
+ intros n; elim n; simpl; auto.
+   intros P2 M1 P3 l H.
+   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+   intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl.
+ intros n1 Hrec P2 M1 P3 l H.
+   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+   intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl.
+ Qed.
+
+ Lemma PNSubst_ok: forall n P1 M1 P2 l P3,
+    PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Proof.
+ intros n P2 M1 P3 l P4; unfold PNSubst.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+ case (POneSubst P2 M1 P3); [idtac | intros; discriminate].
+ intros P5 H1; case n; try (intros; discriminate).
+ intros n1 H2; injection H2; intros; subst.
+ rewrite <- PNSubst1_ok; auto.
+ Qed.
+
+ Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) {struct LM1} : Prop :=
+    match LM1 with
+     cons (M1,P2) LM2 =>  (Mphi l M1 == P2@l) /\ (MPcond LM2 l)
+    | _ => True
+    end.
+
+ Lemma PSubstL1_ok: forall n LM1 P1 l,
+    MPcond LM1 l ->  P1@l == (PSubstL1 P1 LM1 n)@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+   intros; rsimpl.
+ intros (M2,P2) LM2 Hrec P3 l [H H1].
+ rewrite <- Hrec; auto.
+ apply PNSubst1_ok; auto.
+ Qed.
+
+ Lemma PSubstL_ok: forall n LM1 P1 P2 l,
+   PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l ->  P1@l == P2@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+   intros; discriminate.
+ intros (M2,P2) LM2 Hrec P3 P4 l.
+ generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n).
+   intros P5 H0 H1 [H2 H3]; injection H1; intros; subst.
+   rewrite <- PSubstL1_ok; auto.
+ intros l1 H [H1 H2]; auto.
+ Qed.
+
+ Lemma PNSubstL_ok: forall m n LM1 P1 l,
+    MPcond LM1 l ->  P1@l == (PNSubstL P1 LM1 m n)@l.
+ Proof.
+ intros m; elim m; simpl; auto.
+   intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ intros m1 Hrec n LM1 P2 l H.
+ generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ rewrite <- Hrec; auto.
+ Qed.
+
+ (** Definition of polynomial expressions *)
+
+ Inductive PExpr : Type :=
+  | PEc : C -> PExpr
+  | PEX : positive -> PExpr
+  | PEadd : PExpr -> PExpr -> PExpr
+  | PEsub : PExpr -> PExpr -> PExpr
+  | PEmul : PExpr -> PExpr -> PExpr
+  | PEopp : PExpr -> PExpr
+  | PEpow : PExpr -> N -> PExpr.
+
+ (** evaluation of polynomial expressions towards R *)
+ Definition mk_X j := mkPinj_pred j mkX.
+
+ (** evaluation of polynomial expressions towards R *)
+
+ Fixpoint PEeval (l:Env R) (pe:PExpr) {struct pe} : R :=
+   match pe with
+   | PEc c => phi c
+   | PEX j => nth j l
+   | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
+   | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
+   | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
+   | PEopp pe1 => - (PEeval l pe1)
+   | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n)
+   end.
+
+ (** Correctness proofs *)
+
+ Lemma mkX_ok : forall p l, nth  p l == (mk_X p) @ l.
+ Proof.
+  destruct p;simpl;intros;Esimpl;trivial.
+  rewrite nth_spec ; auto.
+  unfold hd.
+  rewrite <- nth_Pdouble_minus_one.
+  rewrite (nth_jump (Pdouble_minus_one p) l 1).
+  reflexivity.
+ Qed.
+
+ Ltac Esimpl3 :=
+  repeat match goal with
+  | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l)
+  | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l)
+  end;Esimpl2;try rrefl;try apply (ARadd_comm ARth).
+
+(* Power using the chinise algorithm *)
+(*Section POWER.
+  Variable subst_l : Pol -> Pol.
+  Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol :=
+   match p with
+   | xH => P
+   | xO p => subst_l (Psquare (Ppow_pos P p))
+   | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p)))
+   end.
+
+  Definition Ppow_N P n :=
+   match n with
+   | N0 => P1
+   | Npos p => Ppow_pos P p
+   end.
+
+  Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+         forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l.
+  Proof.
+   intros l subst_l_ok P.
+   induction p;simpl;intros;try rrefl;try rewrite subst_l_ok.
+   repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+   repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+  Qed.
+
+  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
+         forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+  Proof.  destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial.  Qed.
+
+ End POWER. *)
+
+Section POWER.
+  Variable subst_l : Pol -> Pol.
+  Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
+   match p with
+   | xH => subst_l (Pmul res P)
+   | xO p => Ppow_pos (Ppow_pos res P p) P p
+   | xI p => subst_l (Pmul  (Ppow_pos (Ppow_pos res P p) P p) P)
+   end.
+
+  Definition Ppow_N P n :=
+   match n with
+   | N0 => P1
+   | Npos p => Ppow_pos P1 P p
+   end.
+
+  Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+         forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
+  Proof.
+   intros l subst_l_ok res P p. generalize res;clear res.
+   induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp.
+   rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl.
+  Qed.
+
+  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
+         forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+  Proof.  destruct n;simpl. rrefl. rewrite Ppow_pos_ok. trivial. Esimpl.  auto. Qed.
+
+ End POWER.
+
+ (** Normalization and rewriting *)
+
+ Section NORM_SUBST_REC.
+  Variable n : nat.
+  Variable lmp:list (Mon*Pol).
+  Let subst_l P := PNSubstL P lmp n n.
+  Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
+  Let Ppow_subst := Ppow_N subst_l.
+
+  Fixpoint norm_aux (pe:PExpr) : Pol :=
+   match pe with
+   | PEc c => Pc c
+   | PEX j => mk_X j
+   | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1)
+   | PEadd pe1 (PEopp pe2) =>
+     Psub (norm_aux pe1) (norm_aux pe2)
+   | PEadd pe1 pe2 => Padd (norm_aux  pe1) (norm_aux pe2)
+   | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2)
+   | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2)
+   | PEopp pe1 => Popp (norm_aux pe1)
+   | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
+   end.
+
+  Definition norm_subst pe := subst_l (norm_aux pe).
+
+ (*
+  Fixpoint norm_subst (pe:PExpr) : Pol :=
+   match pe with
+   | PEc c => Pc c
+   | PEX j => subst_l (mk_X j)
+   | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1)
+   | PEadd pe1 (PEopp pe2) =>
+     Psub (norm_subst pe1) (norm_subst pe2)
+   | PEadd pe1 pe2 => Padd (norm_subst  pe1) (norm_subst pe2)
+   | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2)
+   | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2)
+   | PEopp pe1 => Popp (norm_subst pe1)
+   | PEpow pe1 n => Ppow_subst (norm_subst pe1) n
+   end.
+
+  Lemma norm_subst_spec :
+     forall l pe, MPcond lmp l ->
+       PEeval l pe == (norm_subst pe)@l.
+  Proof.
+   intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l).
+      unfold subst_l;intros.
+      rewrite <- PNSubstL_ok;trivial. rrefl.
+   assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l).
+    intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl.
+   induction pe;simpl;Esimpl3.
+   rewrite subst_l_ok;apply mkX_ok.
+   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
+   rewrite IHpe1;rewrite IHpe2;rrefl.
+   rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl.
+   rewrite IHpe;rrefl.
+   unfold Ppow_subst. rewrite Ppow_N_ok. trivial.
+   rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
+      repeat rewrite Pmul_ok;rrefl.
+  Qed.
+*)
+ Lemma norm_aux_spec :
+     forall l pe, (*MPcond lmp l ->*)
+       PEeval l pe == (norm_aux pe)@l.
+  Proof.
+   intros.
+   induction pe;simpl;Esimpl3.
+   apply mkX_ok.
+   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
+   rewrite IHpe1;rewrite IHpe2;rrefl.
+   rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
+   rewrite IHpe;rrefl.
+   rewrite Ppow_N_ok by reflexivity.
+   rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
+      repeat rewrite Pmul_ok;rrefl.
+  Qed.
+
+
+ End NORM_SUBST_REC.
+
+
+End MakeRingPol.
+
diff --git a/plugins/micromega/LICENSE.sos b/plugins/micromega/LICENSE.sos
new file mode 100644
index 00000000..5aadfa2a
--- /dev/null
+++ b/plugins/micromega/LICENSE.sos
@@ -0,0 +1,29 @@
+            HOL Light copyright notice, licence and disclaimer
+
+                     (c) University of Cambridge 1998
+                  (c) Copyright, John Harrison 1998-2006
+
+HOL Light version 2.20, hereinafter referred to as "the software", is a
+computer theorem proving system written by John Harrison. Much of the
+software was developed at the University of Cambridge Computer Laboratory,
+New Museums Site, Pembroke Street, Cambridge, CB2 3QG, England. The
+software is copyright, University of Cambridge 1998 and John Harrison
+1998-2006.
+
+Permission to use, copy, modify, and distribute the software and its
+documentation for any purpose and without fee is hereby granted. In the
+case of further distribution of the software the present text, including
+copyright notice, licence and disclaimer of warranty, must be included in
+full and unmodified form in any release. Distribution of derivative
+software obtained by modifying the software, or incorporating it into
+other software, is permitted, provided the inclusion of the software is
+acknowledged and that any changes made to the software are clearly
+documented.
+
+John Harrison and the University of Cambridge disclaim all warranties
+with regard to the software, including all implied warranties of
+merchantability and fitness. In no event shall John Harrison or the
+University of Cambridge be liable for any special, indirect,
+incidental or consequential damages or any damages whatsoever,
+including, but not limited to, those arising from computer failure or
+malfunction, work stoppage, loss of profit or loss of contracts.
diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v
new file mode 100644
index 00000000..1d7fbd56
--- /dev/null
+++ b/plugins/micromega/MExtraction.v
@@ -0,0 +1,48 @@
+(************************************************************************)
+(*  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 RMicromega.
+Require Import VarMap.
+Require Import RingMicromega.
+Require Import NArith.
+Require Import QArith.
+
+Extract Inductive prod => "( * )" [ "(,)" ].
+Extract Inductive List.list => list [ "[]" "(::)" ].
+Extract Inductive bool => bool [ true false ].
+Extract Inductive sumbool => bool [ true false ].
+Extract Inductive option => option [ Some None ].
+Extract Inductive sumor => option [ Some None ].
+(** Then, in a ternary alternative { }+{ }+{ },
+   -  leftmost choice (Inleft Left) is (Some true),
+   -  middle choice (Inleft Right) is (Some false),
+   -  rightmost choice (Inright) is (None) *)
+
+
+(** To preserve its laziness, andb is normally expansed.
+    Let's rather use the ocaml && *)
+Extract Inlined Constant andb => "(&&)".
+
+Extraction "micromega.ml"
+  List.map simpl_cone (*map_cone  indexes*)
+  denorm Qpower
+  n_of_Z Nnat.N_of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v
new file mode 100644
index 00000000..803dd903
--- /dev/null
+++ b/plugins/micromega/OrderedRing.v
@@ -0,0 +1,458 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                      Evgeny Makarov, INRIA, 2007                     *)
+(************************************************************************)
+
+Require Import Setoid.
+Require Import Ring.
+
+(** Generic properties of ordered rings on a setoid equality *)
+
+Set Implicit Arguments.
+
+Module Import OrderedRingSyntax.
+Export RingSyntax.
+
+Reserved Notation "x ~= y" (at level 70, no associativity).
+Reserved Notation "x [=] y" (at level 70, no associativity).
+Reserved Notation "x [~=] y" (at level 70, no associativity).
+Reserved Notation "x [<] y" (at level 70, no associativity).
+Reserved Notation "x [<=] y" (at level 70, no associativity).
+End OrderedRingSyntax.
+
+Section DEFINITIONS.
+
+Variable R : Type.
+Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
+Variable req rle rlt : R -> R -> Prop.
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+Record SOR : Type := mk_SOR_theory {
+  SORsetoid : Setoid_Theory R req;
+  SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
+  SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2;
+  SORopp_wd : forall x1 x2, x1 == x2 ->  -x1 == -x2;
+  SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2);
+  SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2);
+  SORrt : ring_theory rO rI rplus rtimes rminus ropp req;
+  SORle_refl : forall n : R, n <= n;
+  SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m;
+  SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p;
+  SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m;
+  SORlt_trichotomy : forall n m : R,  n < m \/ n == m \/ m < n;
+  SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m;
+  SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m;
+  SORneq_0_1 : 0 ~= 1
+}.
+
+(* We cannot use Relation_Definitions.order.ord_antisym and
+Relations_1.Antisymmetric because they refer to Leibniz equality *)
+
+End DEFINITIONS.
+
+Section STRICT_ORDERED_RING.
+
+Variable R : Type.
+Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
+Variable req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+
+Add Relation R req
+  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
+  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
+  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+as sor_setoid.
+
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+exact sor.(SORlt_wd).
+Qed.
+
+Add Ring SOR : sor.(SORrt).
+
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+intros x1 x2 H1 y1 y2 H2.
+rewrite (sor.(SORrt).(Rsub_def) x1 y1).
+rewrite (sor.(SORrt).(Rsub_def) x2 y2).
+rewrite H1; now rewrite H2.
+Qed.
+
+Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n.
+Proof.
+intros n m H1 H2; rewrite H2 in H1; now apply H1.
+Qed.
+
+(* Propeties of plus, minus and opp *)
+
+Theorem Rplus_0_l : forall n : R, 0 + n == n.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rplus_0_r : forall n : R, n + 0 == n.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rtimes_0_r : forall n : R, n * 0 == 0.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rplus_comm : forall n m : R, n + m == m + n.
+Proof.
+intros; ring.
+Qed.
+
+Theorem Rtimes_0_l : forall n : R, 0 * n == 0.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rtimes_comm : forall n m : R, n * m == m * n.
+Proof.
+intros; ring.
+Qed.
+
+Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m.
+Proof.
+intros n m.
+split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H.
+now rewrite Rplus_0_l.
+rewrite H; ring.
+Qed.
+
+Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m.
+Proof.
+intros n m p; split; intro H.
+setoid_replace n with (- p + (p + n)) by ring.
+setoid_replace m with (- p + (p + m)) by ring. now rewrite H.
+now rewrite H.
+Qed.
+
+(* Relations *)
+
+Theorem Rle_refl : forall n : R, n <= n.
+Proof sor.(SORle_refl).
+
+Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m.
+Proof sor.(SORle_antisymm).
+
+Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p.
+Proof sor.(SORle_trans).
+
+Theorem Rlt_trichotomy : forall n m : R,  n < m \/ n == m \/ m < n.
+Proof sor.(SORlt_trichotomy).
+
+Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m.
+Proof sor.(SORlt_le_neq).
+
+Theorem Rneq_0_1 : 0 ~= 1.
+Proof sor.(SORneq_0_1).
+
+Theorem Req_em : forall n m : R, n == m \/ n ~= m.
+Proof.
+intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H.
+right; now destruct H.
+now left.
+right; apply Rneq_symm; now destruct H.
+Qed.
+
+Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m.
+Proof.
+intros n m; destruct (Req_em n m) as [H | H].
+split; auto.
+split. intro H1; false_hyp H H1. auto.
+Qed.
+
+Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m.
+Proof.
+intros n m; rewrite Rlt_le_neq.
+split; [intro H | intros [[H1 H2] | H]].
+destruct (Req_em n m) as [H1 | H1]. now right. left; now split.
+assumption.
+rewrite H; apply Rle_refl.
+Qed.
+
+Ltac le_less := rewrite Rle_lt_eq; left; try assumption.
+Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption.
+Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H].
+
+Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p.
+Proof.
+intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split.
+now apply Rle_trans with m.
+intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4.
+Qed.
+
+Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p.
+Proof.
+intros n m p H1 H2; le_elim H1.
+now apply Rlt_trans with (m := m). now rewrite H1.
+Qed.
+
+Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p.
+Proof.
+intros n m p H1 H2; le_elim H2.
+now apply Rlt_trans with (m := m). now rewrite <- H2.
+Qed.
+
+Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n.
+Proof.
+intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]].
+left; now le_less. left; now le_equal. now right.
+Qed.
+
+Theorem Rlt_neq : forall n m : R, n < m -> n ~= m.
+Proof.
+intros n m; rewrite Rlt_le_neq; now intros [_ H].
+Qed.
+
+Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n.
+Proof.
+intros n m; split.
+intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2).
+intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H.
+Qed.
+
+Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n.
+Proof.
+intros n m; split.
+intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2).
+intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption.
+Qed.
+
+(* Plus, minus and order *)
+
+Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m.
+Proof.
+intros n m p; split.
+apply sor.(SORplus_le_mono_l).
+intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H.
+setoid_replace (- p + (p + n)) with n in H by ring.
+setoid_replace (- p + (p + m)) with m in H by ring. assumption.
+Qed.
+
+Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p.
+Proof.
+intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p).
+apply Rplus_le_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m.
+Proof.
+intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l.
+now rewrite <- Rplus_le_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p.
+Proof.
+intros n m p.
+rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l].
+Qed.
+
+Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l].
+Qed.
+
+Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l].
+Qed.
+
+Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l].
+Qed.
+
+Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono.
+Qed.
+
+Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono.
+Qed.
+
+Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono.
+Qed.
+
+Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono.
+Qed.
+
+Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n.
+Proof.
+intros n m. rewrite (@Rplus_le_mono_r n m (- n)).
+setoid_replace (n + - n) with 0 by ring.
+now setoid_replace (m + - n) with (m - n) by ring.
+Qed.
+
+Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n.
+Proof.
+intros n m. rewrite (@Rplus_lt_mono_r n m (- n)).
+setoid_replace (n + - n) with 0 by ring.
+now setoid_replace (m + - n) with (m - n) by ring.
+Qed.
+
+Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n.
+Proof.
+intros n m. split; intro H.
+apply -> (@Rplus_lt_mono_l n m (- n - m)) in H.
+setoid_replace (- n - m + n) with (- m) in H by ring.
+now setoid_replace (- n - m + m) with (- n) in H by ring.
+apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H.
+setoid_replace (n + m + - m) with n in H by ring.
+now setoid_replace (n + m + - n) with m in H by ring.
+Qed.
+
+Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0.
+Proof.
+intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring.
+Qed.
+
+(* Times and order *)
+
+Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m.
+Proof sor.(SORtimes_pos_pos).
+
+Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m.
+Proof.
+intros n m H1 H2.
+le_elim H1. le_elim H2.
+le_less; now apply Rtimes_pos_pos.
+rewrite <- H2; rewrite Rtimes_0_r; le_equal.
+rewrite <- H1; rewrite Rtimes_0_l; le_equal.
+Qed.
+
+Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0.
+Proof.
+intros n m H1 H2. apply -> Ropp_pos_neg.
+setoid_replace (- (n * m)) with (n * (- m)) by ring.
+apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg.
+Qed.
+
+Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m.
+Proof.
+intros n m H1 H2.
+setoid_replace (n * m) with ((- n) * (- m)) by ring.
+apply Rtimes_pos_pos; now apply <- Ropp_pos_neg.
+Qed.
+
+Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n.
+Proof.
+intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]].
+le_less; now apply Rtimes_pos_pos.
+rewrite <- H, Rtimes_0_l; le_equal.
+le_less; now apply Rtimes_neg_neg.
+Qed.
+
+Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0.
+Proof.
+intros n m [H1 H2].
+destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]];
+destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]];
+try (false_hyp H3 H1); try (false_hyp H4 H2).
+apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg.
+apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg.
+apply Rlt_neq. now apply Rtimes_pos_neg.
+apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos.
+Qed.
+
+(* The following theorems are used to build a morphism from Z to R and
+prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *)
+
+(* Surprisingly, multilication is needed to prove the following theorem *)
+
+Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n.
+Proof.
+intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg.
+now setoid_replace (- - n) with n by ring.
+Qed.
+
+Theorem Rlt_0_1 : 0 < 1.
+Proof.
+apply <- Rlt_le_neq. split.
+setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg.
+apply Rneq_0_1.
+Qed.
+
+Theorem Rlt_succ_r : forall n : R, n < 1 + n.
+Proof.
+intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring.
+apply -> Rplus_lt_mono_r. apply Rlt_0_1.
+Qed.
+
+Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m.
+Proof.
+intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r.
+Qed.
+
+(*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m.
+Proof.
+intros n m p H1 H2. apply <- Rlt_lt_minus.
+setoid_replace (p * m - p * n) with (p * (m - n)) by ring.
+apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus.
+Qed.*)
+
+End STRICT_ORDERED_RING.
+
diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v
new file mode 100644
index 00000000..444a590a
--- /dev/null
+++ b/plugins/micromega/Psatz.v
@@ -0,0 +1,86 @@
+(************************************************************************)
+(*  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.
+Declare ML Module "micromega_plugin".
+
+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) ;
+    (* If csdp is not installed, the previous step might not produce any
+    progress: the rest of the tactical will then fail. Hence the 'try'. *)
+    try (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) ;
+    (* If csdp is not installed, the previous step might not produce any
+    progress: the rest of the tactical will then fail. Hence the 'try'. *)
+    try (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 ;
+    (* If csdp is not installed, the previous step might not produce any
+    progress: the rest of the tactical will then fail. Hence the 'try'. *)
+    try (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 ;
+    (* If csdp is not installed, the previous step might not produce any
+    progress: the rest of the tactical will then fail. Hence the 'try'. *)
+    try (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.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v
new file mode 100644
index 00000000..1e909cbc
--- /dev/null
+++ b/plugins/micromega/QMicromega.v
@@ -0,0 +1,197 @@
+(************************************************************************)
+(*  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.
+(*Declare ML Module "micromega_plugin".*)
+
+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.
+  eapply Qle_trans ; eauto.
+  apply (Qlt_not_eq n m H H0) ; auto.
+  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.
+  reflexivity.
+  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  Qeq Qle Qlt (fun x => x) .
+
+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_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d).
+Proof.
+  exact (fun env d =>eval_nformula_dec Qsor (fun x => x)  env d).
+Qed.
+
+Definition QWitness := Psatz Q.
+
+Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult 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 Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool.
+Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool.
+
+Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness)  : bool :=
+  @tauto_checker (Formula Q) (NFormula Q)
+  Qnormalise
+  Qnegate 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 QSORaddon).
+  intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor QSORaddon).
+  intros t w0.
+  apply QWeakChecker_sound.
+Qed.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v
new file mode 100644
index 00000000..21f991ef
--- /dev/null
+++ b/plugins/micromega/RMicromega.v
@@ -0,0 +1,182 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import Refl.
+Require Import Raxioms RIneq Rpow_def DiscrR.
+Require Setoid.
+(*Declare ML Module "micromega_plugin".*)
+
+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  (@eq R) Rle Rlt IZR.
+
+
+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 env d).
+Qed.
+
+Definition RWitness := Psatz Z.
+
+Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult  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 Rnormalise := @cnf_normalise Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
+Definition Rnegate := @cnf_negate Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
+
+Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness)  : bool :=
+  @tauto_checker (Formula Z) (NFormula Z)
+  Rnormalise Rnegate
+  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 RZSORaddon).
+  intros. rewrite Reval_formula_compat. unfold Reval_formula. now apply (cnf_negate_correct Rsor RZSORaddon).
+  intros t w0.
+  apply RWeakChecker_sound.
+Qed.
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v
new file mode 100644
index 00000000..3b0de76b
--- /dev/null
+++ b/plugins/micromega/Refl.v
@@ -0,0 +1,130 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  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/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v
new file mode 100644
index 00000000..d556cd03
--- /dev/null
+++ b/plugins/micromega/RingMicromega.v
@@ -0,0 +1,884 @@
+(************************************************************************)
+(*  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 PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
+Definition PolEnv := Env R. (* For interpreting PolC *)
+Definition eval_pol (env : PolEnv) (p:PolC) : R :=
+   Pphi 0 rplus rtimes phi env p.
+
+Inductive Op1 : Set := (* relations with 0 *)
+| Equal (* == 0 *)
+| NonEqual (* ~= 0 *)
+| Strict (* > 0 *)
+| NonStrict (* >= 0 *).
+
+Definition NFormula := (PolC * 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_pol env p).
+
+
+(** Rule of "signs" for addition and multiplication.
+   An arbitrary result is coded buy None. *)
+
+Definition OpMult (o o' : Op1) : option Op1 :=
+match o with
+| Equal => Some Equal
+| NonStrict =>
+  match o' with
+    | Equal => Some Equal
+    | NonEqual  => None
+    | Strict    => Some NonStrict
+    | NonStrict => Some NonStrict
+  end
+| Strict => match o' with
+              | NonEqual => None
+              |  _       => Some o'
+            end
+| NonEqual => match o' with
+                | Equal => Some Equal
+                | NonEqual => Some NonEqual
+                | _        => None
+              end
+end.
+
+Definition OpAdd (o o': Op1) : option Op1 :=
+  match o with
+    | Equal => Some o'
+    | NonStrict =>
+      match o' with
+        | Strict => Some Strict
+        | NonEqual => None
+        | _ => Some NonStrict
+      end
+    | Strict => match o' with
+                  | NonEqual => None
+                  |  _        => Some Strict
+                end
+    | NonEqual => match o' with
+                    | Equal  => Some NonEqual
+                    | _      => None
+                  end
+  end.
+
+
+Lemma OpMult_sound :
+  forall (o o' om: Op1) (x y : R),
+    eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y).
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' om x y H1 H2 H3.
+(* x == 0 *)
+inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor).
+(* x ~= 0 *)
+destruct o' ; inversion H3.
+ (* y == 0 *)
+ rewrite H2. now rewrite (Rtimes_0_r sor).
+ (* y ~= 0 *)
+ apply (Rtimes_neq_0 sor) ; auto.
+(* 0 < x *)
+destruct o' ; inversion H3.
+ (* y == 0 *)
+ rewrite H2; now rewrite (Rtimes_0_r sor).
+ (* 0 < y *)
+ now apply (Rtimes_pos_pos sor).
+ (* 0 <= y *)
+  apply (Rtimes_nonneg_nonneg sor); [le_less | assumption].
+(* 0 <= x *)
+destruct o' ; inversion H3.
+ (* y == 0 *)
+ rewrite H2; now rewrite (Rtimes_0_r sor).
+ (* 0 < y *)
+ apply (Rtimes_nonneg_nonneg sor); [assumption | le_less ].
+ (* 0 <= y *)
+ now apply (Rtimes_nonneg_nonneg sor).
+Qed.
+
+Lemma OpAdd_sound :
+  forall (o o' oa : Op1) (e e' : R),
+    eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e').
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' oa e e' H1 H2 Hoa.
+(* e == 0 *)
+inversion Hoa. rewrite <- H0.
+destruct o' ; rewrite H1 ; now rewrite  (Rplus_0_l sor).
+(* e ~= 0 *)
+ destruct o'.
+ (* e' == 0 *)
+ inversion Hoa.
+ rewrite H2. now rewrite (Rplus_0_r sor).
+ (* e' ~= 0 *)
+ discriminate.
+ (* 0 < e' *)
+ discriminate.
+ (* 0 <= e' *)
+ discriminate.
+(* 0 < e *)
+ destruct o'.
+ (* e' == 0 *)
+ inversion Hoa.
+ rewrite H2.  now rewrite (Rplus_0_r sor).
+ (* e' ~= 0 *)
+ discriminate.
+ (* 0 < e' *)
+ inversion Hoa.
+ now apply (Rplus_pos_pos sor).
+ (* 0 <= e' *)
+ inversion Hoa.
+ now apply (Rplus_pos_nonneg sor).
+(* 0 <= e *)
+ destruct o'.
+ (* e' == 0 *)
+ inversion Hoa.
+ now rewrite H2, (Rplus_0_r sor).
+ (* e' ~= 0 *)
+ discriminate.
+ (* 0 < e' *)
+ inversion Hoa.
+ now apply (Rplus_nonneg_pos sor).
+ (* 0 <= e' *)
+ inversion Hoa.
+ now apply (Rplus_nonneg_nonneg sor).
+Qed.
+
+Inductive Psatz : Type :=
+| PsatzIn : nat -> Psatz
+| PsatzSquare : PolC -> Psatz
+| PsatzMulC : PolC -> Psatz -> Psatz
+| PsatzMulE : Psatz -> Psatz -> Psatz
+| PsatzAdd  : Psatz -> Psatz -> Psatz
+| PsatzC    : C -> Psatz
+| PsatzZ    : Psatz.
+
+(** Given a list [l] of NFormula and an extended polynomial expression
+   [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a
+   logic consequence of the conjunction of the formulae in l.
+   Moreover, the polynomial expression is obtained by replacing the (PsatzIn n)
+   by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *)
+
+(* Might be defined elsewhere *)
+Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B :=
+  match o with
+    | None => None
+    | Some x => f x
+  end.
+
+Implicit Arguments map_option [A B].
+
+Definition map_option2 (A B C : Type) (f : A -> B -> option C)
+  (o: option A) (o': option B) : option C :=
+  match o , o' with
+    | None , _ => None
+    | _ , None => None
+    | Some x , Some x' => f x x'
+  end.
+
+Implicit Arguments map_option2 [A B C].
+
+Definition Rops_wd := mk_reqe rplus rtimes ropp req
+                       sor.(SORplus_wd)
+                       sor.(SORtimes_wd)
+                       sor.(SORopp_wd).
+
+Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula :=
+  let (ef,o) := f in
+    match o with
+      | Equal => Some (Pmul cO cI cplus ctimes ceqb e ef , Equal)
+      |   _   => None
+    end.
+
+Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula :=
+  let (e1,o1) := f1 in
+    let (e2,o2) := f2 in
+      map_option  (fun x => (Some (Pmul cO cI cplus ctimes ceqb e1 e2,x)))    (OpMult o1 o2).
+
+ Definition nformula_plus_nformula (f1 f2 : NFormula) : option NFormula :=
+  let (e1,o1) := f1 in
+    let (e2,o2) := f2 in
+      map_option  (fun x => (Some (Padd cO cplus ceqb e1 e2,x)))    (OpAdd o1 o2).
+
+
+Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula :=
+  match e with
+    | PsatzIn n => Some (nth n l (Pc cO, Equal))
+    | PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e  , NonStrict)
+    | PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e)
+    | PsatzMulE f1 f2 => map_option2 nformula_times_nformula  (eval_Psatz l f1) (eval_Psatz l f2)
+    | PsatzAdd f1 f2  => map_option2 nformula_plus_nformula  (eval_Psatz l f1) (eval_Psatz l f2)
+    | PsatzC  c  => if cltb cO c then Some (Pc c, Strict) else None
+(* This could be 0, or <> 0 -- but these cases are useless *)
+    | PsatzZ     => Some (Pc cO, Equal) (* Just to make life easier *)
+  end.
+
+Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula),
+  eval_nformula env f -> pexpr_times_nformula e f = Some f' ->
+   eval_nformula env f'.
+Proof.
+  unfold pexpr_times_nformula.
+  destruct f.
+  intros. destruct o ; inversion H0 ; try discriminate.
+  simpl in *.    unfold eval_pol in *.
+  rewrite (Pmul_ok sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm)).
+  rewrite H. apply (Rtimes_0_r sor).
+Qed.
+
+Lemma nformula_times_nformula_correct : forall (env:PolEnv)
+  (f1 f2 f : NFormula),
+  eval_nformula env f1 -> eval_nformula env f2 ->
+  nformula_times_nformula f1 f2 = Some f  ->
+   eval_nformula env f.
+Proof.
+  unfold nformula_times_nformula.
+  destruct f1 ; destruct f2.
+  case_eq (OpMult o o0) ; simpl ; try discriminate.
+  intros. inversion H2 ; simpl.
+  unfold eval_pol.
+  destruct o1; simpl;
+  rewrite (Pmul_ok sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm));
+  apply OpMult_sound with (3:= H);assumption.
+Qed.
+
+Lemma nformula_plus_nformula_correct : forall (env:PolEnv)
+  (f1 f2 f : NFormula),
+  eval_nformula env f1 -> eval_nformula env f2 ->
+  nformula_plus_nformula f1 f2 = Some f  ->
+   eval_nformula env f.
+Proof.
+  unfold nformula_plus_nformula.
+  destruct f1 ; destruct f2.
+  case_eq (OpAdd o o0) ; simpl ; try discriminate.
+  intros. inversion H2 ; simpl.
+  unfold eval_pol.
+  destruct o1; simpl;
+  rewrite (Padd_ok sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm));
+  apply OpAdd_sound with (3:= H);assumption.
+Qed.
+
+Lemma eval_Psatz_Sound :
+  forall (l : list NFormula) (env : PolEnv),
+    (forall (f : NFormula), In f l -> eval_nformula env f) ->
+      forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f ->
+        eval_nformula env f.
+Proof.
+  induction e.
+  (* PsatzIn *)
+  simpl ; intros.
+  destruct (nth_in_or_default n l (Pc cO, Equal)).
+  (* index is in bounds *)
+  apply H ; congruence.
+  (* index is out-of-bounds *)
+  inversion H0.
+  rewrite e. simpl.
+  now apply  addon.(SORrm).(morph0).
+  (* PsatzSquare *)
+  simpl. intros. inversion H0.
+  simpl. unfold eval_pol.
+  rewrite (Psquare_ok sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm));
+  now apply (Rtimes_square_nonneg sor).
+  (* PsatzMulC *)
+  simpl.
+  intro.
+  case_eq  (eval_Psatz l e) ; simpl ; intros.
+  apply IHe in H0.
+  apply pexpr_times_nformula_correct with (1:=H0) (2:= H1).
+  discriminate.
+  (* PsatzMulC *)
+  simpl ; intro.
+  case_eq (eval_Psatz l e1) ; simpl ; try discriminate.
+  case_eq (eval_Psatz l e2) ; simpl ; try discriminate.
+  intros.
+  apply IHe1 in H1. apply IHe2 in H0.
+  apply (nformula_times_nformula_correct env n0 n) ; assumption.
+  (* PsatzAdd *)
+  simpl ; intro.
+  case_eq (eval_Psatz l e1) ; simpl ; try discriminate.
+  case_eq (eval_Psatz l e2) ; simpl ; try discriminate.
+  intros.
+  apply IHe1 in H1. apply IHe2 in H0.
+  apply (nformula_plus_nformula_correct env n0 n) ; assumption.
+  (* PsatzC *)
+  simpl.
+  intro. case_eq (cO [<] c).
+  intros.  inversion H1. simpl.
+  rewrite <- addon.(SORrm).(morph0). now apply cltb_sound.
+  discriminate.
+  (* PsatzZ *)
+  simpl. intros. inversion H0.
+  simpl.   apply  addon.(SORrm).(morph0).
+Qed.
+
+Fixpoint ge_bool (n m  : nat) : bool :=
+ match n with
+   | O   => match m with
+            |  O => true
+            | S _ => false
+          end
+   | S n  => match m with
+               | O => true
+               | S m => ge_bool n m
+             end
+   end.
+
+Lemma ge_bool_cases : forall n m, (if ge_bool n m then n >= m else n < m)%nat.
+Proof.
+  induction n ; simpl.
+  destruct m ; simpl.
+  constructor.
+  omega.
+  destruct m.
+  constructor.
+  omega.
+  generalize (IHn m).
+  destruct (ge_bool n m) ; omega.
+Qed.
+
+
+Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz)  : list nat :=
+  match prf with
+    | PsatzC _ | PsatzZ | PsatzSquare _ => acc
+    | PsatzMulC _ prf => xhyps_of_psatz base acc prf
+    | PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1
+    | PsatzIn n => if ge_bool n base then (n::acc) else acc
+  end.
+
+
+(* roughly speaking, normalise_pexpr_correct is a proof of
+  forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *)
+
+(*****)
+Definition paddC := PaddC cplus.
+Definition psubC := PsubC cminus.
+
+Definition PsubC_ok : forall c P env, eval_pol env (psubC  P c) == eval_pol env P - [c] :=
+  let Rops_wd := mk_reqe rplus rtimes ropp req
+                       sor.(SORplus_wd)
+                       sor.(SORtimes_wd)
+                       sor.(SORopp_wd) in
+                       PsubC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
+                addon.(SORrm).
+
+Definition PaddC_ok : forall c P env, eval_pol env (paddC  P c) == eval_pol env P + [c] :=
+  let Rops_wd := mk_reqe rplus rtimes ropp req
+                       sor.(SORplus_wd)
+                       sor.(SORtimes_wd)
+                       sor.(SORopp_wd) in
+                       PaddC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
+                addon.(SORrm).
+
+
+(* 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  e with
+  | Pc c =>
+    match op with
+    | Equal => cneqb c cO
+    | NonStrict => c [<] cO
+    | Strict => c [<=] cO
+    | NonEqual => c [=] cO
+    end
+  | _ => false (* not a constant *)
+  end.
+
+Lemma check_inconsistent_sound :
+  forall (p : PolC) (op : Op1),
+    check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pol env p).
+Proof.
+intros p op H1 env. unfold check_inconsistent in H1.
+destruct op; simpl ;
+(*****)
+destruct p ; simpl; try discriminate H1;
+try rewrite <- addon.(SORrm).(morph0); trivial.
+now apply cneqb_sound.
+apply addon.(SORrm).(morph_eq) in H1. congruence.
+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 -> Psatz -> bool :=
+  fun l cm =>
+    match eval_Psatz l cm with
+      | None => false
+      | Some f => check_inconsistent f
+    end.
+
+Lemma checker_nf_sound :
+  forall (l : list NFormula) (cm : Psatz),
+    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.
+revert H.
+case_eq (eval_Psatz l cm) ; [|discriminate].
+intros nf. intros.
+rewrite <- make_conj_impl. intro.
+assert (H1' := make_conj_in _ _ H1).
+assert (Hnf :=  @eval_Psatz_Sound  _ _  H1' _ _ H).
+destruct nf.
+apply (@check_inconsistent_sound _ _ H0 env Hnf).
+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.
+
+Definition  eval_pexpr (l : PolEnv) (pe : PExpr C) : R := PEeval rplus rtimes rminus ropp phi pow_phi rpow l pe.
+
+Record Formula : Type := {
+  Flhs : PExpr C;
+  Fop : Op2;
+  Frhs : PExpr C
+}.
+
+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 norm := norm_aux cO cI cplus ctimes cminus copp ceqb.
+
+Definition psub := Psub cO  cplus cminus copp ceqb.
+
+Definition padd  := Padd cO  cplus ceqb.
+
+Definition normalise (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+  let lhs := norm lhs in
+    let rhs := norm rhs in
+  match op with
+  | OpEq =>  (psub  lhs rhs, Equal)
+  | OpNEq => (psub lhs rhs, NonEqual)
+  | OpLe =>  (psub rhs lhs, NonStrict)
+  | OpGe =>  (psub lhs rhs, NonStrict)
+  | OpGt => (psub  lhs rhs, Strict)
+  | OpLt => (psub  rhs lhs, Strict)
+  end.
+
+Definition negate (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+  let lhs := norm lhs in
+    let rhs := norm rhs in
+      match op with
+        | OpEq => (psub rhs lhs, NonEqual)
+        | OpNEq => (psub rhs lhs, Equal)
+        | OpLe => (psub lhs rhs, Strict) (* e <= e' == ~ e > e' *)
+        | OpGe => (psub rhs lhs, Strict)
+        | OpGt => (psub rhs lhs, NonStrict)
+        | OpLt => (psub lhs rhs, NonStrict)
+      end.
+
+
+Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub  lhs rhs) == eval_pol env lhs - eval_pol env rhs.
+Proof.
+  intros.
+  apply (Psub_ok  sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)).
+Qed.
+
+Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd  lhs rhs) == eval_pol env lhs + eval_pol env rhs.
+Proof.
+  intros.
+  apply (Padd_ok  sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)).
+Qed.
+
+Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env  (norm lhs).
+Proof.
+  intros.
+  apply  (norm_aux_spec sor.(SORsetoid) Rops_wd   (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ).
+Qed.
+
+
+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 *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm.
+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 in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm.
+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
+  let lhs := norm lhs in
+    let rhs := norm rhs in
+    match o with
+      | OpEq =>
+        (psub lhs  rhs, Strict)::(psub rhs lhs , Strict)::nil
+      | OpNEq => (psub lhs rhs,Equal) :: nil
+      | OpGt   => (psub rhs lhs,NonStrict) :: nil
+      | OpLt => (psub lhs rhs,NonStrict) :: nil
+      | OpGe => (psub rhs lhs , Strict) :: nil
+      | OpLe => (psub 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;
+    repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ;
+    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
+    let lhs := norm lhs in
+      let rhs := norm rhs in
+    match o with
+      | OpEq  => (psub lhs rhs,Equal) :: nil
+      | OpNEq => (psub lhs  rhs ,Strict)::(psub rhs lhs,Strict)::nil
+      | OpGt  => (psub lhs  rhs,Strict) :: nil
+      | OpLt  => (psub rhs lhs,Strict) :: nil
+      | OpGe  => (psub lhs rhs,NonStrict) :: nil
+      | OpLe  => (psub 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;
+    repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ;
+    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_pol 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.
+
+(** Reverse transformation *)
+
+Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C :=
+  match p with
+    | Pc c => PEc c
+    | Pinj j p => xdenorm  (Pplus j jmp ) p
+    | PX p j q   => PEadd
+      (PEmul (xdenorm jmp p) (PEpow (PEX _  jmp) (Npos j)))
+      (xdenorm (Psucc jmp) q)
+  end.
+
+Lemma xdenorm_correct : forall p i  env, eval_pol (jump i env)  p == eval_pexpr env (xdenorm (Psucc i) p).
+Proof.
+  unfold eval_pol.
+  induction p.
+  simpl. reflexivity.
+  (* Pinj *)
+  simpl.
+  intros.
+  rewrite Pplus_succ_permute_r.
+  rewrite <- IHp.
+  symmetry.
+  rewrite Pplus_comm.
+  rewrite Pjump_Pplus. reflexivity.
+  (* PX *)
+  simpl.
+  intros.
+  rewrite <- IHp1.
+  rewrite <- IHp2.
+  unfold Env.tail , Env.hd.
+  rewrite <- Pjump_Pplus.
+  rewrite <- Pplus_one_succ_r.
+  unfold Env.nth.
+  unfold jump at 2.
+  rewrite Pplus_one_succ_l.
+  rewrite addon.(SORpower).(rpow_pow_N).
+  unfold pow_N. ring.
+Qed.
+
+Definition denorm (p : Pol C)  := xdenorm xH p.
+
+Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p).
+Proof.
+  unfold denorm.
+  induction p.
+  reflexivity.
+  simpl.
+  rewrite <- Pplus_one_succ_r.
+  apply xdenorm_correct.
+  simpl.
+  intros.
+  rewrite IHp1.
+  unfold Env.tail.
+  rewrite xdenorm_correct.
+  change (Psucc xH) with 2%positive.
+  rewrite addon.(SORpower).(rpow_pow_N).
+  simpl. reflexivity.
+Qed.
+
+
+(** Some syntactic simplifications of expressions  *)
+
+
+Definition simpl_cone (e:Psatz) : Psatz :=
+  match e with
+    | PsatzSquare t =>
+                    match t with
+                      | Pc c   => if ceqb cO c then PsatzZ else PsatzC (ctimes c c)
+                      | _ => PsatzSquare t
+                    end
+    | PsatzMulE t1 t2 =>
+      match t1 , t2 with
+        | PsatzZ      , x        => PsatzZ
+        |    x     , PsatzZ      => PsatzZ
+        | PsatzC c ,  PsatzC c' => PsatzC (ctimes c c')
+        | PsatzC p1 , PsatzMulE (PsatzC p2)  x => PsatzMulE (PsatzC (ctimes p1 p2)) x
+        | PsatzC p1 , PsatzMulE x (PsatzC p2)  => PsatzMulE (PsatzC (ctimes p1 p2)) x
+        | PsatzMulE (PsatzC p2)  x  , PsatzC p1   => PsatzMulE (PsatzC (ctimes p1 p2)) x
+        | PsatzMulE x (PsatzC p2)   , PsatzC p1   => PsatzMulE (PsatzC (ctimes p1 p2)) x
+        | PsatzC x   , PsatzAdd y z   => PsatzAdd (PsatzMulE (PsatzC x) y) (PsatzMulE (PsatzC x) z)
+        | PsatzC c ,  _        => if ceqb cI c then t2 else PsatzMulE t1 t2
+        | _ ,  PsatzC c        => if ceqb cI c then t1 else PsatzMulE t1 t2
+        |     _     , _   => e
+      end
+    | PsatzAdd t1 t2 =>
+      match t1 ,  t2 with
+        | PsatzZ     , x => x
+        |   x     , PsatzZ => x
+        |   x     , y   => PsatzAdd x y
+      end
+    |   _     => e
+  end.
+
+
+
+
+End Micromega.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
\ No newline at end of file
diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v
new file mode 100644
index 00000000..b1d02176
--- /dev/null
+++ b/plugins/micromega/Tauto.v
@@ -0,0 +1,327 @@
+(************************************************************************)
+(*  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.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v
new file mode 100644
index 00000000..0a66fce3
--- /dev/null
+++ b/plugins/micromega/VarMap.v
@@ -0,0 +1,259 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  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 (/plugins/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 /plugins/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/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v
new file mode 100644
index 00000000..f27cd15e
--- /dev/null
+++ b/plugins/micromega/ZCoeff.v
@@ -0,0 +1,173 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                      Evgeny Makarov, INRIA, 2007                     *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import ZArith.
+Require Import InitialRing.
+Require Import Setoid.
+
+Import OrderedRingSyntax.
+
+Set Implicit Arguments.
+
+Section InitialMorphism.
+
+Variable R : Type.
+Variables rO rI : R.
+Variables rplus rtimes rminus: R -> R -> R.
+Variable ropp : R -> R.
+Variables req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+Lemma req_refl : forall x, req x x.
+Proof.
+  destruct sor.(SORsetoid).
+  apply Equivalence_Reflexive.
+Qed.
+
+Lemma req_sym : forall x y, req x y -> req y x.
+Proof.
+  destruct sor.(SORsetoid).
+  apply Equivalence_Symmetric.
+Qed.
+
+Lemma req_trans : forall x y z, req x y -> req y z -> req x z.
+Proof.
+  destruct sor.(SORsetoid).
+  apply Equivalence_Transitive.
+Qed.
+
+
+Add Relation R req
+  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
+  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
+  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
+as sor_setoid.
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+exact sor.(SORlt_wd).
+Qed.
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+  exact (rminus_morph sor).
+Qed.
+
+Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
+Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
+
+Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp.
+
+Notation phi_pos := (gen_phiPOS 1 rplus rtimes).
+Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes).
+
+Notation "[ x ]" := (gen_order_phi_Z x).
+
+Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req.
+Proof.
+constructor.
+exact rplus_morph.
+exact rtimes_morph.
+exact ropp_morph.
+Qed.
+
+Lemma Zring_morph :
+  ring_morph 0 1 rplus rtimes rminus ropp req
+             0%Z 1%Z Zplus Zmult Zminus Zopp
+             Zeq_bool gen_order_phi_Z.
+Proof.
+exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)).
+Qed.
+
+Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x.
+Proof.
+induction x as [x IH | x IH |]; simpl;
+try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor);
+try apply (Rlt_0_1 sor); assumption.
+Qed.
+
+Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Psucc x) == 1 + phi_pos1 x.
+Proof.
+exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd
+        (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))).
+Qed.
+
+Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y.
+Proof.
+intros x y H. pattern y; apply Plt_ind with x.
+rewrite phi_pos1_succ; apply (Rlt_succ_r sor).
+clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor).
+assumption.
+Qed.
+
+Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y].
+Proof.
+unfold Zlt; intros x y H;
+do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt));
+destruct x; destruct y; simpl in *; try discriminate.
+apply phi_pos1_pos.
+now apply clt_pos_morph.
+apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
+apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
+apply phi_pos1_pos.
+rewrite Pcompare_antisym in H; simpl in H. apply -> (Ropp_lt_mono sor).
+now apply clt_pos_morph.
+Qed.
+
+Lemma Zcleb_morph : forall x y : Z, Zle_bool x y = true -> [x] <= [y].
+Proof.
+unfold Zle_bool; intros x y H.
+case_eq (x ?= y)%Z; intro H1; rewrite H1 in H.
+le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1.
+le_less. now apply clt_morph.
+discriminate.
+Qed.
+
+Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y].
+Proof.
+intros x y H. unfold Zeq_bool in H.
+case_eq (Zcompare x y); intro H1; rewrite H1 in *; (discriminate || clear H).
+apply (Rlt_neq sor). now apply clt_morph.
+fold (x > y)%Z in H1. rewrite Zgt_iff_lt in H1.
+apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph.
+Qed.
+
+End InitialMorphism.
+
+
diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v
new file mode 100644
index 00000000..b02a9850
--- /dev/null
+++ b/plugins/micromega/ZMicromega.v
@@ -0,0 +1,1023 @@
+(************************************************************************)
+(*  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.
+(*Declare ML Module "micromega_plugin".*)
+
+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.
+
+Ltac inv H := inversion H ; try subst ; clear H.
+
+
+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.
+
+Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z :=
+  match e with
+    | PEc c => c
+    | PEX x => env x
+    | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2
+    | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2
+    | PEpow e1 n  => Zpower (Zeval_expr env e1) (Z_of_N n)
+    | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2)
+    | PEopp e   => Zopp (Zeval_expr env e)
+  end.
+
+Definition eval_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 = eval_expr env e.
+Proof.
+  induction e ; simpl ; try congruence.
+  reflexivity.
+  rewrite ZNpower. congruence.
+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 (env : PolEnv Z) (f : Formula Z):=
+  let (lhs, op, rhs) := f in
+    (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env 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.
+  destruct f ; simpl.
+  rewrite Zeval_expr_compat. rewrite Zeval_expr_compat.
+  unfold eval_expr.
+  generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+        (fun x : N => x) (pow_N 1 Zmult) env Flhs).
+  generalize ((eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+        (fun x : N => x) (pow_N 1 Zmult) env Frhs)).
+  destruct Fop ; simpl; intros ; intuition (auto with zarith).
+Qed.
+
+
+Definition eval_nformula :=
+  eval_nformula 0 Zplus Zmult  (@eq Z) Zle Zlt (fun x => x) .
+
+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_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d).
+Proof.
+  intros.
+  apply (eval_nformula_dec Zsor).
+Qed.
+
+Definition ZWitness := Psatz Z.
+
+Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zeq_bool Zle_bool.
+
+Lemma ZWeakChecker_sound :   forall (l : list (NFormula Z)) (cm : ZWitness),
+  ZWeakChecker l cm = true ->
+  forall env, make_impl (eval_nformula env) l False.
+Proof.
+  intros l cm H.
+  intro.
+  unfold eval_nformula.
+  apply (checker_nf_sound Zsor ZSORaddon l cm).
+  unfold ZWeakChecker in H.
+  exact H.
+Qed.
+
+Definition psub  := psub Z0  Zplus Zminus Zopp Zeq_bool.
+
+Definition padd  := padd Z0  Zplus Zeq_bool.
+
+Definition norm  := norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool.
+
+Definition eval_pol := eval_pol 0  Zplus Zmult (fun x => x).
+
+Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub  lhs rhs) = eval_pol env lhs - eval_pol env rhs.
+Proof.
+  intros.
+  apply (eval_pol_sub Zsor ZSORaddon).
+Qed.
+
+Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd  lhs rhs) = eval_pol env lhs + eval_pol env rhs.
+Proof.
+  intros.
+  apply (eval_pol_add Zsor ZSORaddon).
+Qed.
+
+Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (norm e) .
+Proof.
+  intros.
+  apply (eval_pol_norm Zsor ZSORaddon).
+Qed.
+
+Definition xnormalise (t:Formula Z) : list (NFormula Z)  :=
+  let (lhs,o,rhs) := t in
+    let lhs := norm lhs in
+      let rhs := norm rhs in
+    match o with
+      | OpEq =>
+        ((psub lhs (padd  rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil
+      | OpNEq => (psub lhs rhs,Equal) :: nil
+      | OpGt   => (psub rhs lhs,NonStrict) :: nil
+      | OpLt => (psub lhs rhs,NonStrict) :: nil
+      | OpGe => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil
+      | OpLe => (psub lhs (padd rhs (Pc 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 (eval_nformula env) (normalise t) <-> Zeval_formula env t.
+Proof.
+  Opaque padd.
+  unfold normalise, xnormalise  ; simpl; intros env t.
+  rewrite Zeval_formula_compat.
+  unfold eval_cnf.
+  destruct t as [lhs o rhs]; case_eq o; simpl;
+    repeat rewrite eval_pol_sub;
+      repeat rewrite eval_pol_add;
+      repeat rewrite <- eval_pol_norm ; simpl in *;
+  unfold eval_expr;
+  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).
+  Transparent padd.
+Qed.
+
+Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z)  :=
+  let (lhs,o,rhs) := t in
+    let lhs := norm lhs in
+      let rhs := norm rhs in
+    match o with
+      | OpEq  => (psub lhs rhs,Equal) :: nil
+      | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil
+      | OpGt  => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil
+      | OpLt  => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil
+      | OpGe  => (psub lhs rhs,NonStrict) :: nil
+      | OpLe  => (psub 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 (eval_nformula env) (negate t) <-> ~ Zeval_formula env t.
+Proof.
+Proof.
+  Opaque padd.
+  intros env t.
+  rewrite Zeval_formula_compat.
+  unfold negate, xnegate  ; simpl.
+  unfold eval_cnf.
+  destruct t as [lhs o rhs]; case_eq o; simpl;
+    repeat rewrite eval_pol_sub;
+      repeat rewrite eval_pol_add;
+      repeat rewrite <- eval_pol_norm ; simpl in *;
+  unfold eval_expr;
+  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).
+  Transparent padd.
+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.
+
+(** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *)
+
+Require Import QArith.
+
+Inductive ZArithProof : Type :=
+| DoneProof
+| RatProof : ZWitness -> ZArithProof -> ZArithProof
+| CutProof : ZWitness -> ZArithProof -> ZArithProof
+| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof.
+
+(* 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.
+*)
+
+(* In order to compute the 'cut', we need to express a polynomial P as a * Q + b.
+   - b is the constant
+   - a is the gcd of the other coefficient.
+*)
+Require Import Znumtheory.
+
+Definition isZ0 (x:Z) :=
+  match x with
+    | Z0 => true
+    | _  => false
+  end.
+
+Lemma isZ0_0 : forall x, isZ0 x = true <-> x = 0.
+Proof.
+  destruct x ; simpl ; intuition congruence.
+Qed.
+
+Lemma isZ0_n0 : forall x, isZ0 x = false <-> x <> 0.
+Proof.
+  destruct x ; simpl ; intuition congruence.
+Qed.
+
+Definition ZgcdM (x y : Z) := Zmax (Zgcd x y) 1.
+
+
+Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) :=
+  match p with
+    | Pc c => (0,c)
+    | Pinj _ p => Zgcd_pol p
+    | PX p _ q =>
+      let (g1,c1) := Zgcd_pol p in
+        let (g2,c2) := Zgcd_pol q in
+          (ZgcdM (ZgcdM g1 c1) g2 , c2)
+  end.
+
+(*Eval compute in (Zgcd_pol ((PX (Pc (-2)) 1 (Pc 4)))).*)
+
+
+Fixpoint Zdiv_pol (p:PolC Z) (x:Z) : PolC Z :=
+  match p with
+    | Pc c => Pc (Zdiv c x)
+    | Pinj j p => Pinj j (Zdiv_pol p x)
+    | PX p j q => PX (Zdiv_pol p x) j (Zdiv_pol q x)
+  end.
+
+Inductive Zdivide_pol (x:Z): PolC Z -> Prop :=
+| Zdiv_Pc : forall c, (x | c) -> Zdivide_pol x (Pc c)
+| Zdiv_Pinj : forall p, Zdivide_pol x p ->  forall j, Zdivide_pol x (Pinj j p)
+| Zdiv_PX   : forall p q, Zdivide_pol x p -> Zdivide_pol x q -> forall j, Zdivide_pol x (PX p j q).
+
+
+Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p  ->
+  forall env, eval_pol env p =  a * eval_pol env (Zdiv_pol p a).
+Proof.
+  intros until 2.
+  induction H0.
+  (* Pc *)
+  simpl.
+  intros.
+  apply Zdivide_Zdiv_eq ; auto.
+  (* Pinj *)
+  simpl.
+  intros.
+  apply IHZdivide_pol.
+  (* PX *)
+  simpl.
+  intros.
+  rewrite IHZdivide_pol1.
+  rewrite IHZdivide_pol2.
+  ring.
+Qed.
+
+Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0.
+Proof.
+  induction p.
+  simpl. auto with zarith.
+  simpl. auto.
+  simpl.
+  case_eq (Zgcd_pol p1).
+  case_eq (Zgcd_pol p3).
+  intros.
+  simpl.
+  unfold ZgcdM.
+  generalize (Zgcd_is_pos z1 z2).
+  generalize (Zmax_spec (Zgcd z1 z2) 1).
+  generalize (Zgcd_is_pos (Zmax (Zgcd z1 z2) 1) z).
+  generalize (Zmax_spec (Zgcd (Zmax (Zgcd z1 z2) 1) z) 1).
+  auto with zarith.
+Qed.
+
+Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) ->  Zdivide_pol y p.
+Proof.
+  intros.
+  induction H.
+  constructor.
+  apply Zdivide_trans with (1:= H0) ; assumption.
+  constructor. auto.
+  constructor ; auto.
+Qed.
+
+Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p.
+Proof.
+  induction p ; constructor ; auto.
+  exists c. ring.
+Qed.
+
+Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Zgcd a b | c).
+Proof.
+  intros a b c (q,Hq).
+  destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _].
+  set (g:=Zgcd a b) in *; clearbody g.
+  exists (q * a' + b').
+  symmetry in Hq. rewrite <- Zeq_plus_swap in Hq.
+  rewrite <- Hq, Hb, Ha. ring.
+Qed.
+
+Lemma Zdivide_pol_sub : forall p a b,
+  0 < Zgcd a b ->
+  Zdivide_pol a (PsubC Zminus p b) ->
+   Zdivide_pol (Zgcd a b) p.
+Proof.
+  induction p.
+  simpl.
+  intros. inversion H0.
+  constructor.
+  apply Zgcd_minus ; auto.
+  intros.
+  constructor.
+  simpl in H0. inversion H0 ; subst; clear H0.
+  apply IHp ; auto.
+  simpl. intros.
+  inv H0.
+  constructor.
+  apply Zdivide_pol_Zdivide with (1:= H3).
+  destruct (Zgcd_is_gcd a b) ; assumption.
+  apply IHp2 ; assumption.
+Qed.
+
+Lemma Zdivide_pol_sub_0 : forall p a,
+  Zdivide_pol a (PsubC Zminus p 0) ->
+   Zdivide_pol a p.
+Proof.
+  induction p.
+  simpl.
+  intros. inversion H.
+  constructor.  replace (c - 0) with c in H1 ; auto with zarith.
+  intros.
+  constructor.
+  simpl in H. inversion H ; subst; clear H.
+  apply IHp ; auto.
+  simpl. intros.
+  inv H.
+  constructor. auto.
+  apply IHp2 ; assumption.
+Qed.
+
+
+Lemma Zgcd_pol_div : forall p g c,
+  Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Zminus p c).
+Proof.
+  induction p ; simpl.
+  (* Pc *)
+  intros. inv H.
+  constructor.
+  exists 0. now ring.
+  (* Pinj *)
+  intros.
+  constructor.  apply IHp ; auto.
+  (* PX *)
+  intros g c.
+  case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros.
+  inv H1.
+  unfold ZgcdM at 1.
+  destruct (Zmax_spec (Zgcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1];
+  destruct HH1 as [HH1 HH1'] ; rewrite HH1'.
+  constructor.
+  apply Zdivide_pol_Zdivide with (x:= ZgcdM z1 z2).
+  unfold ZgcdM.
+  destruct (Zmax_spec  (Zgcd z1 z2)  1) as [HH2 | HH2].
+  destruct HH2.
+  rewrite H2.
+  apply Zdivide_pol_sub ; auto.
+  auto with zarith.
+  destruct HH2. rewrite H2.
+  apply Zdivide_pol_one.
+  unfold ZgcdM in HH1. unfold ZgcdM.
+  destruct (Zmax_spec  (Zgcd z1 z2)  1) as [HH2 | HH2].
+  destruct HH2. rewrite H2 in *.
+  destruct (Zgcd_is_gcd (Zgcd z1 z2) z); auto.
+  destruct HH2. rewrite H2.
+  destruct (Zgcd_is_gcd 1  z); auto.
+  apply Zdivide_pol_Zdivide with (x:= z).
+  apply (IHp2 _ _ H); auto.
+  destruct (Zgcd_is_gcd (ZgcdM z1 z2) z); auto.
+  constructor. apply Zdivide_pol_one.
+  apply Zdivide_pol_one.
+Qed.
+
+
+
+
+Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Zminus p c) g))  + c.
+Proof.
+  intros.
+  rewrite <- Zdiv_pol_correct ; auto.
+  rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
+  unfold eval_pol. ring.
+  (**)
+  apply Zgcd_pol_div ; auto.
+Qed.
+
+
+
+Definition makeCuttingPlane (p : PolC Z) : PolC  Z * Z :=
+  let (g,c) := Zgcd_pol p in
+    if Zgt_bool g Z0
+      then (Zdiv_pol (PsubC Zminus p c) g , Zopp (ceiling (Zopp c) g))
+      else (p,Z0).
+
+
+Definition genCuttingPlane (f : NFormula Z) : option (PolC Z * Z * Op1) :=
+  let (e,op) := f in
+    match op with
+      | Equal => let (g,c) := Zgcd_pol e in
+        if andb (Zgt_bool g Z0) (andb (Zgt_bool c Z0) (negb (Zeq_bool (Zgcd g c) g)))
+          then None (* inconsistent *)
+          else Some (e, Z0,op) (* It could still be inconsistent -- but not a cut *)
+      | NonEqual => Some (e,Z0,op)
+      | Strict   =>  let (p,c) := makeCuttingPlane (PsubC Zminus e 1) in
+        Some (p,c,NonStrict)
+      | NonStrict => let (p,c) := makeCuttingPlane e  in
+        Some (p,c,NonStrict)
+    end.
+
+Definition nformula_of_cutting_plane (t : PolC Z * Z * Op1) : NFormula Z :=
+  let (e_z, o) := t in
+    let (e,z) := e_z in
+      (padd e (Pc z) , o).
+
+Definition is_pol_Z0 (p : PolC Z) : bool :=
+  match p with
+    | Pc Z0 => true
+    |   _   => false
+  end.
+
+Lemma is_pol_Z0_eval_pol : forall p, is_pol_Z0 p = true -> forall env, eval_pol env p = 0.
+Proof.
+  unfold is_pol_Z0.
+  destruct p ; try discriminate.
+  destruct z ; try discriminate.
+  reflexivity.
+Qed.
+
+
+
+
+
+Definition eval_Psatz  : list (NFormula Z) -> ZWitness ->  option (NFormula Z) :=
+  eval_Psatz 0 1 Zplus Zmult Zeq_bool Zle_bool.
+
+
+Definition check_inconsistent := check_inconsistent 0 Zeq_bool Zle_bool.
+
+
+
+Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof)  {struct pf} : bool :=
+  match pf with
+    | DoneProof => false
+    | RatProof w pf =>
+      match eval_Psatz l w  with
+        | None => false
+        | Some f =>
+          if check_inconsistent f then true
+            else ZChecker (f::l) pf
+      end
+    | CutProof w pf =>
+      match eval_Psatz l w with
+        | None => false
+        | Some f =>
+          match genCuttingPlane f with
+            | None => true
+            | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf
+          end
+      end
+    | EnumProof w1 w2 pf =>
+      match eval_Psatz l w1 , eval_Psatz l w2 with
+        |  Some f1 , Some f2 =>
+          match genCuttingPlane f1 , genCuttingPlane f2 with
+            |Some (e1,z1,op1) , Some (e2,z2,op2) =>
+              match op1 , op2 with
+                | NonStrict , NonStrict =>
+                  if is_pol_Z0 (padd e1 e2)
+                    then
+                      (fix label (pfs:list ZArithProof) :=
+                        fun lb ub =>
+                          match pfs with
+                            | nil => if Zgt_bool lb ub then true else false
+                            | pf::rsr => andb (ZChecker  ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub)
+                          end)
+                      pf (Zopp z1)  z2
+                    else false
+                |   _    ,   _   => false
+              end
+            |   _   ,  _ => false
+          end
+        |   _   , _  => false
+      end
+      end.
+
+
+
+Fixpoint bdepth (pf : ZArithProof) : nat :=
+  match pf with
+    | DoneProof  => O
+    | RatProof _ p =>  S (bdepth p)
+    | 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  y, In y l ->  ltof ZArithProof bdepth y (EnumProof a b  l).
+Proof.
+  induction l.
+  (* nil *)
+  simpl.
+  tauto.
+  (* cons *)
+  simpl.
+  intros.
+  destruct H.
+  subst.
+  unfold ltof.
+  simpl.
+  generalize (         (fold_right
+            (fun (pf : ZArithProof) (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).
+  auto with zarith.
+  generalize (IHl a0 b  y  H).
+  unfold ltof.
+  simpl.
+  generalize (      (fold_right (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat
+         l)).
+  intros.
+  generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n).
+  auto with zarith.
+Qed.
+
+
+Lemma eval_Psatz_sound : forall env w l f',
+  make_conj (eval_nformula env) l ->
+  eval_Psatz l w  = Some f' ->  eval_nformula env f'.
+Proof.
+  intros.
+  apply (eval_Psatz_Sound Zsor ZSORaddon) with (l:=l) (e:= w) ; auto.
+  apply make_conj_in ; auto.
+Qed.
+
+Lemma makeCuttingPlane_sound : forall env e e' c,
+  eval_nformula env (e, NonStrict) ->
+  makeCuttingPlane e = (e',c) ->
+  eval_nformula env (nformula_of_cutting_plane (e', c, NonStrict)).
+Proof.
+  unfold nformula_of_cutting_plane.
+  unfold eval_nformula. unfold RingMicromega.eval_nformula.
+  unfold eval_op1.
+  intros.
+  rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon).
+  simpl.
+  (**)
+  unfold makeCuttingPlane in H0.
+  revert H0.
+  case_eq (Zgcd_pol e) ; intros g c0.
+  generalize (Zgt_cases g 0) ; destruct (Zgt_bool g 0).
+  intros.
+  inv H2.
+  change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in *.
+  apply Zgcd_pol_correct_lt with (env:=env) in H1.
+  generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Zminus e c0) g)) H0).
+  auto with zarith.
+  auto with zarith.
+  (* g <= 0 *)
+  intros. inv H2. auto with zarith.
+Qed.
+
+
+Lemma cutting_plane_sound : forall env f p,
+  eval_nformula env f ->
+  genCuttingPlane f = Some p ->
+   eval_nformula env (nformula_of_cutting_plane p).
+Proof.
+  unfold genCuttingPlane.
+  destruct f as [e op].
+  destruct op.
+  (* Equal *)
+  destruct p as [[e' z] op].
+  case_eq (Zgcd_pol e) ; intros g c.
+  destruct (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))) ; [discriminate|].
+  intros. inv H1. unfold nformula_of_cutting_plane.
+  unfold eval_nformula in *.
+  unfold RingMicromega.eval_nformula in *.
+  unfold eval_op1 in *.
+  rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon).
+  simpl. rewrite H0. reflexivity.
+  (* NonEqual *)
+  intros.
+  inv H0.
+  unfold eval_nformula in *.
+  unfold RingMicromega.eval_nformula in *.
+  unfold nformula_of_cutting_plane.
+  unfold eval_op1 in *.
+  rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon).
+  simpl. auto with zarith.
+  (* Strict *)
+  destruct p as [[e' z] op].
+  case_eq (makeCuttingPlane (PsubC Zminus e 1)).
+  intros.
+  inv H1.
+  apply makeCuttingPlane_sound with (env:=env) (2:= H).
+  simpl in *.
+  rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
+  auto with zarith.
+  (* NonStrict *)
+  destruct p as [[e' z] op].
+  case_eq (makeCuttingPlane e).
+  intros.
+  inv H1.
+  apply makeCuttingPlane_sound with (env:=env) (2:= H).
+  assumption.
+Qed.
+
+Lemma  genCuttingPlaneNone : forall env f,
+  genCuttingPlane f = None ->
+  eval_nformula env f -> False.
+Proof.
+  unfold genCuttingPlane.
+  destruct f.
+  destruct o.
+  case_eq (Zgcd_pol p) ; intros g c.
+  case_eq (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))).
+  intros.
+  flatten_bool.
+  rewrite negb_true_iff in H5.
+  apply Zeq_bool_neq in H5.
+  contradict H5.
+  rewrite <- Zgt_is_gt_bool in H3.
+  rewrite <- Zgt_is_gt_bool in H.
+  apply Zis_gcd_gcd; auto with zarith.
+  constructor; auto with zarith.
+  change (eval_pol env p = 0) in H2.
+  rewrite Zgcd_pol_correct_lt with (1:= H0) in H2; auto with zarith.
+  set (x:=eval_pol env (Zdiv_pol (PsubC Zminus p c) g)) in *; clearbody x.
+  exists (-x).
+  rewrite <- Zopp_mult_distr_l, Zmult_comm; auto with zarith.
+  (**)
+  discriminate.
+  discriminate.
+  destruct (makeCuttingPlane (PsubC Zminus p 1)) ; discriminate.
+  destruct (makeCuttingPlane p) ; discriminate.
+Qed.
+
+
+Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl  (eval_nformula env)  l False.
+Proof.
+  induction w    using (well_founded_ind (well_founded_ltof _ bdepth)).
+  destruct w as [ | w pf | w pf | w1 w2 pf].
+  (* DoneProof *)
+  simpl. discriminate.
+  (* RatProof *)
+  simpl.
+  intro l. case_eq (eval_Psatz l w) ; [| discriminate].
+  intros f Hf.
+  case_eq (check_inconsistent f).
+  intros.
+  apply (checker_nf_sound Zsor ZSORaddon l w).
+  unfold check_normalised_formulas.  unfold eval_Psatz in Hf. rewrite Hf.
+  unfold check_inconsistent in H0. assumption.
+  intros.
+  assert (make_impl  (eval_nformula env) (f::l) False).
+   apply H with (2:= H1).
+   unfold ltof.
+   simpl.
+   auto with arith.
+  destruct f.
+  rewrite <- make_conj_impl in H2.
+  rewrite make_conj_cons in H2.
+  rewrite <- make_conj_impl.
+  intro.
+  apply H2.
+  split ; auto.
+  apply eval_Psatz_sound with (2:= Hf) ; assumption.
+  (* CutProof *)
+  simpl.
+  intro l.
+  case_eq (eval_Psatz l w) ; [ | discriminate].
+  intros f' Hlc.
+  case_eq (genCuttingPlane f').
+  intros.
+  assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False).
+   eapply (H pf) ; auto.
+   unfold ltof.
+   simpl.
+   auto with arith.
+  rewrite <- make_conj_impl in H2.
+  rewrite make_conj_cons in H2.
+  rewrite <- make_conj_impl.
+  intro.
+  apply H2.
+  split ; auto.
+  apply eval_Psatz_sound with (env:=env) in Hlc.
+  apply cutting_plane_sound with (1:= Hlc) (2:= H0).
+  auto.
+  (* genCuttingPlane = None *)
+  intros.
+  rewrite <- make_conj_impl.
+  intros.
+  apply eval_Psatz_sound with (2:= Hlc) in H2.
+  apply genCuttingPlaneNone with (2:= H2) ; auto.
+  (* EnumProof *)
+  intro.
+  simpl.
+  case_eq (eval_Psatz l w1) ; [  | discriminate].
+  case_eq (eval_Psatz l w2) ; [  | discriminate].
+  intros f1 Hf1 f2 Hf2.
+  case_eq (genCuttingPlane f2) ;  [  | discriminate].
+  destruct p as [ [p1 z1] op1].
+  case_eq (genCuttingPlane f1) ;  [  | discriminate].
+  destruct p as [ [p2 z2] op2].
+  case_eq op1 ; case_eq op2 ; try discriminate.
+  case_eq (is_pol_Z0 (padd p1 p2)) ; try discriminate.
+  intros.
+  (* get the bounds of the enum *)
+  rewrite <- make_conj_impl.
+  intro.
+  assert (-z1 <= eval_pol env p1 <= z2).
+   split.
+   apply  eval_Psatz_sound with (env:=env) in Hf2 ; auto.
+   apply cutting_plane_sound with (1:= Hf2) in H4.
+   unfold nformula_of_cutting_plane in H4.
+   unfold eval_nformula in H4.
+   unfold RingMicromega.eval_nformula in H4.
+   change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H4.
+   unfold eval_op1 in H4.
+   rewrite eval_pol_add in H4. simpl in H4.
+   auto with zarith.
+   (**)
+   apply is_pol_Z0_eval_pol with (env := env) in H0.
+   rewrite eval_pol_add in H0.
+   replace (eval_pol env p1) with (- eval_pol env p2) by omega.
+   apply  eval_Psatz_sound with (env:=env) in Hf1 ; auto.
+   apply cutting_plane_sound with (1:= Hf1) in H3.
+   unfold nformula_of_cutting_plane in H3.
+   unfold eval_nformula in H3.
+   unfold RingMicromega.eval_nformula in H3.
+   change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H3.
+   unfold eval_op1 in H3.
+   rewrite eval_pol_add in H3. simpl in H3.
+   omega.
+  revert H5.
+  set (FF := (fix label (pfs : list ZArithProof) (lb ub : Z) {struct pfs} : bool :=
+    match pfs with
+      | nil => if Z_gt_dec lb ub then true else false
+      | pf :: rsr =>
+        (ZChecker ((PsubC Zminus p1  lb, Equal) :: l) pf &&
+          label rsr (lb + 1)%Z ub)%bool
+    end)).
+  intros.
+  assert (HH :forall x, -z1 <= x <= z2 -> exists pr,
+    (In pr pf /\
+      ZChecker  ((PsubC Zminus p1 x,Equal) :: l) pr = true)%Z).
+  clear H.
+  clear H0 H1 H2 H3 H4 H7.
+  revert H5.
+  generalize (-z1). clear z1. intro z1.
+  revert z1 z2.
+  induction pf;simpl ;intros.
+  generalize (Zgt_cases z1 z2).
+  destruct (Zgt_bool z1 z2).
+  intros.
+  apply False_ind ; omega.
+  discriminate.
+  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 (IHpf _ _ H1 _ H3).
+  destruct H4.
+  exists x0 ; split;auto.
+  (*/asser *)
+  destruct (HH _ H7) as [pr [Hin Hcheker]].
+  assert (make_impl (eval_nformula env) ((PsubC Zminus p1 (eval_pol env p1),Equal) :: l) False).
+   apply (H pr);auto.
+   apply in_bdepth ; auto.
+  rewrite <- make_conj_impl in H8.
+  apply H8.
+  rewrite  make_conj_cons.
+  split ;auto.
+  unfold  eval_nformula.
+  unfold RingMicromega.eval_nformula.
+  simpl.
+  rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
+  unfold eval_pol. ring.
+Qed.
+
+Definition ZTautoChecker  (f : BFormula (Formula Z)) (w: list ZArithProof): bool :=
+  @tauto_checker (Formula Z) (NFormula Z) normalise negate  ZArithProof 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 eval_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.
+
+Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof)  : list nat :=
+  match pt with
+    | DoneProof => acc
+    | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt
+    | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt
+    | EnumProof c1 c2 l =>
+      let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in
+        List.fold_left (xhyps_of_pt (S base)) l acc
+  end.
+
+Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt.
+
+
+(*Lemma hyps_of_pt_correct : forall pt l, *)
+
+
+
+
+
+
+Open Scope Z_scope.
+
+
+(** 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 := eval_formula.
+
+Definition prod_pos_nat := prod positive nat.
+
+Definition n_of_Z (z:Z) : BinNat.N :=
+  match z with
+    | Z0 => N0
+    | Zpos p => Npos p
+    | Zneg p => N0
+  end.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
+
+
diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml
new file mode 100644
index 00000000..c5760229
--- /dev/null
+++ b/plugins/micromega/certificate.ml
@@ -0,0 +1,813 @@
+(************************************************************************)
+(*  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
+open Sos_lib
+
+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
+ val is_null : t -> bool
+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 is_null p = fold (fun mn vl b -> b & sign_num vl = 0) p  true
+
+ 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 -> 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.PsatzMulE(t1, t2) ->
+    simpl_cone  (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2))
+ | Mc.PsatzAdd(t1,t2)  ->
+    simpl_cone (Mc.PsatzAdd (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.PsatzAdd (x,r) -> cone_list  r (x::l)
+   |  _        ->  c :: l in
+
+ let factorise c1 c2 =
+  match c1 , c2 with
+   | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') ->
+      if x = x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
+   | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') ->
+      if x = x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
+   |  _     -> None in
+
+ let rec rebuild_cone l pending  =
+  match l with
+   | [] -> (match pending with
+      | None -> Mc.PsatzZ
+      | Some p -> p
+     )
+   | e::l ->
+      (match pending with
+       | None -> rebuild_cone l (Some e)
+       | Some p -> (match factorise p e with
+          | None -> Mc.PsatzAdd(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
+   | [] -> failwith "empty_certificate"
+   | e::cert' ->
+      let cst = match compare_big_int e zero_big_int with
+       | 0 -> Mc.PsatzZ
+       | 1 ->  Mc.PsatzC (bint_to_cst e)
+       | _ -> failwith "positivity error"
+      in
+      let rec scalar_product cert l =
+       match cert with
+        | [] -> Mc.PsatzZ
+        | 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.PsatzAdd (
+                   Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
+                   r)
+                | 0  -> r
+                | _ ->  Mc.PsatzAdd (
+                   Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
+                   r) in
+
+        ((factorise_linear_cone
+             (simplify_cone n_spec (Mc.PsatzAdd (cst, scalar_product cert' li)))))
+
+
+exception Found of Monomial.t
+
+exception Strict
+
+let primal l =
+  let vr = ref 0 in
+  let module Mmn = Map.Make(Monomial) in
+
+  let vect_of_poly map p =
+    Poly.fold (fun mn vl (map,vect) ->
+      if mn = Monomial.const
+      then (map,vect)
+      else
+	let (mn,m) = try (Mmn.find mn map,map) with Not_found -> let res = (!vr, Mmn.add mn !vr map) in incr vr ; res in
+	  (m,if sign_num vl = 0 then vect else (mn,vl)::vect)) p (map,[]) in
+
+  let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in
+
+  let cmp x y = Pervasives.compare (fst x) (fst y) in
+
+   snd (List.fold_right (fun  (p,op) (map,l) ->
+      let (mp,vect) = vect_of_poly map p in
+      let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in
+
+	(mp,cstr::l)) l (Mmn.empty,[]))
+
+let dual_raw_certificate (l:  (Poly.t * Mc.op1) list) =
+(*  List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *)
+
+
+ let sys = build_linear_system l in
+
+   try
+   match Fourier.find_point sys with
+    | Inr _ -> None
+    | Inl 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 raw_certificate l =
+  try
+    let p = primal l in
+      match Fourier.find_point p with
+	| Inr prf ->
+	    if debug then Printf.printf "AProof : %a\n" pp_proof prf ;
+	    let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in
+	      if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ;
+	      Some (rats_to_ints (Vect.to_list cert))
+	| Inl _   -> None
+  with Strict ->
+    (* Fourier elimination should handle > *)
+    dual_raw_certificate l
+
+
+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*)Some (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 ((x,y),i) -> 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)
+
+let linear_prover_with_cert spec l =
+  match linear_prover spec l with
+    | None -> None
+    | Some cert -> Some (make_certificate spec cert)
+
+
+
+(* 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)
+
+
+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 (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 (make_certificate z_spec prf,Mc.DoneProof))
+  | None     -> (* find the candidate with the smallest range *)
+     (* Grrr - linear_prover is also calling 'make_linear_system' *)
+     let ll = List.fold_right (fun (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 Itv.smaller_itv i1 i2
+       then (x1,i1) else (x2,i2)) (Vect.null,(None,None)) candidates
+      with
+       | (x,(Some i, Some j))  -> Some(i,x,j)
+       |   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
+              ((pplus (pmult (pconst ubd) expr) (popp (pconst  ubn)),
+                      Mc.NonStrict) :: sys),
+            (* lb <= x  -> lb > x *)
+            linear_prover z_spec
+             ((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 ->
+		      let bound_proof (c,l) = make_certificate z_spec (List.tl c , List.tl (List.map (fun x -> x -1) l)) in
+
+                     Some (Mc.EnumProof((*Ml2C.q lb,expr,Ml2C.q ub,*) bound_proof clb, bound_proof cub,prf)))
+             | _ -> None
+           )
+       |  _ -> None
+and zlinear_enum  planes expr clb cub l =
+ if clb >/  cub
+ then Some []
+ else
+  let pexpr = pplus (popp (pconst (Ml2C.bigint (numerator clb)))) expr in
+  let sys' = (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 (prf :: prfl)
+
+let zlinear_prover sys =
+ let candidates = candidates sys in
+ (*  Printf.printf "candidates %d" (List.length candidates) ; *)
+ (*let t0 = Sys.time () in*)
+ let res = xzlinear_prover candidates sys in
+   (*Printf.printf "Time prover : %f" (Sys.time () -. t0) ;*) res
+
+open Sos_types
+open Mutils
+
+let rec scale_term t =
+ match t with
+  | Zero    -> unit_big_int , Zero
+  | Const n ->  (denominator n) , Const (Big_int (numerator n))
+  | Var n   -> unit_big_int , Var n
+  | Inv _   -> failwith "scale_term : not implemented"
+  | Opp t   -> let s, t = scale_term t in s, Opp t
+  | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in
+    let g = gcd_big_int s1 s2 in
+    let s1' = div_big_int s1 g in
+    let s2' = div_big_int s2 g in
+    let e = mult_big_int g (mult_big_int s1' s2') in
+     if (compare_big_int e unit_big_int) = 0
+     then (unit_big_int, Add (y1,y2))
+     else 	e, Add (Mul(Const (Big_int s2'), y1),
+		       Mul (Const (Big_int s1'), y2))
+  | Sub _ -> failwith "scale term: not implemented"
+  | Mul(y,z) ->       let s1,y1 = scale_term y and s2,y2 = scale_term z in
+		       mult_big_int s1 s2 , Mul (y1, y2)
+  |  Pow(t,n) -> let s,t = scale_term t in
+		  power_big_int_positive_int s  n , Pow(t,n)
+  |   _ -> failwith "scale_term : not implemented"
+
+let scale_term t =
+ let (s,t') = scale_term t in
+  s,t'
+
+
+let 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 term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus  Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e)
+
+
+ let rec product l =
+   match l with
+     | [] -> Mc.PsatzZ
+     | [i] -> Mc.PsatzIn (Ml2C.nat i)
+     | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l)
+
+
+let  q_cert_of_pos  pos =
+ let rec _cert_of_pos = function
+   Axiom_eq i ->  Mc.PsatzIn (Ml2C.nat i)
+  | Axiom_le i ->  Mc.PsatzIn (Ml2C.nat i)
+  | Axiom_lt i ->  Mc.PsatzIn (Ml2C.nat i)
+  | Monoid l  -> product l
+  | Rational_eq n | Rational_le n | Rational_lt n ->
+     if compare_num n (Int 0) = 0 then Mc.PsatzZ else
+      Mc.PsatzC (Ml2C.q   n)
+  | Square t -> Mc.PsatzSquare (term_to_q_pol  t)
+  | Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y)
+  | Sum (y, z) -> Mc.PsatzAdd  (_cert_of_pos y, _cert_of_pos z)
+  | Product (y, z) -> Mc.PsatzMulE (_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 term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.zplus  Mc.zmult Mc.zminus Mc.zopp Mc.zeq_bool (term_to_z_expr e)
+
+let  z_cert_of_pos  pos =
+ let s,pos = (scale_certificate pos) in
+ let rec _cert_of_pos = function
+   Axiom_eq i ->  Mc.PsatzIn (Ml2C.nat i)
+  | Axiom_le i ->  Mc.PsatzIn (Ml2C.nat i)
+  | Axiom_lt i ->  Mc.PsatzIn (Ml2C.nat i)
+  | Monoid l  -> product l
+  | Rational_eq n | Rational_le n | Rational_lt n ->
+     if compare_num n (Int 0) = 0 then Mc.PsatzZ else
+      Mc.PsatzC (Ml2C.bigint (big_int_of_num  n))
+  | Square t -> Mc.PsatzSquare (term_to_z_pol  t)
+  | Eqmul (t, y) -> Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y)
+  | Sum (y, z) -> Mc.PsatzAdd  (_cert_of_pos y, _cert_of_pos z)
+  | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in
+  simplify_cone z_spec (_cert_of_pos pos)
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
new file mode 100644
index 00000000..abe4b368
--- /dev/null
+++ b/plugins/micromega/coq_micromega.ml
@@ -0,0 +1,1710 @@
+(************************************************************************)
+(*  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           *)
+(*                                                                      *)
+(* ** Toplevel definition of tactics **                                 *)
+(*                                                                      *)
+(* - Modules ISet, M, Mc, Env, Cache, CacheZ                            *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2009                             *)
+(*                                                                      *)
+(************************************************************************)
+
+open Mutils
+
+(**
+  * Debug flag 
+  *)
+
+let debug = false
+
+(**
+  * Time function
+  *)
+
+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
+
+(**
+  * Initialize a tag type to the Tag module declaration (see Mutils).
+  *)
+
+type tag = Tag.t
+
+(**
+  * An atom is of the form:
+  *   pExpr1 {<,>,=,<>,<=,>=} pExpr2
+  * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are
+  * parametrized by 'cst, which is used as the type of constants.
+  *)
+
+type 'cst atom = 'cst Micromega.formula
+
+(**
+  * Micromega's encoding of formulas.
+  * By order of appearance: boolean constants, variables, atoms, conjunctions,
+  * disjunctions, negation, implication.
+  *)
+
+type 'cst formula =
+  | TT
+  | FF
+  | X of Term.constr
+  | A of 'cst atom * tag * Term.constr
+  | C of 'cst formula * 'cst formula
+  | D of 'cst formula * 'cst formula
+  | N of 'cst formula
+  | I of 'cst formula * Names.identifier option * 'cst formula
+
+(**
+  * Formula pretty-printer.
+  *)
+
+let rec pp_formula o f =
+  match f with
+    | TT -> output_string  o "tt"
+    | FF -> output_string  o "ff"
+    | X c -> output_string o "X "
+    | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t
+    | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2
+    | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2
+    | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)"
+	pp_formula f1
+	  (match n with
+	    | Some id -> Names.string_of_id id
+	    | None -> "") pp_formula f2
+    | N(f) -> Printf.fprintf o "N(%a)" pp_formula f
+
+(**
+  * Collect the identifiers of a (string of) implications. Implication labels
+  * are inherited from Coq/CoC's higher order dependent type constructor (Pi).
+  *)
+
+let rec ids_of_formula f =
+  match f with
+    | I(f1,Some id,f2) -> id::(ids_of_formula f2)
+    | _                -> []
+
+(**
+  * A clause is a list of (tagged) nFormulas.
+  * nFormulas are normalized formulas, i.e., of the form:
+  *   cPol {=,<>,>,>=} 0
+  * with cPol compact polynomials (see the Pol inductive type in EnvRing.v).
+  *)
+
+type 'cst clause = ('cst Micromega.nFormula * tag) list
+
+(**
+  * A CNF is a list of clauses.
+  *)
+
+type 'cst cnf = ('cst clause) list
+
+(**
+  * True and False are empty cnfs and clauses.
+  *)
+
+let tt : 'cst cnf = []
+
+let ff : 'cst cnf = [ [] ]
+
+(**
+  * A refinement of cnf with tags left out. This is an intermediary form
+  * between the cnf tagged list representation ('cst cnf) used to solve psatz,
+  * and the freeform formulas ('cst formula) that is retrieved from Coq.
+  *)
+
+type 'cst mc_cnf = ('cst Micromega.nFormula) list list
+
+(**
+  * From a freeform formula, build a cnf.
+  * The parametric functions negate and normalize are theory-dependent, and
+  * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v
+  * and RingMicromega.v).
+  *)
+
+let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (f:'cst formula) =
+ let negate a t =
+  List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in
+
+ let normalise a t =
+  List.map (fun cl -> List.map (fun x -> (x,t)) 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 (polarity : bool) f =
+  match f with
+   | TT -> if polarity then tt else ff
+   | FF  -> if polarity then ff else tt
+   | X p -> if polarity then ff else ff
+   | A(x,t,_) -> if polarity then normalise x t else negate x t
+   | N(e)  -> xcnf (not polarity) e
+   | C(e1,e2) ->
+      (if polarity then and_cnf else or_cnf) (xcnf polarity e1) (xcnf polarity e2)
+   | D(e1,e2)  ->
+      (if polarity then or_cnf else and_cnf) (xcnf polarity e1) (xcnf polarity e2)
+   | I(e1,_,e2) ->
+      (if polarity then or_cnf else and_cnf) (xcnf (not polarity) e1) (xcnf polarity e2) in
+
+  xcnf true f
+
+(**
+  * MODULE: Ordered set of integers.
+  *)
+
+module ISet = Set.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end)
+
+(**
+  * Given a set of integers s={i0,...,iN} and a list m, return the list of
+  * elements of m that are at position i0,...,iN.
+  *)
+
+let selecti s m =
+  let rec xselecti i m =
+    match m with
+      | [] -> []
+      | e::m -> if ISet.mem i s then e::(xselecti (i+1) m) else xselecti (i+1) m in
+    xselecti 0 m
+
+(**
+  * MODULE: Mapping of the Coq data-strustures into Caml and Caml extracted
+  * code. This includes initializing Caml variables based on Coq terms, parsing
+  * various Coq expressions into Caml, and dumping Caml expressions into Coq.
+  *
+  * Opened here and in csdpcert.ml.
+  *)
+
+module M =
+struct
+
+  open Coqlib
+  open Term
+
+  (**
+    * Location of the Coq libraries.
+    *)
+
+  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"]]
+
+  (**
+    * Initialization : a large amount of Caml symbols are derived from
+    * ZMicromega.v
+    *)
+
+  let init_constant = gen_constant_in_modules "ZMicromega" init_modules
+  let constant = gen_constant_in_modules "ZMicromega" coq_modules
+  (* let constant = gen_constant_in_modules "Omicron" coq_modules *)
+
+  let coq_and = lazy (init_constant "and")
+  let coq_or = lazy (init_constant "or")
+  let coq_not = lazy (init_constant "not")
+  let coq_iff = lazy (init_constant "iff")
+  let coq_True = lazy (init_constant "True")
+  let coq_False = lazy (init_constant "False")
+
+  let coq_cons = lazy (constant "cons")
+  let coq_nil = lazy (constant "nil")
+  let coq_list = lazy (constant "list")
+
+  let coq_O = lazy (init_constant "O")
+  let coq_S = lazy (init_constant "S")
+  let coq_nat = lazy (init_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_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 "ZArithProof")
+  let coq_doneProof = lazy (constant "DoneProof")
+  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 (init_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_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_PX = lazy (constant "PX" )
+  let coq_Pc = lazy (constant"Pc")
+  let coq_Pinj = lazy (constant "Pinj")
+
+  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_PsatzIn = lazy (constant "PsatzIn")
+  let coq_PsatzSquare = lazy (constant "PsatzSquare")
+  let coq_PsatzMulE = lazy (constant "PsatzMulE")
+  let coq_PsatzMultC = lazy (constant "PsatzMulC")
+  let coq_PsatzAdd  = lazy (constant "PsatzAdd")
+  let coq_PsatzC  = lazy (constant "PsatzC")
+  let coq_PsatzZ    = lazy (constant "PsatzZ")
+  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_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")
+
+  (**
+    * Initialization : a few Caml symbols are derived from other libraries;
+    * QMicromega, ZArithRing, RingMicromega.
+    *)
+
+  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_N_of_Z = lazy
+   (gen_constant_in_modules "ZArithRing"
+     [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z")
+
+  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")
+
+  (**
+    * Parsing and dumping : transformation functions between Caml and Coq
+    * data-structures.
+    *
+    * dump_*    functions go from Micromega to Coq terms
+    * parse_*   functions go from Coq to Micromega terms
+    * pp_*      functions pretty-print Coq terms.
+    *)
+
+  (* Error datastructures *)
+
+  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
+
+  (* A simple but useful getter function *)
+
+  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
+
+  (* Access the Micromega module *)
+  
+  module Mc = Micromega
+
+  (* parse/dump/print from numbers up to expressions and formulas *)
+
+  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 (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 -> []
+     | 2 -> parse_elt c.(1) :: parse_list parse_elt c.(2)
+     | i -> raise ParseError
+
+  let rec dump_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_list typ dump_elt l|])
+
+  let pp_list op cl elt o l =
+   let rec _pp  o l =
+    match l with
+     | [] -> ()
+     | [e] -> Printf.fprintf o "%a" elt e
+     | 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 pp_expr pp_z o e =
+  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 in
+    pp_expr o e
+
+  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 dump_pol typ dump_c e =
+    let rec dump_pol e =
+      match e with
+        | Mc.Pc n -> mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|])
+        | Mc.Pinj(p,pol) -> mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|])
+        | Mc.PX(pol1,p,pol2) -> mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in
+      dump_pol e
+
+  let pp_pol pp_c o e =
+    let rec pp_pol o e =
+      match e with
+        | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n
+        | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol
+        | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in
+      pp_pol o e
+
+  let pp_cnf pp_c o f =
+    let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c)  p Tag.pp t) l in
+      List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f
+
+  let dump_psatz typ dump_z e =
+   let z = Lazy.force typ in
+  let rec dump_cone e =
+   match e with
+    | Mc.PsatzIn n -> mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |])
+    | Mc.PsatzMulC(e,c) -> mkApp(Lazy.force coq_PsatzMultC,
+                              [| z; dump_pol z dump_z e ; dump_cone c |])
+    | Mc.PsatzSquare e -> mkApp(Lazy.force coq_PsatzSquare,
+                            [| z;dump_pol z dump_z e|])
+    | Mc.PsatzAdd(e1,e2) -> mkApp(Lazy.force coq_PsatzAdd,
+                              [| z; dump_cone e1; dump_cone e2|])
+    | Mc.PsatzMulE(e1,e2) -> mkApp(Lazy.force coq_PsatzMulE,
+                               [| z; dump_cone e1; dump_cone e2|])
+    | Mc.PsatzC p -> mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|])
+    | Mc.PsatzZ    -> mkApp( Lazy.force coq_PsatzZ,[| z|]) in
+   dump_cone e
+
+  let  pp_psatz pp_z o e =
+   let rec pp_cone o e =
+    match e with
+     | Mc.PsatzIn n ->
+        Printf.fprintf o "(In %a)%%nat" pp_nat n
+     | Mc.PsatzMulC(e,c) ->
+        Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c
+     | Mc.PsatzSquare e ->
+        Printf.fprintf o "(%a^2)" (pp_pol pp_z) e
+     | Mc.PsatzAdd(e1,e2) ->
+        Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2
+     | Mc.PsatzMulE(e1,e2) ->
+        Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2
+     | Mc.PsatzC p ->
+        Printf.fprintf o "(%a)%%positive" pp_z p
+     | Mc.PsatzZ    ->
+        Printf.fprintf o "0" 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 pp_z o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } =
+   Printf.fprintf o"(%a %a %a)" (pp_expr pp_z) l pp_op op (pp_expr pp_z) 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))
+
+  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"
+
+  (**
+    * MODULE: Env is for environment.
+    *)
+
+  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 (* MODULE END: Env *)
+
+  (**
+    * This is the big generic function for expression parsers.
+    *)
+
+  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   ->
+                    begin
+                      try
+                        let (expr,env) = parse_expr env args.(0) in
+                        let power = (parse_exp expr args.(1)) in
+                          (power  , env)
+                      with _ ->   (* if the exponent is a variable *)
+                        let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
+                    end
+                | 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 expr x ->
+      let exp = (parse_z x) in
+        match exp with
+          | Mc.Zneg _ -> Mc.PEc Mc.Z0
+          |   _     ->  Mc.PEpow(expr, Mc.n_of_Z exp))
+    zop_spec
+
+  let parse_qexpr  =  parse_expr
+   qconstant
+    (fun expr x ->
+      let exp = parse_z x in
+        match exp with
+          | Mc.Zneg _ ->
+              begin
+                match expr with
+                | Mc.PEc q -> Mc.PEc (Mc.qpower q exp)
+                |     _    -> print_string "parse_qexpr parse error" ; flush stdout ; raise ParseError
+              end
+          | _     ->  let exp = Mc.n_of_Z  exp in
+                        Mc.PEpow(expr,exp))
+   qop_spec
+
+  let parse_rexpr =  parse_expr
+   rconstant
+   (fun expr x ->
+      let exp = Mc.n_of_nat (parse_nat x) in
+        Mc.PEpow(expr,exp))
+   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)
+  let mkD f1 f2 = D(f1,f2)
+  let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1))
+  let mkI f1 f2 = I(f1,None,f2)
+
+  let mkformula_binary g term f1 f2 =
+    match f1 , f2 with
+    |  X _  , X _ -> X(term)
+    |   _         -> g f1 f2
+
+  (**
+    * This is the big generic function for formula parsers.
+    *)
+  
+  let parse_formula parse_atom env term =
+
+    let parse_atom env tg t = try let (at,env) = parse_atom env t in
+                                    (A(at,tg,t), env,Tag.next tg) with _ -> (X(t),env,tg) in
+
+    let rec xparse_formula env tg term =
+     match kind_of_term term with
+      | App(l,rst) ->
+          (match rst with
+           | [|a;b|] when l = Lazy.force coq_and ->
+               let f,env,tg = xparse_formula env tg a in
+               let g,env, tg = xparse_formula env tg b  in
+               mkformula_binary mkC term f g,env,tg
+           | [|a;b|] when l = Lazy.force coq_or ->
+               let f,env,tg = xparse_formula env tg a in
+               let g,env,tg  = xparse_formula env tg b in
+               mkformula_binary mkD term f g,env,tg
+           | [|a|] when l = Lazy.force coq_not ->
+               let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg)
+           | [|a;b|] when l = Lazy.force coq_iff ->
+               let f,env,tg = xparse_formula env tg a in
+               let g,env,tg = xparse_formula env tg b in
+               mkformula_binary mkIff term f g,env,tg
+           | _ -> parse_atom env tg term)
+      | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) ->
+          let f,env,tg = xparse_formula env tg a in
+          let g,env,tg = xparse_formula env tg b in
+          mkformula_binary mkI term f g,env,tg
+      | _ when term = Lazy.force coq_True -> (TT,env,tg)
+      | _ when term = Lazy.force coq_False -> (FF,env,tg)
+      | _  -> X(term),env,tg in
+    xparse_formula env term
+
+  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
+
+  (**
+    * Given a conclusion and a list of affectations, rebuild a term prefixed by
+    * the appropriate letins.
+    * TODO: reverse the list of bindings!
+    *)
+
+  let set l concl =
+   let rec xset acc = function
+    | [] -> acc
+    | (e::l) ->
+       let (name,expr,typ) = e in
+        xset (Term.mkNamedLetIn
+               (Names.id_of_string name)
+               expr typ acc) l in
+    xset concl l
+
+end (**
+      * MODULE END: M 
+      *)
+
+open M
+
+let rec sig_of_cone = function
+ | Mc.PsatzIn n ->          [CoqToCaml.nat n]
+ | Mc.PsatzMulE(w1,w2) ->   (sig_of_cone w1)@(sig_of_cone w2)
+ | Mc.PsatzMulC(w1,w2) ->   (sig_of_cone w2)
+ | Mc.PsatzAdd(w1,w2) ->    (sig_of_cone w1)@(sig_of_cone w2)
+ | _  -> []
+
+let same_proof sg cl1 cl2 =
+ 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.PsatzIn n -> Names.Idset.union tgs
+     (snd (List.nth clause (CoqToCaml.nat n) ))
+  | Mc.PsatzMulC(e,w) -> xtags tgs w
+  | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(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 = try_any prover polys1
+
+let rec witness prover   l1 l2 =
+ match l2 with
+  | [] -> Some []
+  | e :: l2 ->
+     match find_witness prover (e::l1) with
+      | None -> None
+      | Some w ->
+	 (match witness prover l1 l2 with
+	  | None -> None
+	  | Some l -> Some (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.DoneProof -> Lazy.force coq_doneProof
+  | Micromega.RatProof(cone,rst) ->
+    Term.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|])
+ | Micromega.CutProof(cone,prf) ->
+    Term.mkApp(Lazy.force coq_cutProof,
+	      [| dump_psatz coq_Z dump_z cone ;
+		 dump_proof_term prf|])
+ | Micromega.EnumProof(c1,c2,prfs) ->
+    Term.mkApp (Lazy.force coq_enumProof,
+	       [|  dump_psatz coq_Z dump_z c1 ; dump_psatz 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.DoneProof -> Printf.fprintf o "D"
+  | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz  pp_z) cone pp_proof_term rst
+  | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz  pp_z) cone pp_proof_term rst
+  | Micromega.EnumProof(c1,c2,rst) ->
+      Printf.fprintf o "EP[%a,%a,%a]"
+	(pp_psatz pp_z) c1 (pp_psatz pp_z) c2
+     (pp_list "[" "]" pp_proof_term) rst
+
+let rec parse_hyps parse_arith env tg hyps =
+ match hyps with
+  | [] -> ([],env,tg)
+  | (i,t)::l ->
+     let (lhyps,env,tg) = parse_hyps parse_arith env tg l in
+      try
+       let (c,env,tg) = parse_formula parse_arith env  tg t in
+	((i,c)::lhyps, env,tg)
+      with _ -> 		(lhyps,env,tg)
+       (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
+
+
+(*exception ParseError*)
+
+let parse_goal parse_arith env hyps term =
+ (*  try*)
+ let (f,env,tg) = parse_formula parse_arith env (Tag.from 0) term in
+ let (lhyps,env,tg) = parse_hyps parse_arith env tg hyps in
+  (lhyps,f,env)
+   (*  with Failure x -> raise ParseError*)
+
+(**
+  * The datastructures that aggregate theory-dependent proof values.
+  *)
+
+type ('d, 'prf) domain_spec = {
+ typ : Term.constr; (* Z, Q , R *)
+ coeff : Term.constr ; (* Z, Q *)
+ dump_coeff : 'd -> Term.constr ;
+ proof_typ : Term.constr ;
+ dump_proof : 'prf -> 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_psatz 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_psatz coq_Z dump_z
+}
+
+(**
+  * Instanciate the current Coq goal with a Micromega formula, a varmap, and a
+  * witness.
+  *)
+
+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
+
+(**
+  * The datastructures that aggregate prover attributes.
+  *)
+
+type ('a,'prf) prover = {
+  name : string ; (* name of the prover *)
+  prover : 'a list -> 'prf option ; (* the prover itself *)
+  hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *)
+  compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *)
+  pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *)
+  pp_f   : out_channel -> 'a   -> unit (* pretty printing of the formulas (polynomials)*)
+}
+
+(**
+  * Given a list of provers and a disjunction of atoms, find a proof of any of
+  * the atoms.  Returns an (optional) pair of a proof and a prover
+  * datastructure.
+  *)
+
+let find_witness provers polys1 =
+  let provers = List.map (fun p ->
+    (fun l ->
+      match p.prover l with
+        | None -> None
+        | Some prf -> Some(prf,p)) , p.name) provers in
+  try_any provers (List.map fst polys1)
+
+(**
+  * Given a list of provers and a CNF, find a proof for each of the clauses.
+  * Return the proofs as a list.
+  *)
+
+let witness_list 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_tags  = witness_list
+
+(* *Deprecated* let is_singleton = function [] -> true | [e] -> true | _ -> false *)
+
+let pp_ml_list pp_elt o l =
+  output_string o "[" ;
+  List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ;
+  output_string o "]"
+
+(**
+  * Prune the proof object, according to the 'diff' between two cnf formulas.
+  *)
+
+let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) =
+
+  let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) =
+    let new_cl = Mutils.mapi (fun (f,_) i -> (f,i)) new_cl in
+    let remap i =
+      let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in
+      List.assoc formula new_cl in
+    if debug then
+      begin
+        Printf.printf "\ncompact_proof : %a %a %a"
+          (pp_ml_list prover.pp_f) (List.map fst old_cl)
+          prover.pp_prf prf
+          (pp_ml_list prover.pp_f) (List.map fst new_cl)   ;
+          flush stdout
+      end ;
+    let res = try prover.compact prf remap with x ->
+      if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ;
+      (* This should not happen -- this is the recovery plan... *)
+      match prover.prover (List.map fst new_cl) with
+        | None -> failwith "proof compaction error"
+        | Some p ->  p
+    in
+    if debug then
+      begin
+        Printf.printf " -> %a\n"
+          prover.pp_prf res ;
+        flush stdout
+      end ;
+    res in
+
+  let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) =
+    let hyps_idx = prover.hyps prf in
+    let hyps = selecti hyps_idx old_cl in
+      is_sublist hyps new_cl in
+
+  let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *)
+
+  List.map (fun x ->
+    let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res
+    in compact_proof o p x) cnf_ff'
+
+
+(**
+  * "Hide out" tagged atoms of a formula by transforming them into generic
+  * variables. See the Tag module in mutils.ml for more.
+  *)
+
+let abstract_formula hyps f =
+  let rec xabs f =
+    match f with
+      | X c -> X c
+      | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term)
+      | C(f1,f2) ->
+	  (match xabs f1 , xabs f2 with
+	    |   X a1    ,  X a2   -> X (Term.mkApp(Lazy.force coq_and, [|a1;a2|]))
+	    |    f1     , f2      -> C(f1,f2) )
+      | D(f1,f2) ->
+	  (match xabs f1 , xabs f2 with
+	    |   X a1    ,  X a2   -> X (Term.mkApp(Lazy.force coq_or, [|a1;a2|]))
+	    |    f1     , f2      -> D(f1,f2) )
+      | N(f) ->
+	  (match xabs f with
+	    |   X a    -> X (Term.mkApp(Lazy.force coq_not, [|a|]))
+	    |     f     -> N f)
+      | I(f1,hyp,f2) ->
+	  (match xabs f1 , hyp, xabs f2 with
+	    | X a1      , Some _ , af2    ->  af2
+	    | X a1      , None   , X a2   -> X (Term.mkArrow a1 a2)
+	    |   af1     ,  _     , af2    -> I(af1,hyp,af2)
+	  )
+      | FF -> FF
+      | TT -> TT
+  in  xabs f
+
+(**
+  * This exception is raised by really_call_csdpcert if Coq's configure didn't
+  * find a CSDP executable.
+  *)
+
+exception CsdpNotFound
+
+(**
+  * This is the core of Micromega: apply the prover, analyze the result and
+  * prune unused fomulas, and finally modify the proof state.
+  *)
+
+let micromega_tauto negate normalise spec prover env polys1 polys2 gl =
+ let spec = Lazy.force spec in
+
+ (* Express the goal as one big implication *)
+ let (ff,ids) =
+  List.fold_right
+   (fun (id,f) (cc,ids) ->
+    match f with
+      X _ -> (cc,ids)
+     | _ -> (I(f,Some id,cc), id::ids))
+   polys1 (polys2,[]) in
+
+ (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *)
+ let cnf_ff = cnf negate normalise ff in
+
+ if debug then
+   begin
+     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 ();
+         Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff
+   end;
+
+ match witness_list_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 hyps = List.fold_left (fun s (cl,(prf,p)) ->
+    let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in
+                                     if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ;
+      (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in
+    TagSet.union s tags) TagSet.empty (List.combine cnf_ff res) in
+
+  if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout;
+                 Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ;
+
+  let ff'     = abstract_formula hyps ff in
+  let cnf_ff' = cnf negate normalise ff' in
+
+  if debug then
+    begin
+      Pp.pp (Pp.str "\nAFormula\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 ();
+        Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff'
+    end;
+
+  (* Even if it does not work, this does not mean it is not provable
+  -- the prover is REALLY incomplete *)
+  (* if debug then
+      begin
+        (* recompute the proofs *)
+        match witness_list_tags prover  cnf_ff' with
+          | None -> failwith "abstraction is wrong"
+          | Some res -> ()
+      end ; *)
+  let res' = compact_proofs cnf_ff res cnf_ff' in
+
+  let (ff',res',ids) = (ff',res',List.map Term.mkVar (ids_of_formula ff')) in
+
+  let res' = dump_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
+
+(**
+  * Parse the proof environment, and call micromega_tauto
+  *)
+
+let micromega_gen
+    parse_arith
+    (negate:'cst atom -> 'cst mc_cnf)
+    (normalise:'cst atom -> 'cst mc_cnf)
+    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
+   | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
+      Tacticals.tclFAIL 0 (Pp.str 
+      (" Skipping what remains of this tactic: the complexity of the goal requires "
+      ^ "the use of a specialized external tool called csdp. \n\n" 
+      ^ "Unfortunately this instance of Coq isn't aware of the presence of any \"csdp\" executable. \n\n"
+      ^ "You may need to specify the location during Coq's pre-compilation configuration step")) gl
+
+let lift_ratproof  prover l =
+ match prover l with
+  | None -> None
+  | Some c -> Some (Mc.RatProof( c,Mc.DoneProof))
+
+type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list
+type csdp_certificate = S of Sos_types.positivstellensatz option | F of string
+type provername = string * int option
+
+(**
+  * The caching mechanism.
+  *)
+
+open Persistent_cache
+
+module Cache = PHashtable(struct
+  type t = (provername * micromega_polys)
+  let equal = (=)
+  let hash  = Hashtbl.hash
+end)
+
+let csdp_cache = "csdp.cache"
+
+(**
+  * Build the command to call csdpcert, and launch it. This in turn will call
+  * the sos driver to the csdp executable.
+  * Throw CsdpNotFound if a Coq isn't aware of any csdp executable.
+  *)
+
+let require_csdp =
+  match System.search_exe_in_path "csdp" with
+    | Some _ -> lazy ()
+    | _ -> lazy (raise CsdpNotFound)
+
+let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option  =
+  fun provername poly ->
+
+  Lazy.force require_csdp;
+
+  let cmdname =
+    List.fold_left Filename.concat (Envars.coqlib ())
+      ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in
+
+    match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with
+      | F str -> failwith str
+      | S res -> res
+
+(**
+  * Check the cache before calling the prover.
+  *)
+
+let xcall_csdpcert =
+  Cache.memo csdp_cache (fun (prover,pb) -> really_call_csdpcert prover pb)
+
+(**
+  * Prover callback functions.
+  *)
+
+let call_csdpcert prover pb = xcall_csdpcert (prover,pb)
+
+let rec z_to_q_pol e =
+ match e with
+  | Mc.Pc z   -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH}
+  | Mc.Pinj(p,pol)   -> Mc.Pinj(p,z_to_q_pol pol)
+  | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2)
+
+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
+     if Mc.qWeakChecker poly cert
+     then Some cert
+     else ((print_string "buggy certificate" ; flush stdout) ;None)
+
+let call_csdpcert_z provername poly =
+ let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in
+  match call_csdpcert provername l with
+   | None -> None
+   | Some cert ->
+      let cert = Certificate.z_cert_of_pos cert in
+      if Mc.zWeakChecker poly cert
+      then Some cert
+      else ((print_string "buggy certificate" ; flush stdout) ;None)
+
+let xhyps_of_cone base acc prf =
+  let rec xtract e acc =
+    match e with
+    | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc
+    | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in
+			if n >= base
+			then  ISet.add (n-base) acc
+			else acc
+    | Mc.PsatzMulC(_,c) -> xtract  c acc
+    | Mc.PsatzAdd(e1,e2) |  Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in
+
+    xtract prf acc
+
+let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf
+
+let compact_cone prf f  =
+  let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in
+
+  let rec xinterp prf =
+    match prf with
+    | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf
+    | Mc.PsatzIn n -> Mc.PsatzIn (np n)
+    | Mc.PsatzMulC(e,c) -> Mc.PsatzMulC(e,xinterp c)
+    | Mc.PsatzAdd(e1,e2) -> Mc.PsatzAdd(xinterp e1,xinterp e2)
+    | Mc.PsatzMulE(e1,e2) -> Mc.PsatzMulE(xinterp e1,xinterp e2) in
+
+    xinterp prf
+
+let hyps_of_pt pt =
+
+  let rec xhyps base pt acc =
+    match pt with
+      | Mc.DoneProof -> acc
+      | Mc.RatProof(c,pt) ->  xhyps (base+1) pt (xhyps_of_cone base acc c)
+      | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c)
+      | Mc.EnumProof(c1,c2,l) ->
+	  let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in
+	    List.fold_left (fun s x -> xhyps (base + 1) x s) s l in
+
+    xhyps 0 pt ISet.empty
+
+let hyps_of_pt pt =
+  let res = hyps_of_pt pt in
+    if debug
+    then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res);
+    res
+
+let compact_pt pt f =
+  let translate ofset x =
+    if x < ofset then x
+    else (f (x-ofset) + ofset) in
+
+  let rec compact_pt ofset pt =
+    match pt with
+      | Mc.DoneProof -> Mc.DoneProof
+      | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt )
+      | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt )
+      | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)),
+						   Mc.map (fun x -> compact_pt (ofset+1) x) l) in
+    compact_pt 0 pt
+
+(** 
+  * Definition of provers.
+  * Instantiates the type ('a,'prf) prover defined above.
+  *)
+
+let lift_pexpr_prover p l =  p (List.map (fun (e,o) -> Mc.denorm e , o) l)
+
+let linear_prover_Z = {
+  name    = "linear prover" ;
+  prover  = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ;
+  hyps    = hyps_of_pt ;
+  compact = compact_pt ;
+  pp_prf  = pp_proof_term;
+  pp_f    = fun o x -> pp_pol pp_z o (fst x)
+}
+
+let linear_prover_Q = {
+  name    = "linear prover";
+  prover  = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ;
+  hyps    = hyps_of_cone ;
+  compact = compact_cone ;
+  pp_prf  = pp_psatz pp_q ;
+  pp_f   = fun o x -> pp_pol pp_q o  (fst x)
+}
+
+let linear_prover_R = {
+  name    = "linear prover";
+  prover  = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec) ;
+  hyps    = hyps_of_cone ;
+  compact = compact_cone ;
+  pp_prf  = pp_psatz pp_z ;
+  pp_f    =  fun o x -> pp_pol pp_z o (fst x)
+}
+
+let non_linear_prover_Q str o = {
+  name    = "real nonlinear prover";
+  prover  = call_csdpcert_q (str, o);
+  hyps    = hyps_of_cone;
+  compact = compact_cone ;
+  pp_prf  = pp_psatz pp_q ;
+  pp_f    = fun o x -> pp_pol pp_q o  (fst x)
+}
+
+let non_linear_prover_R str o = {
+  name    = "real nonlinear prover";
+  prover  = call_csdpcert_z (str, o);
+  hyps    = hyps_of_cone;
+  compact = compact_cone;
+  pp_prf  = pp_psatz pp_z;
+  pp_f    = fun o x -> pp_pol pp_z o  (fst x)
+}
+
+let non_linear_prover_Z str o  = {
+  name    = "real nonlinear prover";
+  prover  = lift_ratproof (call_csdpcert_z (str, o));
+  hyps    = hyps_of_pt;
+  compact = compact_pt;
+  pp_prf  = pp_proof_term;
+  pp_f    =  fun o x -> pp_pol pp_z o (fst x)
+}
+
+module CacheZ = PHashtable(struct
+  type t = (Mc.z Mc.pol * Mc.op1) list
+  let equal = (=)
+  let hash  = Hashtbl.hash
+end)
+
+let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover)
+
+let linear_Z =   {
+  name    = "lia";
+  prover  = memo_zlinear_prover ;
+  hyps    = hyps_of_pt;
+  compact = compact_pt;
+  pp_prf  = pp_proof_term;
+  pp_f    = fun o x -> pp_pol pp_z o (fst x)
+}
+
+(** 
+  * Functions instantiating micromega_gen with the appropriate theories and
+  * solvers
+  *)
+
+let psatzl_Z gl =
+ micromega_gen parse_zarith  Mc.negate Mc.normalise zz_domain_spec
+  [ linear_prover_Z ] gl
+
+let psatzl_Q gl =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec
+  [ linear_prover_Q ] gl
+
+let psatz_Q i gl =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec
+  [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl
+
+let psatzl_R gl =
+ micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec
+  [ linear_prover_R ] gl
+
+let psatz_R i gl =
+ micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec
+  [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] gl
+
+let psatz_Z i gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
+  [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl
+
+let sos_Z gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise  zz_domain_spec
+  [ non_linear_prover_Z "pure_sos" None ] gl
+
+let sos_Q gl =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise  qq_domain_spec
+  [ non_linear_prover_Q "pure_sos" None ] gl
+
+let sos_R gl =
+ micromega_gen parse_rarith Mc.rnegate Mc.rnormalise  rz_domain_spec
+  [ non_linear_prover_R "pure_sos" None ] gl
+
+let xlia gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise   zz_domain_spec
+  [ linear_Z ] gl
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml
new file mode 100644
index 00000000..d4e6d920
--- /dev/null
+++ b/plugins/micromega/csdpcert.ml
@@ -0,0 +1,214 @@
+(************************************************************************)
+(*  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
+open Sos_types
+open Sos_lib
+
+
+module Mc = Micromega
+module Ml2C = Mutils.CamlToCoq
+module C2Ml = Mutils.CoqToCaml
+
+type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list
+type csdp_certificate = S of Sos_types.positivstellensatz option | F of string
+type provername = string * int option
+
+
+let debug = true
+let flags = [Open_append;Open_binary;Open_creat]
+
+let chan = open_out_gen flags 0o666 "trace"
+
+
+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)
+
+
+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 o l =
+  output_string o "print_list_term\n";
+ List.iter (fun (e,k) -> Printf.fprintf o "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")) (List.map (fun (e, o) -> Mc.denorm e , o) l) ;
+ output_string o "\n"
+
+
+let partition_expr l =
+ let rec f i = function
+  | [] -> ([],[],[])
+  | (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 =
+  let l = List.map (fun (e,op) -> (Mc.denorm e,op)) l in
+ 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
+   S (Some proof)
+ with
+  | Sos_lib.TooDeep -> S None
+  |    x        ->   F (Printexc.to_string x)
+
+(* This is somewhat buggy, over Z, strict inequality vanish... *)
+let pure_sos  l =
+  let l = List.map (fun (e,o) -> Mc.denorm e, o) l in
+
+ (* 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 *)
+    S (Some proof)
+ with
+(*   | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *)
+   |  x        -> (* May be that could be refined *) S None
+
+
+
+let run_prover prover pb =
+    match prover with
+    | "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb
+    | "pure_sos", None -> pure_sos pb
+    | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1)
+
+
+let output_csdp_certificate o = function
+  | S None -> output_string o "S None"
+  | S (Some p) -> Printf.fprintf o "S (Some %a)" output_psatz p
+  | F s        -> Printf.fprintf o "F %s" s
+
+
+let main () =
+  try
+    let (prover,poly) = (input_value stdin : provername * micromega_polys) in
+    let cert = run_prover prover poly in
+(*      Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ;
+      close_out chan ;   *)
+
+      output_value stdout (cert:csdp_certificate);
+      flush stdout ;
+      Marshal.to_channel  chan (cert:csdp_certificate) [] ;
+      flush chan ;
+      exit 0
+  with  x -> (Printf.fprintf chan "error %s" (Printexc.to_string x)  ; exit 1)
+
+;;
+
+let _ = main () in ()
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
new file mode 100644
index 00000000..f4d04e5d
--- /dev/null
+++ b/plugins/micromega/g_micromega.ml4
@@ -0,0 +1,76 @@
+(************************************************************************)
+(*  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$ *)
+
+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 ZOmicron
+[ "xlia"  ] -> [ Coq_micromega.xlia]
+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 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/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml
new file mode 100644
index 00000000..6250e324
--- /dev/null
+++ b/plugins/micromega/mfourier.ml
@@ -0,0 +1,1012 @@
+open Num
+module Utils = Mutils
+
+let map_option = Utils.map_option
+let from_option = Utils.from_option
+
+let debug = false
+type ('a,'b) lr = Inl of 'a | Inr of 'b
+
+
+module Vect =
+  struct
+    (** [t] is the type of vectors.
+	A vector [(x1,v1) ; ... ; (xn,vn)] is such that:
+	- variables indexes are ordered (x1 < ... < xn
+	- values are all non-zero
+    *)
+    type var = int
+    type t = (var * num) list
+
+(** [equal v1 v2 = true] if the vectors are syntactically equal.
+    ([num] is not handled by  [Pervasives.equal] *)
+
+    let rec equal v1 v2 =
+      match v1 , v2 with
+	| [] , []   -> true
+	| [] , _    -> false
+	| _::_ , [] -> false
+	| (i1,n1)::v1 , (i2,n2)::v2 ->
+	    (i1 = i2) && n1 =/ n2 && equal v1 v2
+
+    let hash v =
+      let rec hash i = function
+	| [] -> i
+	| (vr,vl)::l ->  hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in
+	Hashtbl.hash (hash 0 v )
+
+
+    let null = []
+
+    let pp_vect o vect =
+      List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect
+
+    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
+
+	xfrom_list 0 l
+
+    let zero_num = Int 0
+    let unit_num = Int 1
+
+
+    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 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 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 gcd m =
+      let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int  x (Utils.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 rec mul z t =
+      match z with
+	| Int 0 -> []
+	| Int 1 -> t
+	|  _    -> List.map (fun (i,n) -> (i, mult_num z n)) t
+
+    let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical
+      [
+	(fun () -> Pervasives.compare (fst x) (fst y));
+	(fun () -> compare_num (snd x) (snd y))])
+
+    (** [tail v vect] returns
+	- [None] if [v] is not a variable of the vector [vect]
+	- [Some(vl,rst)]  where [vl] is the value of [v] in vector [vect]
+        and [rst] is the remaining of the vector
+	We exploit that vectors are ordered lists
+    *)
+    let rec tail (v:var) (vect:t) =
+      match vect with
+	| [] -> None
+	| (v',vl)::vect' ->
+	    match Pervasives.compare v' v with
+	      | 0 -> Some (vl,vect) (* Ok, found *)
+	      | -1 -> tail v vect' (* Might be in the tail *)
+	      | _  -> None (* Hopeless *)
+
+    let get v vect =
+      match tail v vect with
+	| None -> None
+	| Some(vl,_) -> Some vl
+
+
+    let rec fresh v =
+	match v with
+	  | [] -> 1
+	  | [v,_] -> v + 1
+	  | _::v  -> fresh v
+
+  end
+open Vect
+
+(** Implementation of intervals *)
+module Itv =
+struct
+
+  (** The type of intervals is *)
+  type interval = num option * num option
+      (** None models the absence of bound i.e. infinity *)
+      (** As a result,
+	  - None , None   -> ]-oo,+oo[
+	  - None , Some v -> ]-oo,v]
+	  - Some v, None  -> [v,+oo[
+	  - Some v, Some v' -> [v,v']
+      Intervals needs to be explicitely normalised.
+      *)
+
+  type who = Left | Right
+
+
+  (** if then interval [itv] is empty, [norm_itv itv] returns [None]
+      otherwise, it returns [Some itv] *)
+
+  let norm_itv itv =
+    match itv with
+      | Some a , Some b -> if a <=/ b then Some itv else None
+      |   _             -> Some itv
+
+  (** [opp_itv itv] computes the opposite interval *)
+  let opp_itv itv =
+  let (l,r) = itv in
+    (map_option minus_num r, map_option minus_num l)
+
+
+
+
+(** [inter i1 i2 = None] if the intersection of intervals is empty
+    [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *)
+  let inter i1 i2 =
+    let (l1,r1) = i1
+    and (l2,r2) = i2 in
+
+    let inter f o1 o2 =
+      match o1 , o2 with
+	| None , None -> None
+	| Some _ , None -> o1
+	| None  , Some _ -> o2
+	| Some n1 , Some n2 -> Some (f n1 n2) in
+
+    norm_itv (inter max_num l1 l2 , inter min_num r1 r2)
+
+  let range = function
+    | None,_ | _,None -> None
+    | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1))
+
+
+  let smaller_itv i1 i2 =
+    match  range i1 ,  range i2  with
+      | None , _ -> false
+      |  _   , None -> true
+      | Some i , Some j -> i <=/ j
+
+
+(** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *)
+let in_bound bnd v =
+  let (l,r) = bnd in
+  match l , r with
+    | None , None -> true
+    | None , Some a -> v <=/ a
+    | Some a , None -> a <=/ v
+    | Some a , Some b -> a <=/ v && v <=/ b
+
+end
+open Itv
+type vector = Vect.t
+
+type cstr = { coeffs : vector ; bound : interval }
+(** 'cstr' is the type of constraints.
+    {coeffs = v ; bound = (l,r) } models the constraints l <= v <= r
+**)
+
+module ISet = Set.Make(struct type t = int let compare = Pervasives.compare end)
+
+
+module PSet = ISet
+
+
+module System = Hashtbl.Make(Vect)
+
+  type proof =
+      | Hyp of int
+      | Elim of  var * proof * proof
+      | And of proof * proof
+
+
+
+type system = {
+  sys : cstr_info ref System.t ;
+  vars : ISet.t
+}
+and cstr_info = {
+  bound : interval ;
+  prf : proof ;
+  pos : int ;
+  neg : int ;
+}
+
+
+(** A system of constraints has the form [{sys = s ; vars = v}].
+    [s] is a hashtable mapping a normalised vector to a [cstr_info] record where
+    - [bound] is an interval
+    - [prf_idx] is the set of hypothese indexes (i.e. constraints in the initial system) used to obtain the current constraint.
+       In the initial system, each constraint is given an unique singleton proof_idx.
+       When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn]
+    - [pos] is the number of positive values of the vector
+    - [neg] is the number of negative values of the vector
+    ( [neg] + [pos] is therefore the length of the vector)
+    [v] is an upper-bound of the set of variables which appear in [s].
+*)
+
+(** To be thrown when a system has no solution *)
+exception SystemContradiction of proof
+let hyps prf =
+  let rec hyps prf acc =
+    match prf with
+      | Hyp i -> ISet.add i acc
+      | Elim(_,prf1,prf2)
+      | And(prf1,prf2) -> hyps prf1 (hyps prf2 acc) in
+    hyps prf ISet.empty
+
+
+(** Pretty printing *)
+  let rec pp_proof o prf =
+    match prf with
+      | Hyp i -> Printf.fprintf o "H%i" i
+      | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2
+      | And(prf1,prf2)   -> Printf.fprintf o "A(%a,%a)"  pp_proof prf1 pp_proof prf2
+
+let pp_bound o  = function
+  | None -> output_string o "oo"
+  | Some a -> output_string o (string_of_num a)
+
+let pp_itv o (l,r) = Printf.fprintf o "(%a,%a)" pp_bound l pp_bound r
+
+let rec pp_list f o l =
+  match l with
+    | [] -> ()
+    | e::l -> f o e ; output_string o ";" ; pp_list f o l
+
+let pp_iset o s =
+  output_string o "{" ;
+  ISet.fold (fun i _ -> Printf.fprintf o "%i " i) s ();
+  output_string o "}"
+
+let pp_pset o s =
+  output_string o "{" ;
+  PSet.fold (fun i _ -> Printf.fprintf o "%i " i) s ();
+  output_string o "}"
+
+
+let pp_info o i = pp_itv o i.bound
+
+let pp_cstr o (vect,bnd) =
+    let (l,r) = bnd in
+      (match l with
+	| None -> ()
+	| Some n -> Printf.fprintf o "%s <= " (string_of_num n))
+      ;
+      pp_vect o vect ;
+      (match r with
+	      | None -> output_string o"\n"
+	      | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n))
+
+
+let pp_system o sys=
+  System.iter (fun vect ibnd ->
+    pp_cstr o (vect,(!ibnd).bound)) sys
+
+
+
+let pp_split_cstr o (vl,v,c,_) =
+  Printf.fprintf o "(val x = %s ,%a,%s)" (string_of_num vl) pp_vect  v  (string_of_num c)
+
+(** [merge_cstr_info] takes:
+    - the intersection of bounds and
+    - the union of proofs
+    - [pos] and [neg] fields should be identical *)
+
+let merge_cstr_info i1 i2 =
+  let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1
+  and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in
+    assert (p1 = p2 && n1 = n2) ;
+    match inter i1 i2 with
+      | None -> None (* Could directly raise a system contradiction exception *)
+      | Some bnd ->
+	  Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) }
+
+(** [xadd_cstr vect cstr_info] loads an constraint into the system.
+    The constraint is neither redundant nor contradictory.
+    @raise SystemContradiction if [cstr_info] returns [None]
+*)
+
+let xadd_cstr vect cstr_info sys =
+  if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ;
+  try
+    let info = System.find sys vect in
+      match merge_cstr_info cstr_info !info with
+	  | None       -> raise (SystemContradiction  (And(cstr_info.prf, (!info).prf)))
+	  | Some info' -> info := info'
+      with
+	| Not_found -> System.replace  sys vect (ref cstr_info)
+
+
+type cstr_ext =
+    | Contradiction (** The constraint is contradictory.
+			Typically, a [SystemContradiction] exception will be raised. *)
+    | Redundant  (** The constrain is redundant.
+		     Typically, the constraint will be dropped *)
+    | Cstr of vector * cstr_info (** Taken alone, the constraint is neither contradictory nor redundant.
+				     Typically, it will be added to the constraint system. *)
+
+(** [normalise_cstr] : vector -> cstr_info -> cstr_ext *)
+let normalise_cstr vect cinfo =
+  match norm_itv cinfo.bound with
+    | None -> Contradiction
+    | Some (l,r) ->
+	match vect with
+	  | [] -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction
+	  | (_,n)::_ ->  Cstr(
+	      (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect),
+			     let divn x = x // n in
+			       if sign_num n = 1
+			       then{cinfo with bound = (map_option divn l , map_option  divn r) }
+			       else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)})
+
+(** For compatibility, there an external representation of constraints *)
+
+type cstr_compat = {coeffs : vector ; op : op ; cst : num}
+and op = |Eq | Ge
+
+let string_of_op = function Eq -> "=" | Ge -> ">="
+
+
+let eval_op = function
+  | Eq -> (=/)
+  | Ge ->  (>=/)
+
+let count v =
+  let rec count n p v =
+    match v with
+      | [] -> (n,p)
+      | (_,vl)::v -> let sg = sign_num vl in
+		       assert (sg <> 0) ;
+	  if sg = 1 then count n (p+1) v else count (n+1) p v in
+    count 0 0 v
+
+
+let norm_cstr {coeffs = v ; op = o ; cst = c} idx =
+  let (n,p) = count v in
+
+  normalise_cstr v {pos = p ; neg = n ; bound =
+  (match o with
+	| Eq -> Some c , Some c
+	| Ge -> Some c , None) ;
+	    prf = Hyp idx }
+
+
+(** [load_system l] takes a list of constraints of type [cstr_compat]
+    @return a system of constraints
+    @raise SystemContradiction if a contradiction is found
+*)
+let load_system l =
+
+  let sys = System.create 1000 in
+
+  let li = Mutils.mapi (fun e i -> (e,i)) l in
+
+  let vars = List.fold_left (fun vrs (cstr,i) ->
+    match norm_cstr cstr i with
+      | Contradiction -> raise (SystemContradiction (Hyp i))
+      | Redundant      -> vrs
+      | Cstr(vect,info) ->
+	  xadd_cstr  vect info sys ;
+	  List.fold_left (fun s (v,_) -> ISet.add v s) vrs cstr.coeffs) ISet.empty li   in
+
+    {sys = sys ;vars = vars}
+
+let system_list sys =
+  let { sys = s ; vars  = v } = sys in
+    System.fold (fun k bi l -> (k, !bi)::l) s []
+
+
+(** [add (v1,c1)  (v2,c2)  ]
+    precondition:  (c1 <>/ Int 0 && c2 <>/ Int 0)
+    @return a pair [(v,ln)] such that
+    [v] is the sum of vector [v1] divided by [c1] and vector [v2] divided by [c2]
+    Note that the resulting vector is not normalised.
+*)
+
+let add (v1,c1)  (v2,c2)  =
+    assert (c1 <>/ Int 0 && c2 <>/ Int 0) ;
+
+  let rec xadd v1 v2  =
+    match v1 , v2 with
+      | (x1,n1)::v1' , (x2,n2)::v2' ->
+	  if x1 = x2
+	  then
+	    let n' = (n1 // c1) +/ (n2 // c2) in
+	      if n' =/ Int 0 then xadd v1' v2'
+	      else
+		let res = xadd v1' v2'  in
+		  (x1,n') ::res
+	  else if x1 < x2
+	  then let res = xadd v1' v2   in
+		 (x1, n1 // c1)::res
+	  else let res = xadd v1 v2'  in
+		 (x2, n2 // c2)::res
+      |  [] , [] -> []
+      |  [] ,  _ -> List.map (fun (x,vl) -> (x,vl // c2)) v2
+      |  _  , [] -> List.map (fun (x,vl) -> (x,vl // c1)) v1 in
+
+  let res = xadd v1 v2 in
+    (res, count res)
+
+let add (v1,c1)   (v2,c2)  =
+  let res = add (v1,c1)   (v2,c2)  in
+    (*    Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*)
+    res
+
+type tlr = (num * vector * cstr_info) list
+type tm = (vector * cstr_info ) list
+
+(** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *)
+
+(** [split x vect info (l,m,r)]
+    @param v is the variable to eliminate
+    @param l contains constraints such that (e + a*x) // a >= c / a
+    @param r contains constraints such that (e + a*x) // - a >= c / -a
+    @param m contains constraints which do not mention [x]
+*)
+
+let split x (vect: vector) info (l,m,r) =
+    match get x vect with
+      | None -> (* The constraint does not mention [x], store it in m *)
+	  (l,(vect,info)::m,r)
+      | Some vl -> (* otherwise *)
+
+          let cons_bound lst bd =
+            match  bd with
+              | None -> lst
+              | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in
+
+          let lb,rb = info.bound in
+            if sign_num vl = 1
+            then  (cons_bound l lb,m,cons_bound r rb)
+            else (* sign_num vl = -1 *)
+              (cons_bound l rb,m,cons_bound r lb)
+
+
+(** [project vr sys] projects system [sys] over the set of variables [ISet.remove vr sys.vars ].
+    This is a one step Fourier elimination.
+*)
+let project vr sys =
+
+  let (l,m,r)  = System.fold (fun vect rf l_m_r -> split vr vect !rf l_m_r) sys.sys  ([],[],[])  in
+
+  let new_sys = System.create (System.length sys.sys) in
+
+    (* Constraints in [m] belong to the projection - for those [vr] is already projected out *)
+    List.iter (fun  (vect,info) -> System.replace new_sys vect (ref info) )  m ;
+
+    let elim (v1,vect1,info1) (v2,vect2,info2) =
+      let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1
+      and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in
+
+      let bnd1 = from_option (fst bound1)
+      and bnd2 = from_option (fst bound2) in
+      let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in
+      let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2)  in
+        (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in
+
+      List.iter(fun  l_elem -> List.iter (fun r_elem ->
+        let (vect,info) = elim l_elem r_elem in
+	  match normalise_cstr vect info with
+	    | Redundant -> ()
+	    | Contradiction -> raise (SystemContradiction  info.prf)
+	    | Cstr(vect,info)   -> xadd_cstr vect info new_sys) r ) l;
+      {sys = new_sys ; vars = ISet.remove  vr sys.vars}
+
+
+(** [project_using_eq] performs elimination by pivoting using an equation.
+    This is the counter_part of the [elim] sub-function of [!project].
+    @param vr is the variable to be used as pivot
+    @param c is the coefficient of variable [vr] in vector [vect]
+    @param len is the length of the equation
+    @param bound is the bound of the equation
+    @param prf is the proof of the equation
+*)
+
+let project_using_eq vr c vect bound  prf (vect',info') =
+    match get vr vect' with
+    | Some c2 ->
+	let c1 = if c2 >=/ Int 0 then minus_num c else c in
+
+	let c2 = abs_num c2 in
+
+	let (vres,(n,p)) = add (vect,c1) (vect', c2)  in
+
+	let cst = bound // c1 in
+
+	let bndres =
+	  let f x = cst +/ x // c2 in
+	  let (l,r) = info'.bound in
+	    (map_option f l , map_option f r) in
+
+	  (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)})
+    | None -> (vect',info')
+
+let elim_var_using_eq vr vect cst  prf sys =
+  let c = from_option (get vr vect) in
+
+  let elim_var = project_using_eq vr c vect cst prf  in
+
+  let  new_sys  =  System.create (System.length sys.sys) in
+
+    System.iter(fun vect iref ->
+      let (vect',info') = elim_var (vect,!iref) in
+	match normalise_cstr vect' info' with
+	    | Redundant -> ()
+	    | Contradiction -> raise (SystemContradiction info'.prf)
+	    | Cstr(vect,info')   -> xadd_cstr vect info' new_sys) sys.sys ;
+
+    {sys = new_sys ; vars = ISet.remove  vr sys.vars}
+
+
+(** [size sys] computes the number of entries in the system of constraints *)
+let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0
+
+module IMap = Map.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end)
+
+let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map ()
+
+(** [eval_vect map vect] evaluates vector [vect] using the values of [map].
+    If [map] binds all the variables of [vect], we get
+    [eval_vect map [(x1,v1);...;(xn,vn)] = (IMap.find x1 map * v1) + ... + (IMap.find xn map) * vn , []]
+    The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *)
+
+let  eval_vect map vect =
+  let rec xeval_vect vect sum rst =
+    match vect with
+      | [] -> (sum,rst)
+      | (v,vl)::vect ->
+	  try
+	    let val_v = IMap.find v map in
+	      xeval_vect vect (sum +/ (val_v */ vl)) rst
+	  with
+	      Not_found -> xeval_vect vect sum ((v,vl)::rst) in
+    xeval_vect vect (Int 0) []
+
+
+(** [restrict_bound n sum itv] returns the interval of [x]
+    given that (fst itv) <=  x * n + sum <= (snd itv) *)
+let restrict_bound n sum (itv:interval) =
+  let f x  = (x -/ sum) // n in
+  let l,r = itv in
+    match sign_num n with
+      | 0 -> if in_bound itv sum
+	then (None,None) (* redundant *)
+	else failwith "SystemContradiction"
+      | 1 ->  map_option f l , map_option f r
+      | _ -> map_option f r , map_option f l
+
+
+(** [bound_of_variable map v sys] computes the interval of [v] in
+    [sys] given a mapping [map] binding all the other variables *)
+let bound_of_variable map v sys =
+  System.fold (fun vect iref bnd  ->
+    let sum,rst = eval_vect  map vect in
+    let vl = match get v rst with
+      | None -> Int 0
+      | Some v -> v in
+      match inter bnd (restrict_bound vl sum (!iref).bound) with
+	| None -> failwith "bound_of_variable: impossible"
+	| Some itv -> itv) sys  (None,None)
+
+
+(** [pick_small_value bnd] picks a value being closed to zero within the interval *)
+let pick_small_value bnd =
+  match bnd with
+    | None , None   ->  Int 0
+    | None , Some i ->  if  (Int 0) <=/ (floor_num  i) then Int 0 else floor_num i
+    | Some i,None   ->  if i <=/ (Int 0) then Int 0 else ceiling_num i
+    | Some i,Some j ->
+	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
+
+
+(** [solution s1 sys_l  = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)]
+    then [sn] is a  system which contains only [black_v] -- if it existed in [s1]
+    and [sn+1] is obtained by projecting [vn] out of [sn]
+    @raise SystemContradiction if  system [s] has no solution
+*)
+
+let solve_sys black_v choose_eq choose_variable sys sys_l =
+
+  let rec solve_sys sys sys_l =
+    if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys);
+
+    let eqs = choose_eq sys in
+      try
+	let (v,vect,cst,ln) =  fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in
+	  if debug then
+	    (Printf.printf "\nE %a = %s variable %i\n" pp_vect vect (string_of_num cst) v ;
+	     flush stdout);
+	  let sys' = elim_var_using_eq v vect cst ln sys in
+	    solve_sys sys' ((v,sys)::sys_l)
+    with Not_found ->
+      let vars = choose_variable  sys in
+	try
+	  let (v,est) =  (List.find (fun (v,_) -> v <> black_v) vars) in
+	    if debug then (Printf.printf "\nV : %i esimate %f\n" v est ; flush stdout) ;
+	    let sys' =  project v sys in
+	      solve_sys sys' ((v,sys)::sys_l)
+	with Not_found ->  (* we are done *) Inl (sys,sys_l)  in
+    solve_sys sys sys_l
+
+
+
+
+let  solve black_v choose_eq choose_variable cstrs =
+
+  try
+    let sys = load_system cstrs in
+(*      Printf.printf "solve :\n %a" pp_system sys.sys ; *)
+      solve_sys black_v choose_eq choose_variable sys []
+  with SystemContradiction prf -> Inr prf
+
+
+(** The  purpose of module [EstimateElimVar] is to try to estimate the cost of eliminating a variable.
+    The output is an ordered list of (variable,cost).
+*)
+
+module EstimateElimVar =
+struct
+  type sys_list = (vector * cstr_info) list
+
+  let abstract_partition (v:int) (l: sys_list) =
+
+    let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) =
+      match l with
+        | [] -> (ltl, n,z,p)
+        | (l1,info) ::rl ->
+            match  l1 with
+            | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p
+            | (vr,vl)::rl1 ->
+		if v = vr
+		then
+		  let cons_bound lst bd =
+		    match  bd with
+		      | None -> lst
+		      | Some bnd -> info.neg+info.pos::lst in
+
+		  let lb,rb = info.bound in
+		    if sign_num vl = 1
+		    then  xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb)
+		    else  xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb)
+		else
+		  (* the variable is greater *)
+		  xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p
+
+    in
+    let (sys',n,z,p) =  xpart l [] [] 0 []  in
+
+    let ln = float_of_int (List.length n) in
+    let sn = float_of_int (List.fold_left (+) 0 n) in
+    let lp = float_of_int (List.length p) in
+    let sp = float_of_int (List.fold_left (+) 0 p) in
+      (sys',  float_of_int z +.  lp *.  sn +.  ln *.  sp -. lp*.ln)
+
+
+  let choose_variable   sys =
+    let {sys = s ; vars = v} = sys in
+
+    let sl = system_list sys in
+
+    let evals  = fst
+      (ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s  in
+                                      ((v,vl)::eval, ts)) v ([],sl)) in
+
+      List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) evals
+
+
+end
+open EstimateElimVar
+
+(** The  module [EstimateElimEq] is similar to [EstimateElimVar] but it orders equations.
+*)
+module EstimateElimEq =
+struct
+
+  let itv_point bnd =
+    match bnd with
+      |(Some a, Some b) -> a =/ b
+      | _   -> false
+
+  let eq_bound bnd c =
+    match bnd with
+      |(Some a, Some b) -> a =/ b && c =/ b
+      | _   -> false
+
+
+  let rec unroll_until v l =
+    match l with
+      | [] -> (false,[])
+      | (i,_)::rl -> if i = v
+	then (true,rl)
+	else if i < v then unroll_until v rl else (false,l)
+
+
+  let choose_primal_equation eqs sys_l =
+
+    let is_primal_equation_var v =
+      List.fold_left (fun (nb_eq,nb_cst) (vect,info) ->
+	if fst (unroll_until v vect)
+	then if itv_point  info.bound then (nb_eq +  1,nb_cst) else (nb_eq,nb_cst)
+	else (nb_eq,nb_cst)) (0,0) sys_l in
+
+    let rec find_var vect =
+      match vect with
+	| [] -> None
+	| (i,_)::vect ->
+	    let (nb_eq,nb_cst) = is_primal_equation_var i in
+	      if nb_eq = 2 && nb_cst = 0
+	      then Some i else find_var vect in
+
+    let rec find_eq_var eqs =
+      match eqs with
+	| [] -> None
+	| (vect,a,prf,ln)::l ->
+	    match find_var vect with
+		| None -> find_eq_var l
+		| Some r -> Some (r,vect,a,prf,ln)
+    in
+
+
+      find_eq_var eqs
+
+
+
+
+  let choose_equality_var  sys =
+
+    let sys_l = system_list sys in
+
+    let equalities = List.fold_left
+      (fun  l (vect,info) ->
+	match  info.bound with
+	  | Some a , Some b ->
+	      if a =/ b then (* This an equation *)
+		(vect,a,info.prf,info.neg+info.pos)::l else l
+	  |   _ -> l
+      ) [] sys_l  in
+
+    let rec estimate_cost v ct sysl acc tlsys =
+      match sysl with
+	| [] -> (acc,tlsys)
+	| (l,info)::rsys ->
+	    let ln = info.pos + info.neg in
+	    let (b,l) = unroll_until v l in
+	    match b with
+	      | true ->
+		  if itv_point info.bound
+		  then estimate_cost  v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *)
+		  else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys)  (* should be more ? *)
+	      | false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in
+
+      match choose_primal_equation equalities sys_l with
+	| None ->
+	    let cost_eq eq const prf ln acc_costs =
+
+	      let rec cost_eq eqr sysl costs =
+		match eqr with
+		  | [] -> costs
+		  | (v,_) ::eqr -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in
+				     cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in
+		cost_eq eq sys_l acc_costs     in
+
+	    let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in
+
+	      (*      pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *)
+
+	      List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) all_costs
+	| Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0]
+
+
+end
+open EstimateElimEq
+
+module Fourier =
+struct
+
+  let optimise vect l =
+    (* We add a dummy (fresh) variable for vector *)
+    let fresh =
+      List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 l in
+    let cstr = {
+      coeffs = Vect.set fresh (Int (-1)) vect ;
+      op = Eq ;
+      cst = (Int 0)} in
+      match solve fresh choose_equality_var choose_variable (cstr::l) with
+	| Inr prf -> None (* This is an unsatisfiability proof *)
+	| Inl (s,_) ->
+	    try
+	      Some (bound_of_variable IMap.empty fresh s.sys)
+	    with
+		x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None
+
+
+  let find_point cstrs =
+
+    match solve max_int choose_equality_var choose_variable cstrs with
+      | Inr prf -> Inr prf
+      | Inl (_,l) ->
+
+	let rec rebuild_solution l map =
+	  match l with
+	    | [] -> map
+	    | (v,e)::l ->
+		let itv = bound_of_variable map v e.sys in
+		let map = IMap.add v (pick_small_value itv) map in
+		  rebuild_solution l map
+	in
+
+	let map = rebuild_solution l IMap.empty in
+	  let vect = List.rev (IMap.fold (fun v i vect -> (v,i)::vect) map []) in
+(*	    Printf.printf "SOLUTION %a" pp_vect vect ; *)
+	  let res = Inl vect in
+	    res
+
+
+end
+
+
+module Proof =
+struct
+
+
+
+
+(** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction.
+    The proofs constructed by Fourier elimination are more like execution traces:
+         - certain facts are recorded but are useless
+         - certain inferences are implicit.
+    The following code implements proof reconstruction.
+*)
+  let add x y = fst (add x y)
+
+
+  let forall_pairs f l1 l2 =
+    List.fold_left (fun acc e1 ->
+      List.fold_left (fun acc e2 ->
+	match f e1 e2 with
+	  | None -> acc
+	  | Some v -> v::acc) acc l2) [] l1
+
+
+  let add_op x y =
+    match x , y with
+      | Eq , Eq -> Eq
+      |     _   -> Ge
+
+
+  let pivot v (p1,c1) (p2,c2) =
+    let {coeffs = v1 ; op = op1 ; cst = n1} = c1
+    and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
+
+      match Vect.get v v1 , Vect.get v v2 with
+        | None , _ | _ , None -> None
+        | Some a   , Some b   ->
+            if (sign_num a) * (sign_num b) = -1
+            then Some (add (p1,abs_num a) (p2,abs_num b) ,
+                      {coeffs = add (v1,abs_num a) (v2,abs_num b) ;
+                       op = add_op op1 op2 ;
+                       cst = n1 // (abs_num a) +/ n2 // (abs_num b) })
+            else if op1 = Eq
+            then Some (add (p1,minus_num (a // b)) (p2,Int 1),
+                      {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ;
+                       op     = add_op op1 op2;
+                       cst    = n1 // (minus_num (a// b)) +/ n2 // (Int 1)})
+            else if op2 = Eq
+	    then
+	      Some (add (p2,minus_num (b // a)) (p1,Int 1),
+                   {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ;
+                    op     = add_op op1 op2;
+                    cst    = n2 // (minus_num (b// a)) +/ n1 // (Int 1)})
+	    else  None (* op2 could be Eq ... this might happen *)
+
+
+  let normalise_proofs l =
+    List.fold_left (fun acc (prf,cstr) ->
+      match acc with
+        | Inr _ -> acc (* I already found a contradiction *)
+        | Inl acc ->
+            match norm_cstr cstr 0 with
+              | Redundant -> Inl acc
+              | Contradiction -> Inr (prf,cstr)
+              | Cstr(v,info)  -> Inl ((prf,cstr,v,info)::acc)) (Inl []) l
+
+
+  type oproof = (vector * cstr_compat * num) option
+
+  let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) =
+    let (l,r) = info.bound in
+
+    let keep p ob bd =
+      match ob , bd with
+        | None , None -> None
+        | None , Some b -> Some(prf,cstr,b)
+        | Some _ , None -> ob
+        | Some(prfl,cstrl,bl) , Some b -> if p bl b then Some(prf,cstr, b) else ob in
+
+    let oleft  = keep (<=/) oleft l in
+    let oright = keep (>=/) oright r in
+      (* Now, there might be a contradiction *)
+      match oleft , oright with
+        | None , _ | _ , None -> Inl (oleft,oright)
+        | Some(prfl,cstrl,l) , Some(prfr,cstrr,r) ->
+            if l <=/ r
+            then Inl (oleft,oright)
+            else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*)
+              match cstrr.coeffs with
+                | [] -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *)
+                | (v,_)::_ ->
+                    match pivot v (prfl,cstrl) (prfr,cstrr) with
+                      | None -> failwith "merge_proof : pivot is not possible"
+                      | Some x -> Inr x
+
+let  mk_proof hyps prf =
+  (* I am keeping list - I might have a proof for the left bound and a proof for the right bound.
+     If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2.
+     For each proof list, all the vectors should be of the form a.v for different constants a.
+  *)
+
+  let rec mk_proof prf =
+    match prf with
+      | Hyp i -> [ ([i, Int 1] , List.nth hyps i) ]
+
+      | Elim(v,prf1,prf2) ->
+          let prfsl = mk_proof prf1
+          and prfsr = mk_proof prf2 in
+            (* I take only the pairs for which the elimination is meaningfull *)
+            forall_pairs (pivot v) prfsl prfsr
+      | And(prf1,prf2) ->
+          let prfsl1 = mk_proof prf1
+          and prfsl2 = mk_proof prf2 in
+          (* detect trivial redundancies and contradictions *)
+            match normalise_proofs (prfsl1@prfsl2) with
+              | Inr x -> [x] (* This is a contradiction - this should be the end of the proof *)
+              | Inl l -> (* All the vectors are the same *)
+                  let prfs =
+                    List.fold_left (fun acc e ->
+                      match acc with
+                        | Inr _ -> acc (* I have a contradiction *)
+                        | Inl (oleft,oright) -> merge_proof oleft e oright) (Inl(None,None)) l in
+                    match prfs with
+                      | Inr x -> [x]
+                      | Inl (oleft,oright) ->
+			  match oleft , oright with
+			    | None , None -> []
+			    | None , Some(prf,cstr,_) | Some(prf,cstr,_) , None -> [prf,cstr]
+			    | Some(prf1,cstr1,_) , Some(prf2,cstr2,_) -> [prf1,cstr1;prf2,cstr2] in
+
+    mk_proof prf
+
+
+end
+
diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml
new file mode 100644
index 00000000..c350ed0f
--- /dev/null
+++ b/plugins/micromega/micromega.ml
@@ -0,0 +1,1703 @@
+(** val negb : bool -> bool **)
+
+let negb = function
+  | true -> false
+  | false -> true
+
+type nat =
+  | O
+  | S of nat
+
+type comparison =
+  | Eq
+  | Lt
+  | Gt
+
+(** val compOpp : comparison -> comparison **)
+
+let compOpp = function
+  | Eq -> Eq
+  | Lt -> Gt
+  | Gt -> Lt
+
+(** val plus : nat -> nat -> nat **)
+
+let rec plus n0 m =
+  match n0 with
+    | O -> m
+    | S p -> S (plus p m)
+
+(** val app : 'a1 list -> 'a1 list -> 'a1 list **)
+
+let rec app l m =
+  match l with
+    | [] -> m
+    | a :: l1 -> a :: (app l1 m)
+
+(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **)
+
+let rec nth n0 l default =
+  match n0 with
+    | O -> (match l with
+              | [] -> default
+              | x :: l' -> x)
+    | S m -> (match l with
+                | [] -> default
+                | x :: t0 -> nth m t0 default)
+
+(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
+
+let rec map f = function
+  | [] -> []
+  | a :: t0 -> (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)
+
+(** val psize : positive -> nat **)
+
+let rec psize = function
+  | XI p2 -> S (psize p2)
+  | XO p2 -> S (psize p2)
+  | XH -> S O
+
+type n =
+  | N0
+  | Npos of positive
+
+(** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **)
+
+let rec pow_pos rmul x = function
+  | XI i0 -> let p = pow_pos rmul x i0 in rmul x (rmul p p)
+  | XO i0 -> let p = pow_pos rmul x i0 in rmul p p
+  | XH -> x
+
+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 zabs : z -> z **)
+
+let zabs = function
+  | Z0 -> Z0
+  | Zpos p -> Zpos p
+  | Zneg p -> Zpos p
+
+(** val zmax : z -> z -> z **)
+
+let zmax m n0 =
+  match zcompare m n0 with
+    | Lt -> n0
+    | _ -> m
+
+(** 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 **)
+
+let rec zdiv_eucl_POS a b =
+  match a with
+    | XI a' ->
+        let q0 , r = zdiv_eucl_POS a' b in
+        let r' = zplus (zmult (Zpos (XO XH)) r) (Zpos XH) in
+        if zgt_bool b r'
+        then (zmult (Zpos (XO XH)) q0) , r'
+        else (zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)) , (zminus r' b)
+    | XO a' ->
+        let q0 , r = zdiv_eucl_POS a' b in
+        let r' = zmult (Zpos (XO XH)) r in
+        if zgt_bool b r'
+        then (zmult (Zpos (XO XH)) q0) , r'
+        else (zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)) , (zminus r' b)
+    | XH ->
+        if zge_bool b (Zpos (XO XH)) then Z0 , (Zpos XH) else (Zpos XH) , Z0
+
+(** val zdiv_eucl : z -> z -> z  *  z **)
+
+let zdiv_eucl a b =
+  match a with
+    | Z0 -> Z0 , Z0
+    | Zpos a' ->
+        (match b with
+           | Z0 -> Z0 , Z0
+           | Zpos p -> zdiv_eucl_POS a' b
+           | Zneg b' ->
+               let q0 , r = zdiv_eucl_POS a' (Zpos b') in
+               (match r with
+                  | Z0 -> (zopp q0) , Z0
+                  | _ -> (zopp (zplus q0 (Zpos XH))) , (zplus b r)))
+    | Zneg a' ->
+        (match b with
+           | Z0 -> Z0 , Z0
+           | Zpos p ->
+               let q0 , r = zdiv_eucl_POS a' b in
+               (match r with
+                  | Z0 -> (zopp q0) , Z0
+                  | _ -> (zopp (zplus q0 (Zpos XH))) , (zminus b r))
+           | Zneg b' ->
+               let q0 , r = zdiv_eucl_POS a' (Zpos b') in q0 , (zopp r))
+
+(** val zdiv : z -> z -> z **)
+
+let zdiv a b =
+  let q0 , x = zdiv_eucl a b in q0
+
+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 -> if peq ceqb p2 p'0 then peq ceqb q0 q' else 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 ->
+        if ceqb c cO
+        then (match q0 with
+                | Pc c0 -> q0
+                | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
+                | PX (p2, p3, p4) -> Pinj (XH, q0))
+        else PX (p, i, q0)
+    | Pinj (p2, p3) -> PX (p, i, q0)
+    | PX (p', i', q') ->
+        if peq ceqb q' (p0 cO)
+        then PX (p', (pplus i' i), q0)
+        else 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 =
+  if ceqb c cO
+  then p0 cO
+  else if ceqb c cI then p else 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')))
+
+(** val psquare :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> bool) -> 'a1 pol -> 'a1 pol **)
+
+let rec psquare cO cI cadd cmul ceqb = function
+  | Pc c -> Pc (cmul c c)
+  | Pinj (j, q0) -> Pinj (j, (psquare cO cI cadd cmul ceqb q0))
+  | PX (p2, i, q0) ->
+      mkPX cO ceqb
+        (padd cO cadd ceqb
+          (mkPX cO ceqb (psquare cO cI cadd cmul ceqb p2) i (p0 cO))
+          (pmul cO cI cadd cmul ceqb p2
+            (let p3 = pmulC cO cI cmul ceqb q0 (cadd cI cI) in
+            match p3 with
+              | Pc c -> p3
+              | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
+              | PX (p4, p5, p6) -> Pinj (XH, p3)))) i
+        (psquare cO cI cadd cmul ceqb q0)
+
+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 =
+  []
+
+(** val ff : 'a1 cnf **)
+
+let ff =
+  [] :: []
+
+(** 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
+    | [] -> tt
+    | 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 -> if pol0 then tt else ff
+  | FF -> if pol0 then ff else tt
+  | X -> ff
+  | A x -> if pol0 then normalise0 x else negate0 x
+  | Cj (e1, e2) ->
+      if pol0
+      then and_cnf (xcnf normalise0 negate0 pol0 e1)
+             (xcnf normalise0 negate0 pol0 e2)
+      else or_cnf (xcnf normalise0 negate0 pol0 e1)
+             (xcnf normalise0 negate0 pol0 e2)
+  | D (e1, e2) ->
+      if pol0
+      then or_cnf (xcnf normalise0 negate0 pol0 e1)
+             (xcnf normalise0 negate0 pol0 e2)
+      else and_cnf (xcnf normalise0 negate0 pol0 e1)
+             (xcnf normalise0 negate0 pol0 e2)
+  | N e -> xcnf normalise0 negate0 (negb pol0) e
+  | I (e1, e2) ->
+      if pol0
+      then or_cnf (xcnf normalise0 negate0 (negb pol0) e1)
+             (xcnf normalise0 negate0 pol0 e2)
+      else 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
+    | [] -> true
+    | e :: f0 ->
+        (match l with
+           | [] -> false
+           | c :: l0 ->
+               if checker e c then cnf_checker checker f0 l0 else 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 polC = 'c pol
+
+type op1 =
+  | Equal
+  | NonEqual
+  | Strict
+  | NonStrict
+
+type 'c nFormula = 'c polC  *  op1
+
+(** val opAdd : op1 -> op1 -> op1 option **)
+
+let opAdd o o' =
+  match o with
+    | Equal -> Some o'
+    | NonEqual -> (match o' with
+                     | Equal -> Some NonEqual
+                     | _ -> None)
+    | Strict -> (match o' with
+                   | NonEqual -> None
+                   | _ -> Some Strict)
+    | NonStrict ->
+        (match o' with
+           | NonEqual -> None
+           | Strict -> Some Strict
+           | _ -> Some NonStrict)
+
+type 'c psatz =
+  | PsatzIn of nat
+  | PsatzSquare of 'c polC
+  | PsatzMulC of 'c polC * 'c psatz
+  | PsatzMulE of 'c psatz * 'c psatz
+  | PsatzAdd of 'c psatz * 'c psatz
+  | PsatzC of 'c
+  | PsatzZ
+
+(** val pexpr_times_nformula :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **)
+
+let pexpr_times_nformula cO cI cplus ctimes ceqb e = function
+  | ef , o ->
+      (match o with
+         | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef) , Equal)
+         | _ -> None)
+
+(** val nformula_times_nformula :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **)
+
+let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 =
+  let e1 , o1 = f1 in
+  let e2 , o2 = f2 in
+  (match o1 with
+     | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal)
+     | NonEqual ->
+         (match o2 with
+            | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal)
+            | NonEqual -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) ,
+                NonEqual)
+            | _ -> None)
+     | Strict ->
+         (match o2 with
+            | NonEqual -> None
+            | _ -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , o2))
+     | NonStrict ->
+         (match o2 with
+            | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal)
+            | NonEqual -> None
+            | _ -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , NonStrict)))
+
+(** val nformula_plus_nformula :
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1
+    nFormula -> 'a1 nFormula option **)
+
+let nformula_plus_nformula cO cplus ceqb f1 f2 =
+  let e1 , o1 = f1 in
+  let e2 , o2 = f2 in
+  (match opAdd o1 o2 with
+     | Some x -> Some ((padd cO cplus ceqb e1 e2) , x)
+     | None -> None)
+
+(** val eval_Psatz :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1
+    nFormula option **)
+
+let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function
+  | PsatzIn n0 -> Some (nth n0 l ((Pc cO) , Equal))
+  | PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0) , NonStrict)
+  | PsatzMulC (re, e0) ->
+      (match eval_Psatz cO cI cplus ctimes ceqb cleb l e0 with
+         | Some x -> pexpr_times_nformula cO cI cplus ctimes ceqb re x
+         | None -> None)
+  | PsatzMulE (f1, f2) ->
+      (match eval_Psatz cO cI cplus ctimes ceqb cleb l f1 with
+         | Some x ->
+             (match eval_Psatz cO cI cplus ctimes ceqb cleb l f2 with
+                | Some x' ->
+                    nformula_times_nformula cO cI cplus ctimes ceqb x x'
+                | None -> None)
+         | None -> None)
+  | PsatzAdd (f1, f2) ->
+      (match eval_Psatz cO cI cplus ctimes ceqb cleb l f1 with
+         | Some x ->
+             (match eval_Psatz cO cI cplus ctimes ceqb cleb l f2 with
+                | Some x' -> nformula_plus_nformula cO cplus ceqb x x'
+                | None -> None)
+         | None -> None)
+  | PsatzC c ->
+      if (&&) (cleb cO c) (negb (ceqb cO c))
+      then Some ((Pc c) , Strict)
+      else None
+  | PsatzZ -> Some ((Pc cO) , Equal)
+
+(** val check_inconsistent :
+    'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula ->
+    bool **)
+
+let check_inconsistent cO ceqb cleb = function
+  | e , op ->
+      (match e with
+         | Pc c ->
+             (match op with
+                | Equal -> negb (ceqb c cO)
+                | NonEqual -> ceqb c cO
+                | Strict -> cleb c cO
+                | NonStrict -> (&&) (cleb c cO) (negb (ceqb c cO)))
+         | _ -> false)
+
+(** val check_normalised_formulas :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz ->
+    bool **)
+
+let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm =
+  match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with
+    | Some f -> check_inconsistent cO ceqb cleb f
+    | None -> false
+
+type op2 =
+  | OpEq
+  | OpNEq
+  | OpLe
+  | OpGe
+  | OpLt
+  | OpGt
+
+type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr }
+
+(** val flhs : 'a1 formula -> 'a1 pExpr **)
+
+let flhs x = x.flhs
+
+(** val fop : 'a1 formula -> op2 **)
+
+let fop x = x.fop
+
+(** val frhs : 'a1 formula -> 'a1 pExpr **)
+
+let frhs x = x.frhs
+
+(** val norm :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **)
+
+let norm cO cI cplus ctimes cminus copp ceqb pe =
+  norm_aux cO cI cplus ctimes cminus copp ceqb pe
+
+(** val psub0 :
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
+    -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
+
+let psub0 cO cplus cminus copp ceqb p p' =
+  psub cO cplus cminus copp ceqb p p'
+
+(** val padd0 :
+    'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
+    -> 'a1 pol **)
+
+let padd0 cO cplus ceqb p p' =
+  padd cO cplus ceqb p p'
+
+(** val xnormalise :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+    nFormula list **)
+
+let xnormalise cO cI cplus ctimes cminus copp ceqb t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+  let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in
+  let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in
+  (match o with
+     | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) ::
+         (((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: [])
+     | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Equal) :: []
+     | OpLe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) :: []
+     | OpGe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: []
+     | OpLt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , NonStrict) ::
+         []
+     | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , NonStrict) ::
+         [])
+
+(** val cnf_normalise :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+    nFormula cnf **)
+
+let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 =
+  map (fun x -> x :: []) (xnormalise cO cI cplus ctimes cminus copp ceqb t0)
+
+(** val xnegate :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+    nFormula list **)
+
+let xnegate cO cI cplus ctimes cminus copp ceqb t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+  let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in
+  let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in
+  (match o with
+     | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Equal) :: []
+     | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) ::
+         (((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: [])
+     | OpLe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , NonStrict) ::
+         []
+     | OpGe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , NonStrict) ::
+         []
+     | OpLt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: []
+     | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) :: [])
+
+(** val cnf_negate :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+    -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+    nFormula cnf **)
+
+let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 =
+  map (fun x -> x :: []) (xnegate cO cI cplus ctimes cminus copp ceqb t0)
+
+(** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **)
+
+let rec xdenorm jmp = function
+  | Pc c -> PEc c
+  | Pinj (j, p2) -> xdenorm (pplus j jmp) p2
+  | PX (p2, j, q0) -> PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp),
+      (Npos j))))), (xdenorm (psucc jmp) q0))
+
+(** val denorm : 'a1 pol -> 'a1 pExpr **)
+
+let denorm p =
+  xdenorm XH p
+
+(** val simpl_cone :
+    'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz ->
+    'a1 psatz **)
+
+let simpl_cone cO cI ctimes ceqb e = match e with
+  | PsatzSquare t0 ->
+      (match t0 with
+         | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c)
+         | _ -> PsatzSquare t0)
+  | PsatzMulE (t1, t2) ->
+      (match t1 with
+         | PsatzMulE (x, x0) ->
+             (match x with
+                | PsatzC p2 ->
+                    (match t2 with
+                       | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0)
+                       | PsatzZ -> PsatzZ
+                       | _ -> e)
+                | _ ->
+                    (match x0 with
+                       | PsatzC p2 ->
+                           (match t2 with
+                              | PsatzC c -> PsatzMulE ((PsatzC
+                                  (ctimes c p2)), x)
+                              | PsatzZ -> PsatzZ
+                              | _ -> e)
+                       | _ ->
+                           (match t2 with
+                              | PsatzC c ->
+                                  if ceqb cI c
+                                  then t1
+                                  else PsatzMulE (t1, t2)
+                              | PsatzZ -> PsatzZ
+                              | _ -> e)))
+         | PsatzC c ->
+             (match t2 with
+                | PsatzMulE (x, x0) ->
+                    (match x with
+                       | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0)
+                       | _ ->
+                           (match x0 with
+                              | PsatzC p2 -> PsatzMulE ((PsatzC
+                                  (ctimes c p2)), x)
+                              | _ ->
+                                  if ceqb cI c
+                                  then t2
+                                  else PsatzMulE (t1, t2)))
+                | PsatzAdd (y, z0) -> PsatzAdd ((PsatzMulE ((PsatzC c), y)),
+                    (PsatzMulE ((PsatzC c), z0)))
+                | PsatzC c0 -> PsatzC (ctimes c c0)
+                | PsatzZ -> PsatzZ
+                | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))
+         | PsatzZ -> PsatzZ
+         | _ ->
+             (match t2 with
+                | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2)
+                | PsatzZ -> PsatzZ
+                | _ -> e))
+  | PsatzAdd (t1, t2) ->
+      (match t1 with
+         | PsatzZ -> t2
+         | _ -> (match t2 with
+                   | PsatzZ -> t1
+                   | _ -> PsatzAdd (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 qeq_bool : q -> q -> bool **)
+
+let qeq_bool x y =
+  zeq_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.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))
+
+(** 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)
+
+(** val qinv : q -> q **)
+
+let qinv x =
+  match x.qnum with
+    | Z0 -> { qnum = Z0; qden = XH }
+    | Zpos p -> { qnum = (Zpos x.qden); qden = p }
+    | Zneg p -> { qnum = (Zneg x.qden); qden = p }
+
+(** val qpower_positive : q -> positive -> q **)
+
+let qpower_positive q0 p =
+  pow_pos qmult q0 p
+
+(** val qpower : q -> z -> q **)
+
+let qpower q0 = function
+  | Z0 -> { qnum = (Zpos XH); qden = XH }
+  | Zpos p -> qpower_positive q0 p
+  | Zneg p -> qinv (qpower_positive q0 p)
+
+(** val pgcdn : nat -> positive -> positive -> positive **)
+
+let rec pgcdn n0 a b =
+  match n0 with
+    | O -> XH
+    | S n1 ->
+        (match a with
+           | XI a' ->
+               (match b with
+                  | XI b' ->
+                      (match pcompare a' b' Eq with
+                         | Eq -> a
+                         | Lt -> pgcdn n1 (pminus b' a') a
+                         | Gt -> pgcdn n1 (pminus a' b') b)
+                  | XO b0 -> pgcdn n1 a b0
+                  | XH -> XH)
+           | XO a0 ->
+               (match b with
+                  | XI p -> pgcdn n1 a0 b
+                  | XO b0 -> XO (pgcdn n1 a0 b0)
+                  | XH -> XH)
+           | XH -> XH)
+
+(** val pgcd : positive -> positive -> positive **)
+
+let pgcd a b =
+  pgcdn (plus (psize a) (psize b)) a b
+
+(** val zgcd : z -> z -> z **)
+
+let zgcd a b =
+  match a with
+    | Z0 -> zabs b
+    | Zpos a0 ->
+        (match b with
+           | Z0 -> zabs a
+           | Zpos b0 -> Zpos (pgcd a0 b0)
+           | Zneg b0 -> Zpos (pgcd a0 b0))
+    | Zneg a0 ->
+        (match b with
+           | Z0 -> zabs a
+           | Zpos b0 -> Zpos (pgcd a0 b0)
+           | Zneg b0 -> Zpos (pgcd a0 b0))
+
+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 psatz
+
+(** val zWeakChecker : z nFormula list -> z psatz -> bool **)
+
+let zWeakChecker x x0 =
+  check_normalised_formulas Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0
+
+(** val psub1 : z pol -> z pol -> z pol **)
+
+let psub1 p p' =
+  psub0 Z0 zplus zminus zopp zeq_bool p p'
+
+(** val padd1 : z pol -> z pol -> z pol **)
+
+let padd1 p p' =
+  padd0 Z0 zplus zeq_bool p p'
+
+(** val norm0 : z pExpr -> z pol **)
+
+let norm0 pe =
+  norm Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool pe
+
+(** val xnormalise0 : z formula -> z nFormula list **)
+
+let xnormalise0 t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+  let lhs0 = norm0 lhs in
+  let rhs0 = norm0 rhs in
+  (match o with
+     | OpEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) ::
+         (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: [])
+     | OpNEq -> ((psub1 lhs0 rhs0) , Equal) :: []
+     | OpLe -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: []
+     | OpGe -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: []
+     | OpLt -> ((psub1 lhs0 rhs0) , NonStrict) :: []
+     | OpGt -> ((psub1 rhs0 lhs0) , NonStrict) :: [])
+
+(** val normalise : z formula -> z nFormula cnf **)
+
+let normalise t0 =
+  map (fun x -> x :: []) (xnormalise0 t0)
+
+(** val xnegate0 : z formula -> z nFormula list **)
+
+let xnegate0 t0 =
+  let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+  let lhs0 = norm0 lhs in
+  let rhs0 = norm0 rhs in
+  (match o with
+     | OpEq -> ((psub1 lhs0 rhs0) , Equal) :: []
+     | OpNEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) ::
+         (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: [])
+     | OpLe -> ((psub1 rhs0 lhs0) , NonStrict) :: []
+     | OpGe -> ((psub1 lhs0 rhs0) , NonStrict) :: []
+     | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: []
+     | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: [])
+
+(** val negate : z formula -> z nFormula cnf **)
+
+let negate t0 =
+  map (fun x -> x :: []) (xnegate0 t0)
+
+(** val ceiling : z -> z -> z **)
+
+let ceiling a b =
+  let q0 , r = zdiv_eucl a b in
+  (match r with
+     | Z0 -> q0
+     | _ -> zplus q0 (Zpos XH))
+
+type zArithProof =
+  | DoneProof
+  | RatProof of zWitness * zArithProof
+  | CutProof of zWitness * zArithProof
+  | EnumProof of zWitness * zWitness * zArithProof list
+
+(** val zgcdM : z -> z -> z **)
+
+let zgcdM x y =
+  zmax (zgcd x y) (Zpos XH)
+
+(** val zgcd_pol : z polC -> z  *  z **)
+
+let rec zgcd_pol = function
+  | Pc c -> Z0 , c
+  | Pinj (p2, p3) -> zgcd_pol p3
+  | PX (p2, p3, q0) ->
+      let g1 , c1 = zgcd_pol p2 in
+      let g2 , c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2) , c2
+
+(** val zdiv_pol : z polC -> z -> z polC **)
+
+let rec zdiv_pol p x =
+  match p with
+    | Pc c -> Pc (zdiv c x)
+    | Pinj (j, p2) -> Pinj (j, (zdiv_pol p2 x))
+    | PX (p2, j, q0) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q0 x))
+
+(** val makeCuttingPlane : z polC -> z polC  *  z **)
+
+let makeCuttingPlane p =
+  let g , c = zgcd_pol p in
+  if zgt_bool g Z0
+  then (zdiv_pol (psubC zminus p c) g) , (zopp (ceiling (zopp c) g))
+  else p , Z0
+
+(** val genCuttingPlane : z nFormula -> ((z polC  *  z)  *  op1) option **)
+
+let genCuttingPlane = function
+  | e , op ->
+      (match op with
+         | Equal ->
+             let g , c = zgcd_pol e in
+             if (&&) (zgt_bool g Z0)
+                  ((&&) (zgt_bool c Z0) (negb (zeq_bool (zgcd g c) g)))
+             then None
+             else Some ((e , Z0) , op)
+         | NonEqual -> Some ((e , Z0) , op)
+         | Strict ->
+             let p , c = makeCuttingPlane (psubC zminus e (Zpos XH)) in
+             Some ((p , c) , NonStrict)
+         | NonStrict ->
+             let p , c = makeCuttingPlane e in Some ((p , c) , NonStrict))
+
+(** val nformula_of_cutting_plane :
+    ((z polC  *  z)  *  op1) -> z nFormula **)
+
+let nformula_of_cutting_plane = function
+  | e_z , o -> let e , z0 = e_z in (padd1 e (Pc z0)) , o
+
+(** val is_pol_Z0 : z polC -> bool **)
+
+let is_pol_Z0 = function
+  | Pc z0 -> (match z0 with
+                | Z0 -> true
+                | _ -> false)
+  | _ -> false
+
+(** val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option **)
+
+let eval_Psatz0 x x0 =
+  eval_Psatz Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0
+
+(** val check_inconsistent0 : z nFormula -> bool **)
+
+let check_inconsistent0 f =
+  check_inconsistent Z0 zeq_bool zle_bool f
+
+(** val zChecker : z nFormula list -> zArithProof -> bool **)
+
+let rec zChecker l = function
+  | DoneProof -> false
+  | RatProof (w, pf0) ->
+      (match eval_Psatz0 l w with
+         | Some f ->
+             if check_inconsistent0 f then true else zChecker (f :: l) pf0
+         | None -> false)
+  | CutProof (w, pf0) ->
+      (match eval_Psatz0 l w with
+         | Some f ->
+             (match genCuttingPlane f with
+                | Some cp ->
+                    zChecker ((nformula_of_cutting_plane cp) :: l) pf0
+                | None -> true)
+         | None -> false)
+  | EnumProof (w1, w2, pf0) ->
+      (match eval_Psatz0 l w1 with
+         | Some f1 ->
+             (match eval_Psatz0 l w2 with
+                | Some f2 ->
+                    (match genCuttingPlane f1 with
+                       | Some p ->
+                           let p2 , op3 = p in
+                           let e1 , z1 = p2 in
+                           (match genCuttingPlane f2 with
+                              | Some p3 ->
+                                  let p4 , op4 = p3 in
+                                  let e2 , z2 = p4 in
+                                  (match op3 with
+                                     | NonStrict ->
+                                         (match op4 with
+                                            | NonStrict ->
+                                                if is_pol_Z0 (padd1 e1 e2)
+                                                then
+                                                  let rec label pfs lb ub =
+
+                                                  match pfs with
+                                                    |
+                                                  [] -> zgt_bool lb ub
+                                                    |
+                                                  pf1 :: rsr ->
+                                                  (&&)
+                                                  (zChecker
+                                                  (((psub1 e1 (Pc lb)) ,
+                                                  Equal) :: l) pf1)
+                                                  (label rsr
+                                                  (zplus lb (Zpos XH)) ub)
+                                                  in label pf0 (zopp z1) z2
+                                                else false
+                                            | _ -> false)
+                                     | _ -> false)
+                              | None -> false)
+                       | None -> false)
+                | None -> false)
+         | None -> false)
+
+(** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **)
+
+let zTautoChecker f w =
+  tauto_checker normalise negate zChecker f w
+
+(** val n_of_Z : z -> n **)
+
+let n_of_Z = function
+  | Zpos p -> Npos p
+  | _ -> N0
+
+type qWitness = q psatz
+
+(** val qWeakChecker : q nFormula list -> q psatz -> bool **)
+
+let qWeakChecker x x0 =
+  check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH);
+    qden = XH } qplus qmult qeq_bool qle_bool x x0
+
+(** val qnormalise : q formula -> q nFormula cnf **)
+
+let qnormalise t0 =
+  cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH }
+    qplus qmult qminus qopp qeq_bool t0
+
+(** val qnegate : q formula -> q nFormula cnf **)
+
+let qnegate t0 =
+  cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus
+    qmult qminus qopp qeq_bool t0
+
+(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **)
+
+let qTautoChecker f w =
+  tauto_checker qnormalise qnegate qWeakChecker f w
+
+type rWitness = z psatz
+
+(** val rWeakChecker : z nFormula list -> z psatz -> bool **)
+
+let rWeakChecker x x0 =
+  check_normalised_formulas Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0
+
+(** val rnormalise : z formula -> z nFormula cnf **)
+
+let rnormalise t0 =
+  cnf_normalise Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0
+
+(** val rnegate : z formula -> z nFormula cnf **)
+
+let rnegate t0 =
+  cnf_negate Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0
+
+(** val rTautoChecker : z formula bFormula -> rWitness list -> bool **)
+
+let rTautoChecker f w =
+  tauto_checker rnormalise rnegate rWeakChecker f w
+
diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli
new file mode 100644
index 00000000..3e3ae2c3
--- /dev/null
+++ b/plugins/micromega/micromega.mli
@@ -0,0 +1,442 @@
+val negb : bool -> bool
+
+type nat =
+  | O
+  | S of nat
+
+type comparison =
+  | Eq
+  | Lt
+  | Gt
+
+val compOpp : comparison -> comparison
+
+val plus : nat -> nat -> nat
+
+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
+
+val psize : positive -> nat
+
+type n =
+  | N0
+  | Npos of positive
+
+val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1
+
+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 zabs : z -> z
+
+val zmax : z -> z -> z
+
+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
+
+val zdiv_eucl : z -> z -> z  *  z
+
+val zdiv : z -> z -> z
+
+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
+
+val psquare :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  bool) -> '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 polC = 'c pol
+
+type op1 =
+  | Equal
+  | NonEqual
+  | Strict
+  | NonStrict
+
+type 'c nFormula = 'c polC  *  op1
+
+val opAdd : op1 -> op1 -> op1 option
+
+type 'c psatz =
+  | PsatzIn of nat
+  | PsatzSquare of 'c polC
+  | PsatzMulC of 'c polC * 'c psatz
+  | PsatzMulE of 'c psatz * 'c psatz
+  | PsatzAdd of 'c psatz * 'c psatz
+  | PsatzC of 'c
+  | PsatzZ
+
+val pexpr_times_nformula :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option
+
+val nformula_times_nformula :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option
+
+val nformula_plus_nformula :
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1
+  nFormula -> 'a1 nFormula option
+
+val eval_Psatz :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1
+  nFormula option
+
+val check_inconsistent :
+  'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool
+
+val check_normalised_formulas :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool
+
+type op2 =
+  | OpEq
+  | OpNEq
+  | OpLe
+  | OpGe
+  | OpLt
+  | OpGt
+
+type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr }
+
+val flhs : 'a1 formula -> 'a1 pExpr
+
+val fop : 'a1 formula -> op2
+
+val frhs : 'a1 formula -> 'a1 pExpr
+
+val norm :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
+
+val psub0 :
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
+  -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+
+val padd0 :
+  'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol ->
+  'a1 pol
+
+val xnormalise :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
+  list
+
+val cnf_normalise :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
+  cnf
+
+val xnegate :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
+  list
+
+val cnf_negate :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+  'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
+  cnf
+
+val xdenorm : positive -> 'a1 pol -> 'a1 pExpr
+
+val denorm : 'a1 pol -> 'a1 pExpr
+
+val simpl_cone :
+  'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz ->
+  'a1 psatz
+
+type q = { qnum : z; qden : positive }
+
+val qnum : q -> z
+
+val qden : q -> positive
+
+val qeq_bool : q -> q -> bool
+
+val qle_bool : q -> q -> bool
+
+val qplus : q -> q -> q
+
+val qmult : q -> q -> q
+
+val qopp : q -> q
+
+val qminus : q -> q -> q
+
+val qinv : q -> q
+
+val qpower_positive : q -> positive -> q
+
+val qpower : q -> z -> q
+
+val pgcdn : nat -> positive -> positive -> positive
+
+val pgcd : positive -> positive -> positive
+
+val zgcd : z -> z -> z
+
+type 'a t =
+  | Empty
+  | Leaf of 'a
+  | Node of 'a t * 'a * 'a t
+
+val find : 'a1 -> 'a1 t -> positive -> 'a1
+
+type zWitness = z psatz
+
+val zWeakChecker : z nFormula list -> z psatz -> bool
+
+val psub1 : z pol -> z pol -> z pol
+
+val padd1 : z pol -> z pol -> z pol
+
+val norm0 : z pExpr -> z pol
+
+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 zArithProof =
+  | DoneProof
+  | RatProof of zWitness * zArithProof
+  | CutProof of zWitness * zArithProof
+  | EnumProof of zWitness * zWitness * zArithProof list
+
+val zgcdM : z -> z -> z
+
+val zgcd_pol : z polC -> z  *  z
+
+val zdiv_pol : z polC -> z -> z polC
+
+val makeCuttingPlane : z polC -> z polC  *  z
+
+val genCuttingPlane : z nFormula -> ((z polC  *  z)  *  op1) option
+
+val nformula_of_cutting_plane : ((z polC  *  z)  *  op1) -> z nFormula
+
+val is_pol_Z0 : z polC -> bool
+
+val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option
+
+val check_inconsistent0 : z nFormula -> bool
+
+val zChecker : z nFormula list -> zArithProof -> bool
+
+val zTautoChecker : z formula bFormula -> zArithProof list -> bool
+
+val n_of_Z : z -> n
+
+type qWitness = q psatz
+
+val qWeakChecker : q nFormula list -> q psatz -> bool
+
+val qnormalise : q formula -> q nFormula cnf
+
+val qnegate : q formula -> q nFormula cnf
+
+val qTautoChecker : q formula bFormula -> qWitness list -> bool
+
+type rWitness = z psatz
+
+val rWeakChecker : z nFormula list -> z psatz -> bool
+
+val rnormalise : z formula -> z nFormula cnf
+
+val rnegate : z formula -> z nFormula cnf
+
+val rTautoChecker : z formula bFormula -> rWitness list -> bool
+
diff --git a/plugins/micromega/micromega_plugin.mllib b/plugins/micromega/micromega_plugin.mllib
new file mode 100644
index 00000000..debc296e
--- /dev/null
+++ b/plugins/micromega/micromega_plugin.mllib
@@ -0,0 +1,9 @@
+Sos_types
+Mutils
+Micromega
+Mfourier
+Certificate
+Persistent_cache
+Coq_micromega
+G_micromega
+Micromega_plugin_mod
diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml
new file mode 100644
index 00000000..ec06fa58
--- /dev/null
+++ b/plugins/micromega/mutils.ml
@@ -0,0 +1,402 @@
+(************************************************************************)
+(*  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 finally f rst =
+  try
+    let res = f () in
+      rst () ; res
+  with x ->
+    (try rst ()
+    with _  -> raise x
+    ); raise x
+
+let map_option f x =
+  match x with
+    | None -> None
+    | Some v -> Some (f v)
+
+let from_option = function
+  | None -> failwith "from_option"
+  | Some v -> v
+
+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 iteri f l =
+ let rec xiter i l =
+  match l with
+   | [] -> ()
+   | e::l -> f i e ; xiter (i+1) l in
+  xiter 0 l
+
+let mapi f l =
+ let rec xmap i l =
+  match l with
+   | [] -> []
+   | e::l -> (f i e)::xmap (i+1) l in
+  xmap 0 l
+
+let rec map3 f l1 l2 l3 =
+  match l1 , l2 ,l3 with
+    | [] , [] , [] -> []
+    | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3)
+    |      _   -> raise (Invalid_argument "map3")
+
+
+
+let rec is_sublist l1 l2 =
+  match l1 ,l2 with
+    | [] ,_ -> true
+    | e::l1', [] -> false
+    | e::l1' , e'::l2' ->
+	if e = e' then is_sublist l1' l2'
+	else is_sublist l1 l2'
+
+
+
+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 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)}
+
+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
+
+module type Tag =
+sig
+  type t
+
+  val from : int -> t
+  val next : t -> t
+  val pp : out_channel -> t -> unit
+  val compare : t -> t -> int
+end
+
+module Tag : Tag =
+struct
+  type t = int
+  let from i = i
+  let next i = i + 1
+  let pp o i = output_string o (string_of_int i)
+  let compare : int -> int -> int = Pervasives.compare
+end
+
+module TagSet = Set.Make(Tag)
+
+
+let command exe_path args vl =
+  (* creating pipes for stdin, stdout, stderr *)
+  let (stdin_read,stdin_write) = Unix.pipe ()
+  and (stdout_read,stdout_write) = Unix.pipe ()
+  and (stderr_read,stderr_write) = Unix.pipe () in
+
+
+  (* Create the process *)
+  let pid = Unix.create_process exe_path args stdin_read stdout_write stderr_write in
+
+  (* Write the data on the stdin of the created process *)
+  let outch = Unix.out_channel_of_descr stdin_write in
+    output_value outch vl ;
+    flush outch ;
+
+  (* Wait for its completion *)
+    let _pid,status = Unix.waitpid [] pid in
+
+      finally
+	(fun () ->
+	  (* Recover the result *)
+	  match status with
+	    | Unix.WEXITED 0 ->
+		let inch  = Unix.in_channel_of_descr  stdout_read in
+		  begin try Marshal.from_channel inch with x -> failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) end
+	    | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i)
+	    | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i)
+	    | Unix.WSTOPPED  i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i))
+	(fun () ->
+	  (* Cleanup  *)
+	  List.iter (fun x -> try Unix.close x with _ -> ()) [stdin_read; stdin_write; stdout_read ; stdout_write ; stderr_read; stderr_write]
+	)
+
+
+
+
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml
new file mode 100644
index 00000000..f17e1c35
--- /dev/null
+++ b/plugins/micromega/persistent_cache.ml
@@ -0,0 +1,180 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* A persistent hashtable                                               *)
+(*                                                                      *)
+(*  Frédéric Besson (Inria Rennes) 2009                                 *)
+(*                                                                      *)
+(************************************************************************)
+
+
+module type PHashtable =
+  sig
+    type 'a t
+    type key
+
+    val create : int -> string -> 'a t
+    (** [create i f] creates an empty persistent table
+	with initial size i
+	associated with file [f] *)
+
+
+    val open_in : string -> 'a t
+    (** [open_in f] rebuilds a table from the records stored in file [f].
+	As marshaling is not type-safe, it migth segault.
+    *)
+
+    val find : 'a t -> key -> 'a
+    (** find has the specification of Hashtable.find *)
+
+    val add  : 'a t -> key -> 'a -> unit
+    (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl].
+	(and writes the binding to the file associated with [tbl].)
+	If [key] is already bound, raises KeyAlreadyBound *)
+
+    val close : 'a t -> unit
+    (** [close tbl] is closing the table.
+	Once closed, a table cannot be used.
+	i.e, copy, find,add will raise UnboundTable *)
+
+    val memo : string -> (key -> 'a) -> (key -> 'a)
+      (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table.
+	  Note that the cache will only be loaded when the function is used for the first time *)
+
+  end
+
+open Hashtbl
+
+module PHashtable(Key:HashedType) : PHashtable with type key = Key.t  =
+struct
+
+  type key = Key.t
+
+  module Table = Hashtbl.Make(Key)
+
+
+
+  exception InvalidTableFormat
+  exception UnboundTable
+
+
+  type mode = Closed | Open
+
+
+  type 'a t =
+      {
+	outch : out_channel ;
+	mutable status : mode ;
+	htbl : 'a Table.t
+      }
+
+
+let create i f =
+  {
+    outch = open_out_bin f ;
+    status = Open ;
+    htbl = Table.create i
+  }
+
+let finally f rst =
+  try
+    let res = f () in
+      rst () ; res
+  with x ->
+    (try rst ()
+    with _  -> raise x
+    ); raise x
+
+
+let read_key_elem inch =
+  try
+    Some (Marshal.from_channel inch)
+  with
+    | End_of_file -> None
+    |    _        -> raise InvalidTableFormat
+
+let open_in f =
+  let flags = [Open_rdonly;Open_binary;Open_creat] in
+  let inch = open_in_gen flags 0o666 f in
+  let htbl = Table.create 10 in
+
+  let rec xload () =
+    match read_key_elem inch with
+      | None -> ()
+      | Some (key,elem) ->
+	  Table.add htbl key elem ;
+	  xload () in
+
+    try
+      finally (fun () -> xload () ) (fun () -> close_in inch) ;
+      {
+	outch = begin
+	  let flags = [Open_append;Open_binary;Open_creat] in
+	    open_out_gen flags 0o666 f
+	end ;
+	status = Open ;
+	htbl = htbl
+      }
+    with InvalidTableFormat ->
+      (* Try to keep as many entries as possible *)
+      begin
+	let flags = [Open_wronly; Open_trunc;Open_binary;Open_creat] in
+	let outch = open_out_gen flags 0o666 f in
+	  Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl;
+	  { outch = outch ;
+	    status = Open ;
+	    htbl   = htbl
+	  }
+      end
+
+
+let close t =
+  let {outch = outch ; status = status ; htbl = tbl} = t in
+    match t.status with
+    | Closed -> () (* don't do it twice *)
+    | Open  ->
+	close_out outch ;
+	Table.clear tbl ;
+	t.status <- Closed
+
+let add t k e =
+  let {outch = outch ; status = status ; htbl = tbl} = t in
+    if status = Closed
+    then raise UnboundTable
+    else
+      begin
+	Table.add tbl k e ;
+	Marshal.to_channel outch (k,e) [Marshal.No_sharing]
+      end
+
+let find t k =
+  let {outch = outch ; status = status ; htbl = tbl} = t in
+    if status = Closed
+    then raise UnboundTable
+    else
+      let res = Table.find tbl k in
+	res
+
+let memo cache f =
+  let tbl = lazy (open_in cache) in
+    fun x ->
+      let tbl = Lazy.force tbl in
+	try
+	  find tbl x
+	with
+	    Not_found ->
+	      let res = f x in
+		add tbl x res ;
+		res
+
+end
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml
new file mode 100644
index 00000000..3029496b
--- /dev/null
+++ b/plugins/micromega/sos.ml
@@ -0,0 +1,1859 @@
+(* ========================================================================= *)
+(* - This code originates from John Harrison's HOL LIGHT 2.30                *)
+(*   (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       *)
+(* ========================================================================= *)
+
+(* ========================================================================= *)
+(* Nonlinear universal reals procedure using SOS decomposition.              *)
+(* ========================================================================= *)
+open Num;;
+open List;;
+open Sos_types;;
+open Sos_lib;;
+
+(*
+prioritize_real();;
+*)
+
+let debugging = ref false;;
+
+exception Sanity;;
+
+exception Unsolvable;;
+
+(* ------------------------------------------------------------------------- *)
+(* 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_dot (v1:vector) (v2:vector) =
+  let m = dim v1 and n = dim v2 in
+  if m <> n then failwith "vector_add: incompatible dimensions" else
+  foldl (fun a i x -> x +/ a) (Int 0)
+        (combine ( */ ) (fun x -> x =/ Int 0) (snd v1) (snd 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.                                                       *)
+(* ------------------------------------------------------------------------- *)
+
+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,[x]) -> h +/ x | (h,_) -> h) 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,[x]) -> h */ power_num (Int 10) x | (h,_) -> h);;
+
+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_sdpaoutput,parse_csdpoutput =
+  let vector =
+    token "{" ++ listof decimal (token ",") "decimal" ++ token "}"
+               >> (fun ((_,v),_) -> vector_of_list v) in
+  let rec skipupto dscr prs inp =
+      (dscr ++ prs >> snd
+    || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in
+  let ignore inp = (),[] in
+  let sdpaoutput =
+    skipupto (word "xVec" ++ token "=")
+             (vector ++ ignore >> fst) in
+  let csdpoutput =
+    (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++
+    (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in
+  mkparser sdpaoutput,mkparser csdpoutput;;
+
+(* ------------------------------------------------------------------------- *)
+(* Also parse the SDPA output to test success (CSDP yields a return code).   *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_run_succeeded =
+   let rec skipupto dscr prs inp =
+      (dscr ++ prs >> snd
+    || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in
+  let prs = skipupto (word "phase.value" ++ token "=")
+                     (possibly (a "p") ++ possibly (a "d") ++
+                      (word "OPT" || word "FEAS")) in
+  fun s -> try ignore (prs (explode s)); true with Noparse -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* The default parameters. Unfortunately this goes to a fixed file.          *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_default_parameters =
+"100     unsigned int maxIteration;
+1.0E-7  double 0.0 < epsilonStar;
+1.0E2   double 0.0 < lambdaStar;
+2.0     double 1.0 < omegaStar;
+-1.0E5  double lowerBound;
+1.0E5   double upperBound;
+0.1     double 0.0 <= betaStar <  1.0;
+0.2     double 0.0 <= betaBar  <  1.0, betaStar <= betaBar;
+0.9     double 0.0 < gammaStar  <  1.0;
+1.0E-7  double 0.0 < epsilonDash;
+";;
+
+(* ------------------------------------------------------------------------- *)
+(* These were suggested by Makoto Yamashita for problems where we are        *)
+(* right at the edge of the semidefinite cone, as sometimes happens.         *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_alt_parameters =
+"1000    unsigned int maxIteration;
+1.0E-7  double 0.0 < epsilonStar;
+1.0E4   double 0.0 < lambdaStar;
+2.0     double 1.0 < omegaStar;
+-1.0E5  double lowerBound;
+1.0E5   double upperBound;
+0.1     double 0.0 <= betaStar <  1.0;
+0.2     double 0.0 <= betaBar  <  1.0, betaStar <= betaBar;
+0.9     double 0.0 < gammaStar  <  1.0;
+1.0E-7  double 0.0 < epsilonDash;
+";;
+
+let sdpa_params = sdpa_alt_parameters;;
+
+(* ------------------------------------------------------------------------- *)
+(* 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;;
+
+(* ------------------------------------------------------------------------- *)
+(* Now call CSDP on a problem and parse back the output.                     *)
+(* ------------------------------------------------------------------------- *)
+
+let run_csdp dbg obj mats =
+  let input_file = Filename.temp_file "sos" ".dat-s" in
+  let output_file =
+    String.sub input_file 0 (String.length input_file - 6) ^ ".out"
+  and params_file = Filename.concat (!temp_path) "param.csdp" in
+  file_of_string input_file (sdpa_of_problem "" obj mats);
+  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
+  let op = string_of_file output_file in
+  let res = parse_csdpoutput op in
+  ((if dbg then ()
+    else (Sys.remove input_file; Sys.remove output_file));
+    rv,res);;
+
+let csdp obj mats =
+  let rv,res = run_csdp (!debugging) obj mats in
+  (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible"
+   else if rv = 3 then ()
+    (* Format.print_string "csdp warning: Reduced accuracy";
+     Format.print_newline() *)
+   else if rv <> 0 then failwith("csdp: error "^string_of_int rv)
+   else ());
+  res;;
+
+(* ------------------------------------------------------------------------- *)
+(* 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
+  let rv,res = run_csdp false obj mats in
+  if rv = 1 or rv = 2 then false
+  else if rv = 0 then true
+  else failwith "linear_program: An error occurred in the SDP solver";;
+
+(* ------------------------------------------------------------------------- *)
+(* Alternative interface testing A x >= b for matrix A, vector b.            *)
+(* ------------------------------------------------------------------------- *)
+
+let linear_program a b =
+  let m,n = dimensions a in
+  if dim b <> m then failwith "linear_program: incompatible dimensions" else
+  let mats = diagonal b :: map (fun j -> diagonal (column j a)) (1--n)
+  and obj = vector_const (Int 1) m in
+  let rv,res = run_csdp false obj mats in
+  if rv = 1 or rv = 2 then false
+  else if rv = 0 then true
+  else failwith "linear_program: An error occurred in the SDP solver";;
+
+(* ------------------------------------------------------------------------- *)
+(* 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
+    | [] -> assert false
+    | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] 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 failstore = ref [];;
+
+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 (failstore := [vars,dun,eqs]; 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 = epoly_cmul (Int(-1));;
+
+let epoly_add = combine equation_add is_undefined;;
+
+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 run_csdp dbg nblocks blocksizes obj mats =
+  let input_file = Filename.temp_file "sos" ".dat-s" in
+  let output_file =
+    String.sub input_file 0 (String.length input_file - 6) ^ ".out"
+  and params_file = Filename.concat (!temp_path) "param.csdp" in
+  file_of_string input_file
+   (sdpa_of_blockproblem "" nblocks blocksizes obj mats);
+  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
+  let op = string_of_file output_file in
+  let res = parse_csdpoutput op in
+  ((if dbg then ()
+    else (Sys.remove input_file; Sys.remove output_file));
+    rv,res);;
+
+let csdp nblocks blocksizes obj mats =
+  let rv,res = run_csdp (!debugging) nblocks blocksizes obj mats in
+  (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible"
+   else if rv = 3 then ()
+    (*Format.print_string "csdp warning: Reduced accuracy";
+     Format.print_newline() *)
+   else if rv <> 0 then failwith("csdp: error "^string_of_int rv)
+   else ());
+  res;;
+
+(* ------------------------------------------------------------------------- *)
+(* 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
+        (((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 =
+  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 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;;
+
+(* ------------------------------------------------------------------------- *)
+(* Iterative deepening.                                                      *)
+(* ------------------------------------------------------------------------- *)
+
+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);;
+
+(* ------------------------------------------------------------------------- *)
+(* The ordering so we can create canonical HOL polynomials.                  *)
+(* ------------------------------------------------------------------------- *)
+
+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 HOL.                         *)
+(* ------------------------------------------------------------------------- *)
+
+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));;
+
+(* ------------------------------------------------------------------------- *)
+(* Interface to HOL.                                                         *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_NONLINEAR_PROVER translator (eqs,les,lts) =
+  let eq0 = map (poly_of_term o lhand o concl) eqs
+  and le0 = map (poly_of_term o lhand o concl) les
+  and lt0 = map (poly_of_term o lhand o concl) lts in
+  let eqp0 = map (fun (t,i) -> t,Axiom_eq i) (zip eq0 (0--(length eq0 - 1)))
+  and lep0 = map (fun (t,i) -> t,Axiom_le i) (zip le0 (0--(length le0 - 1)))
+  and ltp0 = map (fun (t,i) -> t,Axiom_lt i) (zip lt0 (0--(length lt0 - 1))) in
+  let keq,eq = partition (fun (p,_) -> multidegree p = 0) eqp0
+  and klep,lep = partition (fun (p,_) -> multidegree p = 0) lep0
+  and kltp,ltp = partition (fun (p,_) -> multidegree p = 0) ltp0 in
+  let trivial_axiom (p,ax) =
+    match ax with
+      Axiom_eq n when eval undefined p <>/ num_0 -> el n eqs
+    | Axiom_le n when eval undefined p </ num_0 -> el n les
+    | Axiom_lt n when eval undefined p <=/ num_0 -> el n lts
+    | _ -> failwith "not a trivial axiom" in
+  try let th = tryfind trivial_axiom (keq @ klep @ kltp) in
+      CONV_RULE (LAND_CONV REAL_POLY_CONV THENC REAL_RAT_RED_CONV) th
+  with Failure _ ->
+  let pol = itlist poly_mul (map fst ltp) (poly_const num_1) in
+  let leq = lep @ ltp in
+  let tryall d =
+    let e = multidegree pol in
+    let k = if e = 0 then 0 else d / e in
+    let eq' = map fst eq 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 tryall 0 in
+  let proofs_ideal =
+    map2 (fun q (p,ax) -> Eqmul(term_of_poly q,ax)) cert_ideal eq
+  and proofs_cone = map term_of_sos cert_cone
+  and proof_ne =
+    if ltp = [] 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
+  let proof = end_itlist (fun s t -> Sum(s,t))
+                         (proof_ne :: proofs_ideal @ proofs_cone) in
+  print_string("Translating proof certificate to HOL");
+  print_newline();
+  translator (eqs,les,lts) proof;;
+*)
+(* ------------------------------------------------------------------------- *)
+(* A wrapper that tries to substitute away variables first.                  *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_NONLINEAR_SUBST_PROVER =
+  let zero = `&0:real`
+  and mul_tm = `( * ):real->real->real`
+  and shuffle1 =
+    CONV_RULE(REWR_CONV(REAL_ARITH `a + x = (y:real) <=> x = y - a`))
+  and shuffle2 =
+    CONV_RULE(REWR_CONV(REAL_ARITH `x + a = (y:real) <=> x = y - a`)) in
+  let rec substitutable_monomial fvs tm =
+    match tm with
+      Var(_,Tyapp("real",[])) when not (mem tm fvs) -> Int 1,tm
+    | Comb(Comb(Const("real_mul",_),c),(Var(_,_) as t))
+         when is_ratconst c & not (mem t fvs)
+          -> rat_of_term c,t
+    | Comb(Comb(Const("real_add",_),s),t) ->
+         (try substitutable_monomial (union (frees t) fvs) s
+          with Failure _ -> substitutable_monomial (union (frees s) fvs) t)
+    | _ -> failwith "substitutable_monomial"
+  and isolate_variable v th =
+    match lhs(concl th) with
+      x when x = v -> th
+    | Comb(Comb(Const("real_add",_),(Var(_,Tyapp("real",[])) as x)),t)
+        when x = v -> shuffle2 th
+    | Comb(Comb(Const("real_add",_),s),t) ->
+        isolate_variable v(shuffle1 th) in
+  let make_substitution th =
+    let (c,v) = substitutable_monomial [] (lhs(concl th)) in
+    let th1 = AP_TERM (mk_comb(mul_tm,term_of_rat(Int 1 // c))) th in
+    let th2 = CONV_RULE(BINOP_CONV REAL_POLY_MUL_CONV) th1 in
+    CONV_RULE (RAND_CONV REAL_POLY_CONV) (isolate_variable v th2) in
+  fun translator ->
+    let rec substfirst(eqs,les,lts) =
+      try let eth = tryfind make_substitution eqs in
+          let modify =
+            CONV_RULE(LAND_CONV(SUBS_CONV[eth] THENC REAL_POLY_CONV)) in
+          substfirst(filter (fun t -> lhand(concl t) <> zero) (map modify eqs),
+                     map modify les,map modify lts)
+      with Failure _ -> REAL_NONLINEAR_PROVER translator (eqs,les,lts) in
+    substfirst;;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Overall function.                                                         *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_SOS =
+  let init = GEN_REWRITE_CONV ONCE_DEPTH_CONV [DECIMAL]
+  and pure = GEN_REAL_ARITH REAL_NONLINEAR_SUBST_PROVER in
+  fun tm -> let th = init tm in EQ_MP (SYM th) (pure(rand(concl th)));;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Add hacks for division.                                                   *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_SOSFIELD =
+  let inv_tm = `inv:real->real` in
+  let prenex_conv =
+    TOP_DEPTH_CONV BETA_CONV THENC
+    PURE_REWRITE_CONV[FORALL_SIMP; EXISTS_SIMP; real_div;
+                      REAL_INV_INV; REAL_INV_MUL; GSYM REAL_POW_INV] THENC
+    NNFC_CONV THENC DEPTH_BINOP_CONV `(/\)` CONDS_CELIM_CONV THENC
+    PRENEX_CONV
+  and setup_conv = NNF_CONV THENC WEAK_CNF_CONV THENC CONJ_CANON_CONV
+  and core_rule t =
+    try REAL_ARITH t
+    with Failure _ -> try REAL_RING t
+    with Failure _ -> REAL_SOS t
+  and is_inv =
+    let is_div = is_binop `(/):real->real->real` in
+    fun tm -> (is_div tm or (is_comb tm & rator tm = inv_tm)) &
+              not(is_ratconst(rand tm)) in
+  let BASIC_REAL_FIELD tm =
+    let is_freeinv t = is_inv t & free_in t tm in
+    let itms = setify(map rand (find_terms is_freeinv tm)) in
+    let hyps = map (fun t -> SPEC t REAL_MUL_RINV) itms in
+    let tm' = itlist (fun th t -> mk_imp(concl th,t)) hyps tm in
+    let itms' = map (curry mk_comb inv_tm) itms in
+    let gvs = map (genvar o type_of) itms' in
+    let tm'' = subst (zip gvs itms') tm' in
+    let th1 = setup_conv tm'' in
+    let cjs = conjuncts(rand(concl th1)) in
+    let ths = map core_rule cjs in
+    let th2 = EQ_MP (SYM th1) (end_itlist CONJ ths) in
+    rev_itlist (C MP) hyps (INST (zip itms' gvs) th2) in
+  fun tm ->
+    let th0 = prenex_conv tm in
+    let tm0 = rand(concl th0) in
+    let avs,bod = strip_forall tm0 in
+    let th1 = setup_conv bod in
+    let ths = map BASIC_REAL_FIELD (conjuncts(rand(concl th1))) in
+    EQ_MP (SYM th0) (GENL avs (EQ_MP (SYM th1) (end_itlist CONJ ths)));;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Integer version.                                                          *)
+(* ------------------------------------------------------------------------- *)
+(*
+let INT_SOS =
+  let atom_CONV =
+    let pth = prove
+      (`(~(x <= y) <=> y + &1 <= x:int) /\
+        (~(x < y) <=> y <= x) /\
+        (~(x = y) <=> x + &1 <= y \/ y + &1 <= x) /\
+        (x < y <=> x + &1 <= y)`,
+       REWRITE_TAC[INT_NOT_LE; INT_NOT_LT; INT_NOT_EQ; INT_LT_DISCRETE]) in
+    GEN_REWRITE_CONV I [pth]
+  and bub_CONV = GEN_REWRITE_CONV TOP_SWEEP_CONV
+   [int_eq; int_le; int_lt; int_ge; int_gt;
+    int_of_num_th; int_neg_th; int_add_th; int_mul_th;
+    int_sub_th; int_pow_th; int_abs_th; int_max_th; int_min_th] in
+  let base_CONV = TRY_CONV atom_CONV THENC bub_CONV in
+  let NNF_NORM_CONV = GEN_NNF_CONV false
+   (base_CONV,fun t -> base_CONV t,base_CONV(mk_neg t)) in
+  let init_CONV =
+    GEN_REWRITE_CONV DEPTH_CONV [FORALL_SIMP; EXISTS_SIMP] THENC
+    GEN_REWRITE_CONV DEPTH_CONV [INT_GT; INT_GE] THENC
+    CONDS_ELIM_CONV THENC NNF_NORM_CONV in
+  let p_tm = `p:bool`
+  and not_tm = `(~)` in
+  let pth = TAUT(mk_eq(mk_neg(mk_neg p_tm),p_tm)) in
+  fun tm ->
+    let th0 = INST [tm,p_tm] pth
+    and th1 = NNF_NORM_CONV(mk_neg tm) in
+    let th2 = REAL_SOS(mk_neg(rand(concl th1))) in
+    EQ_MP th0 (EQ_MP (AP_TERM not_tm (SYM th1)) th2);;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Natural number version.                                                   *)
+(* ------------------------------------------------------------------------- *)
+(*
+let SOS_RULE tm =
+  let avs = frees tm in
+  let tm' = list_mk_forall(avs,tm) in
+  let th1 = NUM_TO_INT_CONV tm' in
+  let th2 = INT_SOS (rand(concl th1)) in
+  SPECL avs (EQ_MP (SYM th1) th2);;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Now pure SOS stuff.                                                       *)
+(* ------------------------------------------------------------------------- *)
+
+(*prioritize_real();;*)
+
+(* ------------------------------------------------------------------------- *)
+(* 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;;
+
+(* ------------------------------------------------------------------------- *)
+(* Return to original non-block matrices.                                    *)
+(* ------------------------------------------------------------------------- *)
+
+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";;
+
+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 "";;
+
+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 "";;
+
+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 "";;
+
+let run_csdp dbg obj mats =
+  let input_file = Filename.temp_file "sos" ".dat-s" in
+  let output_file =
+    String.sub input_file 0 (String.length input_file - 6) ^ ".out"
+  and params_file = Filename.concat (!temp_path) "param.csdp" in
+  file_of_string input_file (sdpa_of_problem "" obj mats);
+  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
+  let op = string_of_file output_file in
+  let res = parse_csdpoutput op in
+  ((if dbg then ()
+    else (Sys.remove input_file; Sys.remove output_file));
+    rv,res);;
+
+let csdp obj mats =
+  let rv,res = run_csdp (!debugging) obj mats in
+  (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible"
+    else if rv = 3 then ()
+(*    (Format.print_string "csdp warning: Reduced accuracy";
+     Format.print_newline()) *)
+   else if rv <> 0 then failwith("csdp: error "^string_of_int rv)
+   else ());
+  res;;
+
+(* ------------------------------------------------------------------------- *)
+(* 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 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 = sumofsquares_general_symmetry csdp;;
+
+(* ------------------------------------------------------------------------- *)
+(* Pure HOL SOS conversion.                                                  *)
+(* ------------------------------------------------------------------------- *)
+(*
+let SOS_CONV =
+  let mk_square =
+    let pow_tm = `(pow)` and two_tm = `2` in
+    fun tm -> mk_comb(mk_comb(pow_tm,tm),two_tm)
+  and mk_prod = mk_binop `( * )`
+  and mk_sum = mk_binop `(+)` in
+  fun tm ->
+    let k,sos = sumofsquares(poly_of_term tm) in
+    let mk_sqtm(c,p) =
+      mk_prod (term_of_rat(k */ c)) (mk_square(term_of_poly p)) in
+    let tm' = end_itlist mk_sum (map mk_sqtm sos) in
+    let th = REAL_POLY_CONV tm and th' = REAL_POLY_CONV tm' in
+    TRANS th (SYM th');;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Attempt to prove &0 <= x by direct SOS decomposition.                     *)
+(* ------------------------------------------------------------------------- *)
+(*
+let PURE_SOS_TAC =
+  let tac =
+    MATCH_ACCEPT_TAC(REWRITE_RULE[GSYM REAL_POW_2] REAL_LE_SQUARE) ORELSE
+    MATCH_ACCEPT_TAC REAL_LE_SQUARE ORELSE
+    (MATCH_MP_TAC REAL_LE_ADD THEN CONJ_TAC) ORELSE
+    (MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC) ORELSE
+    CONV_TAC(RAND_CONV REAL_RAT_REDUCE_CONV THENC REAL_RAT_LE_CONV) in
+  REPEAT GEN_TAC THEN REWRITE_TAC[real_ge] THEN
+  GEN_REWRITE_TAC I [GSYM REAL_SUB_LE] THEN
+  CONV_TAC(RAND_CONV SOS_CONV) THEN
+  REPEAT tac THEN NO_TAC;;
+
+let PURE_SOS tm = prove(tm,PURE_SOS_TAC);;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Examples.                                                                 *)
+(* ------------------------------------------------------------------------- *)
+
+(*****
+
+time REAL_SOS
+  `a1 >= &0 /\ a2 >= &0 /\
+   (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + &2) /\
+   (a1 * b1 + a2 * b2 = &0)
+   ==> a1 * a2 - b1 * b2 >= &0`;;
+
+time REAL_SOS `&3 * x + &7 * a < &4 /\ &3 < &2 * x ==> a < &0`;;
+
+time REAL_SOS
+  `b pow 2 < &4 * a * c ==> ~(a * x pow 2 + b * x + c = &0)`;;
+
+time REAL_SOS
+  `(a * x pow 2 + b * x + c = &0) ==> b pow 2 >= &4 * a * c`;;
+
+time REAL_SOS
+ `&0 <= x /\ x <= &1 /\ &0 <= y /\ y <= &1
+  ==> x pow 2 + y pow 2 < &1 \/
+      (x - &1) pow 2 + y pow 2 < &1 \/
+      x pow 2 + (y - &1) pow 2 < &1 \/
+      (x - &1) pow 2 + (y - &1) pow 2 < &1`;;
+
+time REAL_SOS
+ `&0 <= b /\ &0 <= c /\ &0 <= x /\ &0 <= y /\
+  (x pow 2 = c) /\ (y pow 2 = a pow 2 * c + b)
+  ==> a * c <= y * x`;;
+
+time REAL_SOS
+ `&0 <= x /\ &0 <= y /\ &0 <= z /\ x + y + z <= &3
+  ==> x * y + x * z + y * z >= &3 * x * y * z`;;
+
+time REAL_SOS
+ `(x pow 2 + y pow 2 + z pow 2 = &1) ==> (x + y + z) pow 2 <= &3`;;
+
+time REAL_SOS
+ `(w pow 2 + x pow 2 + y pow 2 + z pow 2 = &1)
+  ==> (w + x + y + z) pow 2 <= &4`;;
+
+time REAL_SOS
+ `x >= &1 /\ y >= &1 ==> x * y >= x + y - &1`;;
+
+time REAL_SOS
+ `x > &1 /\ y > &1 ==> x * y > x + y - &1`;;
+
+time REAL_SOS
+ `abs(x) <= &1
+  ==> abs(&64 * x pow 7 - &112 * x pow 5 + &56 * x pow 3 - &7 * x) <= &1`;;
+
+time REAL_SOS
+ `abs(x - z) <= e /\ abs(y - z) <= e /\ &0 <= u /\ &0 <= v /\ (u + v = &1)
+  ==> abs((u * x + v * y) - z) <= e`;;
+
+(* ------------------------------------------------------------------------- *)
+(* One component of denominator in dodecahedral example.                     *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+  `&2 <= x /\ x <= &125841 / &50000 /\
+   &2 <= y /\ y <= &125841 / &50000 /\
+   &2 <= z /\ z <= &125841 / &50000
+   ==> &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= &0`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Over a larger but simpler interval.                                       *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+ `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4
+  ==> &0 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* We can do 12. I think 12 is a sharp bound; see PP's certificate.          *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+ `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4
+  ==> &12 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Gloptipoly example.                                                       *)
+(* ------------------------------------------------------------------------- *)
+
+(*** This works but normalization takes minutes
+
+time REAL_SOS
+ `(x - y - &2 * x pow 4 = &0) /\ &0 <= x /\ x <= &2 /\ &0 <= y /\ y <= &3
+  ==> y pow 2 - &7 * y - &12 * x + &17 >= &0`;;
+
+ ***)
+
+(* ------------------------------------------------------------------------- *)
+(* Inequality from sci.math (see "Leon-Sotelo, por favor").                  *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+  `&0 <= x /\ &0 <= y /\ (x * y = &1)
+   ==> x + y <= x pow 2 + y pow 2`;;
+
+time REAL_SOS
+  `&0 <= x /\ &0 <= y /\ (x * y = &1)
+   ==> x * y * (x + y) <= x pow 2 + y pow 2`;;
+
+time REAL_SOS
+  `&0 <= x /\ &0 <= y ==> x * y * (x + y) pow 2 <= (x pow 2 + y pow 2) pow 2`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Some examples over integers and natural numbers.                          *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE `!m n. 2 * m + n = (n + m) + m`;;
+time SOS_RULE `!n. ~(n = 0) ==> (0 MOD n = 0)`;;
+time SOS_RULE  `!m n. m < n ==> (m DIV n = 0)`;;
+time SOS_RULE `!n:num. n <= n * n`;;
+time SOS_RULE  `!m n. n * (m DIV n) <= m`;;
+time SOS_RULE `!n. ~(n = 0) ==> (0 DIV n = 0)`;;
+time SOS_RULE `!m n p. ~(p = 0) /\ m <= n ==> m DIV p <= n DIV p`;;
+time SOS_RULE `!a b n. ~(a = 0) ==> (n <= b DIV a <=> a * n <= b)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* This is particularly gratifying --- cf hideous manual proof in arith.ml   *)
+(* ------------------------------------------------------------------------- *)
+
+(*** This doesn't now seem to work as well as it did; what changed?
+
+time SOS_RULE
+ `!a b c d. ~(b = 0) /\ b * c < (a + 1) * d ==> c DIV d <= a DIV b`;;
+
+ ***)
+
+(* ------------------------------------------------------------------------- *)
+(* Key lemma for injectivity of Cantor-type pairing functions.               *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE
+ `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1)
+                ==> (x1 + y1 = x2 + y2)`;;
+
+time SOS_RULE
+ `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) /\
+                (x1 + y1 = x2 + y2)
+                ==> (x1 = x2) /\ (y1 = y2)`;;
+
+time SOS_RULE
+ `!x1 y1 x2 y2.
+      (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 =
+       ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2)
+       ==> (x1 + y1 = x2 + y2)`;;
+
+time SOS_RULE
+ `!x1 y1 x2 y2.
+      (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 =
+       ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) /\
+      (x1 + y1 = x2 + y2)
+      ==> (x1 = x2) /\ (y1 = y2)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Reciprocal multiplication (actually just ARITH_RULE does these).          *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE `x <= 127 ==> ((86 * x) DIV 256 = x DIV 3)`;;
+
+time SOS_RULE `x < 2 EXP 16 ==> ((104858 * x) DIV (2 EXP 20) = x DIV 10)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* This is more impressive since it's really nonlinear. See REMAINDER_DECODE *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE `0 < m /\ m < n  ==> ((m * ((n * x) DIV m + 1)) DIV n = x)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Some conversion examples.                                                 *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_CONV
+ `&2 * x pow 4 + &2 * x pow 3 * y - x pow 2 * y pow 2 + &5 * y pow 4`;;
+
+time SOS_CONV
+ `x pow 4 - (&2 * y * z + &1) * x pow 2 +
+  (y pow 2 * z pow 2 + &2 * y * z + &2)`;;
+
+time SOS_CONV `&4 * x pow 4 +
+          &4 * x pow 3 * y - &7 * x pow 2 * y pow 2 - &2 * x * y pow 3 +
+          &10 * y pow 4`;;
+
+time SOS_CONV `&4 * x pow 4 * y pow 6 + x pow 2 - x * y pow 2 + y pow 2`;;
+
+time SOS_CONV
+  `&4096 * (x pow 4 + x pow 2 + z pow 6 - &3 * x pow 2 * z pow 2) + &729`;;
+
+time SOS_CONV
+ `&120 * x pow 2 - &63 * x pow 4 + &10 * x pow 6 +
+  &30 * x * y - &120 * y pow 2 + &120 * y pow 4 + &31`;;
+
+time SOS_CONV
+ `&9 * x pow 2 * y pow 4 + &9 * x pow 2 * z pow 4 + &36 * x pow 2 * y pow 3 +
+  &36 * x pow 2 * y pow 2 - &48 * x * y * z pow 2 + &4 * y pow 4 +
+  &4 * z pow 4 - &16 * y pow 3 + &16 * y pow 2`;;
+
+time SOS_CONV
+ `(x pow 2 + y pow 2 + z pow 2) *
+  (x pow 4 * y pow 2 + x pow 2 * y pow 4 +
+   z pow 6 - &3 * x pow 2 * y pow 2 *   z pow 2)`;;
+
+time SOS_CONV
+ `x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3`;;
+
+(*** I think this will work, but normalization is slow
+
+time SOS_CONV
+ `&100 * (x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z) + &212`;;
+
+ ***)
+
+time SOS_CONV
+ `&100 * ((&2 * x - &2) pow 2 + (x pow 3 - &8 * x - &2) pow 2) - &588`;;
+
+time SOS_CONV
+ `x pow 2 * (&120 - &63 * x pow 2 + &10 * x pow 4) + &30 * x * y +
+    &30 * y pow 2 * (&4 * y pow 2 - &4) + &31`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Example of basic rule.                                                    *)
+(* ------------------------------------------------------------------------- *)
+
+time PURE_SOS
+  `!x. x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3
+       >= &1 / &7`;;
+
+time PURE_SOS
+ `&0 <= &98 * x pow 12 +
+        -- &980 * x pow 10 +
+        &3038 * x pow 8 +
+        -- &2968 * x pow 6 +
+        &1022 * x pow 4 +
+        -- &84 * x pow 2 +
+        &2`;;
+
+time PURE_SOS
+ `!x. &0 <= &2 * x pow 14 +
+            -- &84 * x pow 12 +
+            &1022 * x pow 10 +
+            -- &2968 * x pow 8 +
+            &3038 * x pow 6 +
+            -- &980 * x pow 4 +
+            &98 * x pow 2`;;
+
+(* ------------------------------------------------------------------------- *)
+(* From Zeng et al, JSC vol 37 (2004), p83-99.                               *)
+(* All of them work nicely with pure SOS_CONV, except (maybe) the one noted. *)
+(* ------------------------------------------------------------------------- *)
+
+PURE_SOS
+  `x pow 6 + y pow 6 + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2 >= &0`;;
+
+PURE_SOS `x pow 4 + y pow 4 + z pow 4 + &1 - &4*x*y*z >= &0`;;
+
+PURE_SOS `x pow 4 + &2*x pow 2*z + x pow 2 - &2*x*y*z + &2*y pow 2*z pow 2 +
+&2*y*z pow 2 + &2*z pow 2 - &2*x + &2* y*z + &1 >= &0`;;
+
+(**** This is harder. Interestingly, this fails the pure SOS test, it seems.
+      Yet only on rounding(!?) Poor Newton polytope optimization or something?
+      But REAL_SOS does finally converge on the second run at level 12!
+
+REAL_SOS
+`x pow 4*y pow 4 - &2*x pow 5*y pow 3*z pow 2 + x pow 6*y pow 2*z pow 4 + &2*x
+pow 2*y pow 3*z - &4* x pow 3*y pow 2*z pow 3 + &2*x pow 4*y*z pow 5 + z pow
+2*y pow 2 - &2*z pow 4*y*x + z pow 6*x pow 2 >= &0`;;
+
+ ****)
+
+PURE_SOS
+`x pow 4 + &4*x pow 2*y pow 2 + &2*x*y*z pow 2 + &2*x*y*w pow 2 + y pow 4 + z
+pow 4 + w pow 4 + &2*z pow 2*w pow 2 + &2*x pow 2*w + &2*y pow 2*w + &2*x*y +
+&3*w pow 2 + &2*z pow 2 + &1 >= &0`;;
+
+PURE_SOS
+`w pow 6 + &2*z pow 2*w pow 3 + x pow 4 + y pow 4 + z pow 4 + &2*x pow 2*w +
+&2*x pow 2*z + &3*x pow 2 + w pow 2 + &2*z*w + z pow 2 + &2*z + &2*w + &1 >=
+&0`;;
+
+*****)
diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli
new file mode 100644
index 00000000..e38caba0
--- /dev/null
+++ b/plugins/micromega/sos.mli
@@ -0,0 +1,36 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Sos_types
+
+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
+
+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/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml
new file mode 100644
index 00000000..baf90d4d
--- /dev/null
+++ b/plugins/micromega/sos_lib.ml
@@ -0,0 +1,621 @@
+(* ========================================================================= *)
+(* - This code originates from John Harrison's HOL LIGHT 2.30                *)
+(*   (see file LICENSE.sos for license, copyright and disclaimer)            *)
+(*   This code is the HOL LIGHT library code used by sos.ml                  *)
+(* - 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       *)
+(* ========================================================================= *)
+open Sos_types
+open Num
+open List
+
+let debugging = ref false;;
+
+(* ------------------------------------------------------------------------- *)
+(* 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);;
+
+
+
+(* ------------------------------------------------------------------------- *)
+(* 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);;
+
+(* ------------------------------------------------------------------------- *)
+(* 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 temp_path = ref Filename.temp_dir_name;;
+
+(* ------------------------------------------------------------------------- *)
+(* Convenient conversion between files and (lists of) strings.               *)
+(* ------------------------------------------------------------------------- *)
+
+let strings_of_file filename =
+  let fd = try Pervasives.open_in filename
+           with Sys_error _ ->
+             failwith("strings_of_file: can't open "^filename) in
+  let rec suck_lines acc =
+    try let l = Pervasives.input_line fd in
+        suck_lines (l::acc)
+    with End_of_file -> rev acc in
+  let data = suck_lines [] in
+  (Pervasives.close_in fd; data);;
+
+let string_of_file filename =
+  end_itlist (fun s t -> s^"\n"^t) (strings_of_file filename);;
+
+let file_of_string filename s =
+  let fd = Pervasives.open_out filename in
+  output_string fd s; close_out fd;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Iterative deepening.                                                      *)
+(* ------------------------------------------------------------------------- *)
+
+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
diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml
new file mode 100644
index 00000000..fe481ecc
--- /dev/null
+++ b/plugins/micromega/sos_types.ml
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* The type of positivstellensatz -- used to communicate with sos *)
+open Num
+
+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);;
+
+
+let rec output_term o t =
+  match t with
+    | Zero -> output_string o "0"
+    | Const n -> output_string o (string_of_num n)
+    | Var n   -> Printf.fprintf o "v%s" n
+    | Inv t   -> Printf.fprintf o "1/(%a)" output_term t
+    | Opp t    -> Printf.fprintf o "- (%a)" output_term t
+    | Add(t1,t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2
+    | Sub(t1,t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2
+    | Mul(t1,t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2
+    | Div(t1,t2) -> Printf.fprintf o "(%a)/(%a)" output_term t1 output_term t2
+    | Pow(t1,i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i
+(* ------------------------------------------------------------------------- *)
+(* 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;;
+
+
+let rec output_psatz o = function
+  | Axiom_eq i -> Printf.fprintf o "Aeq(%i)" i
+  | Axiom_le i -> Printf.fprintf o "Ale(%i)" i
+  | Axiom_lt i -> Printf.fprintf o "Alt(%i)" i
+  | Rational_eq  n -> Printf.fprintf o "eq(%s)" (string_of_num n)
+  | Rational_le  n -> Printf.fprintf o "le(%s)" (string_of_num n)
+  | Rational_lt n  ->  Printf.fprintf o "lt(%s)" (string_of_num n)
+  | Square t       -> Printf.fprintf o "(%a)^2" output_term t
+  | Monoid l       -> Printf.fprintf o "monoid"
+  | Eqmul (t,ps)   -> Printf.fprintf o "%a * %a" output_term t output_psatz ps
+  | Sum (t1,t2)    -> Printf.fprintf o "%a + %a" output_psatz t1 output_psatz t2
+  | Product (t1,t2)    -> Printf.fprintf o "%a * %a" output_psatz t1 output_psatz t2
diff --git a/plugins/micromega/vo.itarget b/plugins/micromega/vo.itarget
new file mode 100644
index 00000000..30201308
--- /dev/null
+++ b/plugins/micromega/vo.itarget
@@ -0,0 +1,13 @@
+CheckerMaker.vo
+EnvRing.vo
+Env.vo
+OrderedRing.vo
+Psatz.vo
+QMicromega.vo
+Refl.vo
+RingMicromega.vo
+RMicromega.vo
+Tauto.vo
+VarMap.vo
+ZCoeff.vo
+ZMicromega.vo
diff --git a/plugins/nsatz/NsatzR.v b/plugins/nsatz/NsatzR.v
new file mode 100644
index 00000000..c68c9584
--- /dev/null
+++ b/plugins/nsatz/NsatzR.v
@@ -0,0 +1,407 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*
+ Tactic nsatz: proofs of polynomials equalities with variables in R.
+ Uses Hilbert Nullstellensatz and Buchberger algorithm.
+ Thanks to B.Gregoire and L.Thery for help on ring tactic,
+ and to B.Barras for modularization of the ocaml code.
+ Example: see test-suite/success/Nsatz.v
+ L.Pottier, june 2010
+*)
+
+Require Import List.
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinList.
+Require Import Znumtheory.
+Require Import RealField Rdefinitions Rfunctions RIneq DiscrR.
+Require Import Ring_polynom Ring_tac InitialRing.
+
+Declare ML Module "nsatz_plugin".
+
+Local Open Scope R_scope.
+
+Lemma psos_r1b: forall x y, x - y = 0 -> x = y.
+intros x y H; replace x with ((x - y) + y);
+  [rewrite H | idtac]; ring.
+Qed.
+
+Lemma psos_r1: forall x y, x = y -> x - y = 0.
+intros x y H; rewrite H; ring.
+Qed.
+
+Lemma nsatzR_not1: forall x y:R, x<>y -> exists z:R, z*(x-y)-1=0.
+intros.
+exists (1/(x-y)).
+field.
+unfold not.
+unfold not in H.
+intros.
+apply H.
+replace x with ((x-y)+y).
+rewrite H0.
+ring.
+ring.
+Qed.
+
+Lemma nsatzR_not1_0: forall x:R, x<>0 -> exists z:R, z*x-1=0.
+intros.
+exists (1/(x)).
+field.
+auto.
+Qed.
+
+
+Ltac equalities_to_goal :=
+  lazymatch goal with
+  |  H: (@eq R ?x 0) |- _ => try revert H
+  |  H: (@eq R 0 ?x) |- _ =>
+          try generalize (sym_equal H); clear H
+  |  H: (@eq R ?x ?y) |- _ =>
+          try generalize (psos_r1 _ _ H); clear H
+   end.
+
+Lemma nsatzR_not2: 1<>0.
+auto with *.
+Qed.
+
+Lemma nsatzR_diff: forall x y:R, x<>y -> x-y<>0.
+intros.
+intro; apply H.
+replace x with (x-y+y) by ring.
+rewrite H0; ring.
+Qed.
+
+(* Removes x<>0 from hypothesis *)
+Ltac nsatzR_not_hyp:=
+ match goal with
+ | H: ?x<>?y |- _ =>
+  match y with
+   |0 =>
+     let H1:=fresh "Hnsatz" in
+     let y:=fresh "x" in
+     destruct (@nsatzR_not1_0 _ H) as (y,H1); clear H
+   |_ => generalize (@nsatzR_diff _ _ H); clear H; intro
+  end
+ end.
+
+Ltac nsatzR_not_goal :=
+ match goal with
+ | |- ?x<>?y :> R => red; intro; apply nsatzR_not2
+ | |- False       => apply nsatzR_not2
+ end.
+
+Ltac nsatzR_begin :=
+  intros;
+  repeat nsatzR_not_hyp;
+  try nsatzR_not_goal;
+  try apply psos_r1b;
+  repeat equalities_to_goal.
+
+(* code de Benjamin *)
+
+Definition PolZ := Pol Z.
+Definition PEZ := PExpr Z.
+
+Definition P0Z : PolZ := @P0 Z 0%Z.
+
+Definition PolZadd : PolZ -> PolZ -> PolZ :=
+  @Padd Z 0%Z Zplus Zeq_bool.
+
+Definition PolZmul : PolZ -> PolZ -> PolZ :=
+  @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool.
+
+Definition PolZeq := @Peq Z Zeq_bool.
+
+Definition norm :=
+  @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
+
+Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ :=
+ match la, lp with
+ | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp)
+ | _, _ => P0Z
+ end.
+
+Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) :=
+ match lla with
+ | List.nil => lp
+ | la::lla => compute_list lla ((mult_l la lp)::lp)
+ end.
+
+Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) :=
+ let (lla, lq) := certif in
+ let lp := List.map norm lpe in
+ PolZeq (norm qe) (mult_l lq (compute_list lla lp)).
+
+
+(* Correction *)
+Definition PhiR : list R -> PolZ -> R :=
+  (Pphi 0 Rplus Rmult (gen_phiZ 0 1 Rplus Rmult Ropp)).
+
+Definition PEevalR : list R -> PEZ -> R :=
+   PEeval 0 Rplus Rmult Rminus Ropp (gen_phiZ 0 1 Rplus Rmult Ropp)
+         Nnat.nat_of_N pow.
+
+Lemma P0Z_correct : forall l, PhiR l P0Z = 0.
+Proof. trivial. Qed.
+
+
+Lemma PolZadd_correct : forall P' P l,
+  PhiR l (PolZadd P P') = (PhiR l P + PhiR l P').
+Proof.
+ refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (F_R Rfield))
+           (gen_phiZ_morph Rset Rext (F_R Rfield))).
+Qed.
+
+Lemma PolZmul_correct : forall P P' l,
+  PhiR l (PolZmul P P') = (PhiR l P * PhiR l P').
+Proof.
+ refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext (F_R Rfield))
+           (gen_phiZ_morph Rset Rext (F_R Rfield))).
+Qed.
+
+Lemma norm_correct :
+  forall (l : list R) (pe : PEZ), PEevalR l pe = PhiR l (norm pe).
+Proof.
+ intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (F_R Rfield))
+           (gen_phiZ_morph Rset Rext (F_R Rfield)) R_power_theory) with (lmp:= List.nil).
+ compute;trivial.
+Qed.
+
+Lemma PolZeq_correct : forall P P' l,
+  PolZeq P P' = true ->
+  PhiR l P = PhiR l P'.
+Proof.
+ intros;apply
+   (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (F_R Rfield)));trivial.
+Qed.
+
+Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop :=
+  match l with
+  | List.nil => True
+  | a::l => Interp a = 0 /\ Cond0 A Interp l
+  end.
+
+Lemma mult_l_correct : forall l la lp,
+  Cond0 PolZ (PhiR l) lp ->
+  PhiR l (mult_l la lp) = 0.
+Proof.
+ induction la;simpl;intros;trivial.
+ destruct lp;trivial.
+ simpl in H;destruct H.
+ rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring | trivial].
+Qed.
+
+Lemma compute_list_correct : forall l lla lp,
+  Cond0 PolZ (PhiR l) lp ->
+  Cond0 PolZ (PhiR l) (compute_list lla lp).
+Proof.
+ induction lla;simpl;intros;trivial.
+ apply IHlla;simpl;split;trivial.
+ apply mult_l_correct;trivial.
+Qed.
+
+Lemma check_correct :
+  forall l lpe qe certif,
+    check lpe qe certif = true ->
+    Cond0 PEZ (PEevalR l) lpe ->
+    PEevalR l qe = 0.
+Proof.
+ unfold check;intros l lpe qe (lla, lq) H2 H1.
+ apply PolZeq_correct with (l:=l) in H2.
+ rewrite norm_correct, H2.
+ apply mult_l_correct.
+ apply compute_list_correct.
+ clear H2 lq lla qe;induction lpe;simpl;trivial.
+ simpl in H1;destruct H1.
+ rewrite <- norm_correct;auto.
+Qed.
+
+(* fin du code de Benjamin *)
+
+Lemma nsatzR_l3:forall c p r, ~c=0 -> c*p^r=0 -> p=0.
+intros.
+elim (Rmult_integral _ _ H0);intros.
+ absurd (c=0);auto.
+
+ clear H0; induction r; simpl in *.
+  contradict H1; discrR.
+
+  elim (Rmult_integral _ _ H1); auto.
+Qed.
+
+
+Ltac generalise_eq_hyps:=
+  repeat
+    (match goal with
+     |h : (?p = ?q)|- _ => revert h
+     end).
+
+Ltac lpol_goal t :=
+  match t with
+  | ?a = 0 -> ?b =>
+    let r:= lpol_goal b in
+    constr:(a::r)
+  | ?a = 0 => constr:(a::nil)
+ end.
+
+Fixpoint IPR p {struct p}: R :=
+  match p with
+    xH => 1
+  | xO xH => 1 + 1
+  | xO p1 => 2 * (IPR p1)
+  | xI xH => 1 + (1 + 1)
+  | xI p1 => 1 + 2 * (IPR p1)
+  end.
+
+Definition IZR1 z :=
+  match z with Z0 => 0
+             | Zpos p => IPR p
+             | Zneg p => -(IPR p)
+  end.
+
+Fixpoint interpret3 t fv {struct t}: R :=
+  match t with
+  | (PEadd t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 + v2)
+  | (PEmul t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 * v2)
+  | (PEsub t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 - v2)
+  | (PEopp t1) =>
+       let v1  := interpret3 t1 fv in (-v1)
+  | (PEpow t1 t2) =>
+       let v1  := interpret3 t1 fv in v1 ^(Nnat.nat_of_N t2)
+  | (PEc t1) => (IZR1 t1)
+  | (PEX n) => List.nth (pred (nat_of_P n)) fv 0
+  end.
+
+(* lp est incluse dans fv. La met en tete. *)
+
+Ltac parametres_en_tete fv lp :=
+    match fv with
+     | (@nil _)          => lp
+     | (@cons _ ?x ?fv1) =>
+       let res := AddFvTail x lp in
+         parametres_en_tete fv1 res
+    end.
+
+Ltac append1 a l :=
+ match l with
+ | (@nil _)     => constr:(cons a l)
+ | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l')
+ end.
+
+Ltac rev l :=
+  match l with
+   |(@nil _)      => l
+   | (cons ?x ?l) => let l' := rev l in append1 x l'
+  end.
+
+
+Ltac nsatz_call_n info nparam p rr lp kont :=
+  nsatz_compute (PEc info :: PEc nparam :: PEpow p rr :: lp);
+  match goal with
+  | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
+    intros _;
+    set (lci:=lci0);
+    set (lq:=lq0);
+    kont c rr lq lci
+  end.
+
+Ltac nsatz_call radicalmax info nparam p lp kont :=
+  let rec try_n n :=
+    lazymatch n with
+    | 0%N => fail
+    | _ =>
+(*        idtac "Trying power: " n;*)
+        (let r := eval compute in (Nminus radicalmax (Npred n)) in
+         nsatz_call_n info nparam p r lp kont) ||
+         let n' := eval compute in (Npred n) in try_n n'
+    end in
+  try_n radicalmax.
+
+
+Ltac nsatzR_gen radicalmax info lparam lvar n RNG lH _rl :=
+  get_Pre RNG ();
+  let mkFV := Ring_tac.get_RingFV RNG in
+  let mkPol := Ring_tac.get_RingMeta RNG in
+  generalise_eq_hyps;
+  let t := Get_goal in
+  let lpol := lpol_goal t in
+  intros;
+  let fv :=
+    match lvar with
+    | nil =>
+        let fv1 := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in
+        let fv1 := list_fold_right mkFV fv1 lpol in
+        rev fv1
+    (* heuristique: les dernieres variables auront le poid le plus fort *)
+    | _ => lvar
+    end in
+  check_fv fv;
+  (*idtac "variables:";idtac fv;*)
+  let nparam := eval compute in (Z_of_nat (List.length lparam)) in
+  let fv := parametres_en_tete fv lparam in
+  idtac "variables:"; idtac fv;
+   (* idtac "nparam:"; idtac nparam;*)
+  let lpol := list_fold_right
+    ltac:(fun p l => let p' := mkPol p fv in constr:(p'::l))
+    (@nil (PExpr Z))
+    lpol in
+  let lpol := eval compute in (List.rev lpol) in
+  (*idtac lpol;*)
+  let SplitPolyList kont :=
+    match lpol with
+    | ?p2::?lp2 => kont p2 lp2
+    | _ => idtac "polynomial not in the ideal"
+    end in
+  SplitPolyList ltac:(fun p lp =>
+    set (p21:=p) ;
+    set (lp21:=lp);
+    nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci =>
+      set (q := PEmul c (PEpow p21 r));
+      let Hg := fresh "Hg" in
+      assert (Hg:check lp21 q (lci,lq) = true);
+      [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate"
+      | let Hg2 := fresh "Hg" in
+        assert (Hg2: interpret3 q fv = 0);
+        [ simpl; apply (@check_correct fv lp21 q (lci,lq) Hg); simpl;
+          repeat (split;[assumption|idtac]); exact I
+        | simpl in Hg2; simpl;
+          apply nsatzR_l3 with (interpret3 c fv) (Nnat.nat_of_N r);simpl;
+          [ discrR || idtac "could not prove discrimination result"
+          | exact Hg2]
+        ]
+      ])).
+
+Ltac nsatzRpv radicalmax info lparam lvar:=
+  nsatzR_begin;
+  intros;
+  let G := Get_goal in
+  ring_lookup
+    (PackRing ltac:(nsatzR_gen radicalmax info lparam lvar ring_subst_niter))
+    [] G.
+
+Ltac nsatzR := nsatzRpv 6%N 1%Z (@nil R) (@nil R).
+Ltac nsatzRradical radicalmax := nsatzRpv radicalmax 1%Z (@nil R) (@nil R).
+Ltac nsatzRparameters lparam := nsatzRpv 6%N 1%Z lparam (@nil R).
+
+Tactic Notation "nsatz" := nsatzR.
+Tactic Notation "nsatz" "with" "lexico" :=
+  nsatzRpv 6%N 2%Z (@nil R) (@nil R).
+Tactic Notation "nsatz" "with" "lexico" "sugar":=
+  nsatzRpv 6%N 3%Z (@nil R) (@nil R).
+Tactic Notation "nsatz" "without" "sugar":=
+  nsatzRpv 6%N 0%Z (@nil R) (@nil R).
+
+
diff --git a/plugins/nsatz/NsatzZ.v b/plugins/nsatz/NsatzZ.v
new file mode 100644
index 00000000..a65efac2
--- /dev/null
+++ b/plugins/nsatz/NsatzZ.v
@@ -0,0 +1,73 @@
+(************************************************************************)
+(*  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 Reals ZArith.
+Require Export NsatzR.
+
+Open Scope Z_scope.
+
+Lemma nsatzZhypR: forall x y:Z, x=y -> IZR x = IZR y.
+Proof IZR_eq. (* or f_equal ... *)
+
+Lemma nsatzZconclR: forall x y:Z, IZR x = IZR y -> x = y.
+Proof eq_IZR.
+
+Lemma nsatzZhypnotR: forall x y:Z, x<>y -> IZR x <> IZR y.
+Proof IZR_neq.
+
+Lemma nsatzZconclnotR: forall x y:Z, IZR x <> IZR y -> x <> y.
+Proof.
+intros x y H. contradict H. f_equal. assumption.
+Qed.
+
+Ltac nsatzZtoR1 :=
+ repeat
+  (match goal with
+   | H:(@eq Z ?x ?y) |- _ =>
+       generalize (@nsatzZhypR _ _ H); clear H; intro H
+   | |- (@eq Z ?x ?y) => apply nsatzZconclR
+   | H:not (@eq Z ?x ?y) |- _ =>
+       generalize (@nsatzZhypnotR _ _ H); clear H; intro H
+   | |- not (@eq Z ?x ?y) => apply nsatzZconclnotR
+   end).
+
+Lemma nsatzZR1: forall x y:Z, IZR(x+y) = (IZR x + IZR y)%R.
+Proof plus_IZR.
+
+Lemma nsatzZR2: forall x y:Z, IZR(x*y) = (IZR x * IZR y)%R.
+Proof mult_IZR.
+
+Lemma nsatzZR3: forall x y:Z, IZR(x-y) = (IZR x - IZR y)%R.
+Proof.
+intros; symmetry. apply Z_R_minus.
+Qed.
+
+Lemma nsatzZR4: forall (x:Z) p, IZR(x ^ Zpos p) = (IZR x ^ nat_of_P p)%R.
+Proof.
+intros. rewrite pow_IZR.
+do 2 f_equal.
+apply Zpos_eq_Z_of_nat_o_nat_of_P.
+Qed.
+
+Ltac nsatzZtoR2:=
+  repeat
+   (rewrite nsatzZR1 in * ||
+    rewrite nsatzZR2 in * ||
+    rewrite nsatzZR3 in * ||
+    rewrite nsatzZR4 in *).
+
+Ltac nsatzZ_begin :=
+ intros;
+ nsatzZtoR1;
+ nsatzZtoR2;
+ simpl in *.
+ (*cbv beta iota zeta delta [nat_of_P Pmult_nat plus mult] in *.*)
+
+Ltac nsatzZ :=
+ nsatzZ_begin; (*idtac "nsatzZ_begin;";*)
+ nsatzR.
diff --git a/plugins/nsatz/Nsatz_domain.v b/plugins/nsatz/Nsatz_domain.v
new file mode 100644
index 00000000..11f905f9
--- /dev/null
+++ b/plugins/nsatz/Nsatz_domain.v
@@ -0,0 +1,558 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*
+ Tactic nsatz: proofs of polynomials equalities with variables in R.
+ Uses Hilbert Nullstellensatz and Buchberger algorithm.
+ Thanks to B.Gregoire for the verification of the certicate
+ and L.Thery for help on ring tactic,
+ and to B.Barras for modularization of the ocaml code.
+ Example: see test-suite/success/Nsatz.v
+ L.Pottier, june 2010
+*)
+
+Require Import List.
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinList.
+Require Import Znumtheory.
+Require Import Ring_polynom Ring_tac InitialRing.
+
+Declare ML Module "nsatz_plugin".
+
+
+Class Zero (A : Type) := {zero : A}.
+Notation "0" := zero.
+Class One (A : Type) := {one : A}.
+Notation "1" := one.
+Class Addition (A : Type) := {addition : A -> A -> A}.
+Notation "x + y" := (addition x y).
+Class Multiplication (A : Type) := {multiplication : A -> A -> A}.
+Notation "x * y" := (multiplication x y).
+Class Subtraction (A : Type) := {subtraction : A -> A -> A}.
+Notation "x - y" := (subtraction x y).
+Class Opposite (A : Type) := {opposite : A -> A}.
+Notation "- x" := (opposite x).
+
+Class Ring (R:Type) := {
+ ring0: R; ring1: R;
+ ring_plus: R->R->R; ring_mult: R->R->R;
+ ring_sub:  R->R->R; ring_opp: R->R;
+ ring_ring:
+   ring_theory ring0 ring1 ring_plus ring_mult ring_sub
+               ring_opp (@eq R)}.
+
+Class Domain (R : Type) := {
+ domain_ring:> Ring R;
+ domain_axiom_product:
+   forall x y, ring_mult x y = ring0 -> x = ring0 \/ y = ring0;
+ domain_axiom_one_zero: ring1 <> ring0}.
+
+Ltac ring2 := simpl; ring.
+
+Section domain.
+
+Variable R: Type.
+Variable Rd: Domain R.
+Add Ring Rr: (@ring_ring R (@domain_ring R Rd)).
+
+Instance zero_ring : Zero R := {zero := ring0}.
+Instance one_ring : One R := {one := ring1}.
+Instance addition_ring : Addition R := {addition x y := ring_plus x y}.
+Instance multiplication_ring : Multiplication R := {multiplication x y := ring_mult x y}.
+Instance subtraction_ring : Subtraction R := {subtraction x y := ring_sub x y}.
+Instance opposite_ring : Opposite R := {opposite x := ring_opp x}.
+
+Lemma psos_r1b: forall x y:R, x - y = 0 -> x = y.
+intros x y H; replace x with ((x - y) + y);
+  [rewrite H | idtac]; ring2.
+Qed.
+
+Lemma psos_r1: forall x y, x = y -> x - y = 0.
+intros x y H; rewrite H; ring2.
+Qed.
+
+
+Lemma nsatzR_diff: forall x y:R, x<>y -> x - y<>0.
+intros.
+intro; apply H.
+replace x with ((x - y) + y) by ring2.
+rewrite H0; ring2.
+Qed.
+
+(* code de Benjamin *)
+Require Import ZArith.
+
+Definition PolZ := Pol Z.
+Definition PEZ := PExpr Z.
+
+Definition P0Z : PolZ := @P0 Z 0%Z.
+
+Definition PolZadd : PolZ -> PolZ -> PolZ :=
+  @Padd Z 0%Z Zplus Zeq_bool.
+
+Definition PolZmul : PolZ -> PolZ -> PolZ :=
+  @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool.
+
+Definition PolZeq := @Peq Z Zeq_bool.
+
+Definition norm :=
+  @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
+
+Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ :=
+ match la, lp with
+ | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp)
+ | _, _ => P0Z
+ end.
+
+Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) :=
+ match lla with
+ | List.nil => lp
+ | la::lla => compute_list lla ((mult_l la lp)::lp)
+ end.
+
+Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) :=
+ let (lla, lq) := certif in
+ let lp := List.map norm lpe in
+ PolZeq (norm qe) (mult_l lq (compute_list lla lp)).
+
+
+(* Correction *)
+Definition PhiR : list R -> PolZ -> R :=
+  (Pphi 0 ring_plus ring_mult (gen_phiZ 0 1 ring_plus ring_mult ring_opp)).
+
+Definition pow (r : R) (n : nat) := pow_N 1 ring_mult r (Nnat.N_of_nat n).
+
+Definition PEevalR : list R -> PEZ -> R :=
+   PEeval 0 ring_plus ring_mult ring_sub ring_opp
+    (gen_phiZ 0 1 ring_plus ring_mult ring_opp)
+         Nnat.nat_of_N pow.
+
+Lemma P0Z_correct : forall l, PhiR l P0Z = 0.
+Proof. trivial. Qed.
+
+Lemma Rext: ring_eq_ext ring_plus ring_mult ring_opp eq.
+apply mk_reqe. intros. rewrite H; rewrite H0; trivial.
+ intros. rewrite H; rewrite H0; trivial.
+intros. rewrite H; trivial. Qed.
+
+Lemma Rset : Setoid_Theory R eq.
+apply Eqsth.
+Qed.
+
+Lemma PolZadd_correct : forall P' P l,
+  PhiR l (PolZadd P P') = ((PhiR l P) + (PhiR l P')).
+Proof.
+ refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
+           (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))).
+Qed.
+
+Lemma PolZmul_correct : forall P P' l,
+  PhiR l (PolZmul P P') = ((PhiR l P) * (PhiR l P')).
+Proof.
+ refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
+           (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))).
+Qed.
+
+Lemma R_power_theory
+     : power_theory 1 ring_mult eq Nnat.nat_of_N pow.
+apply mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. trivial. Qed.
+
+Lemma norm_correct :
+  forall (l : list R) (pe : PEZ), PEevalR l pe = PhiR l (norm pe).
+Proof.
+ intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
+           (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))) R_power_theory)
+    with (lmp:= List.nil).
+ compute;trivial.
+Qed.
+
+Lemma PolZeq_correct : forall P P' l,
+  PolZeq P P' = true ->
+  PhiR l P = PhiR l P'.
+Proof.
+ intros;apply
+   (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))));trivial.
+Qed.
+
+Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop :=
+  match l with
+  | List.nil => True
+  | a::l => Interp a = 0 /\ Cond0 A Interp l
+  end.
+
+Lemma mult_l_correct : forall l la lp,
+  Cond0 PolZ (PhiR l) lp ->
+  PhiR l (mult_l la lp) = 0.
+Proof.
+ induction la;simpl;intros;trivial.
+ destruct lp;trivial.
+ simpl in H;destruct H.
+ rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring2 | trivial].
+Qed.
+
+Lemma compute_list_correct : forall l lla lp,
+  Cond0 PolZ (PhiR l) lp ->
+  Cond0 PolZ (PhiR l) (compute_list lla lp).
+Proof.
+ induction lla;simpl;intros;trivial.
+ apply IHlla;simpl;split;trivial.
+ apply mult_l_correct;trivial.
+Qed.
+
+Lemma check_correct :
+  forall l lpe qe certif,
+    check lpe qe certif = true ->
+    Cond0 PEZ (PEevalR l) lpe ->
+    PEevalR l qe = 0.
+Proof.
+ unfold check;intros l lpe qe (lla, lq) H2 H1.
+ apply PolZeq_correct with (l:=l) in H2.
+ rewrite norm_correct, H2.
+ apply mult_l_correct.
+ apply compute_list_correct.
+ clear H2 lq lla qe;induction lpe;simpl;trivial.
+ simpl in H1;destruct H1.
+ rewrite <- norm_correct;auto.
+Qed.
+
+(* fin du code de Benjamin *)
+
+Lemma pow_not_zero: forall p n, pow p n = 0 -> p = 0.
+induction n. unfold pow; simpl. intros. absurd (1 = 0).
+simpl. apply domain_axiom_one_zero.
+ trivial. replace (pow p (S n)) with (p * (pow p n)). intros.
+case (@domain_axiom_product _ _ _ _ H). trivial. trivial.
+unfold pow; simpl.
+clear IHn. induction n; try ring2. simpl.
+ rewrite pow_pos_Psucc. trivial. exact Rset.
+ intros. rewrite H; rewrite H0; trivial.
+ intros. ring2. intros. ring2. Qed.
+
+Lemma Rdomain_pow: forall c p r, ~c= 0 -> c * (pow p r)= 0 -> p = ring0.
+intros. case (@domain_axiom_product _ _ _ _ H0). intros; absurd (c = 0); auto.
+intros. apply pow_not_zero with r. trivial. Qed.
+
+Definition R2:= 1 + 1.
+
+Fixpoint IPR p {struct p}: R :=
+  match p with
+    xH => 1
+  | xO xH => 1 + 1
+  | xO p1 => R2 + (IPR p1)
+  | xI xH => 1 + (1 + 1)
+  | xI p1 => 1 + (R2 * (IPR p1))
+  end.
+
+Definition IZR1 z :=
+  match z with Z0 => 0
+             | Zpos p => IPR p
+             | Zneg p => -(IPR p)
+  end.
+
+Fixpoint interpret3 t fv {struct t}: R :=
+  match t with
+  | (PEadd t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 + v2)
+  | (PEmul t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 * v2)
+  | (PEsub t1 t2) =>
+       let v1  := interpret3 t1 fv in
+       let v2  := interpret3 t2 fv in (v1 - v2)
+  | (PEopp t1) =>
+       let v1  := interpret3 t1 fv in (- v1)
+  | (PEpow t1 t2) =>
+       let v1  := interpret3 t1 fv in pow v1 (Nnat.nat_of_N t2)
+  | (PEc t1) => (IZR1 t1)
+  | (PEX n) => List.nth (pred (nat_of_P n)) fv 0
+  end.
+
+
+End domain.
+
+Ltac equalities_to_goal :=
+  lazymatch goal with
+  |  H: (@eq _ ?x 0) |- _ => try revert H
+  |  H: (@eq _ 0 ?x) |- _ =>
+          try generalize (sym_equal H); clear H
+  |  H: (@eq _ ?x ?y) |- _ =>
+          try generalize (@psos_r1 _ _ _ _ H); clear H
+   end.
+
+Ltac nsatz_domain_begin tacsimpl:=
+  intros;
+  try apply (@psos_r1b _ _);
+  repeat equalities_to_goal;
+  tacsimpl.
+
+Ltac generalise_eq_hyps:=
+  repeat
+    (match goal with
+     |h : (?p = ?q)|- _ => revert h
+     end).
+
+Ltac lpol_goal t :=
+  match t with
+  | ?a = ring0 -> ?b =>
+    let r:= lpol_goal b in
+    constr:(a::r)
+  | ?a = ring0 => constr:(a::nil)
+ end.
+
+(* lp est incluse dans fv. La met en tete. *)
+
+Ltac parametres_en_tete fv lp :=
+    match fv with
+     | (@nil _)          => lp
+     | (@cons _ ?x ?fv1) =>
+       let res := AddFvTail x lp in
+         parametres_en_tete fv1 res
+    end.
+
+Ltac append1 a l :=
+ match l with
+ | (@nil _)     => constr:(cons a l)
+ | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l')
+ end.
+
+Ltac rev l :=
+  match l with
+   |(@nil _)      => l
+   | (cons ?x ?l) => let l' := rev l in append1 x l'
+  end.
+
+Ltac nsatz_call_n info nparam p rr lp kont :=
+  let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in
+  nsatz_compute ll;
+  match goal with
+  | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
+    intros _;
+    set (lci:=lci0);
+    set (lq:=lq0);
+    kont c rr lq lci
+  end.
+
+Ltac nsatz_call radicalmax info nparam p lp kont :=
+  let rec try_n n :=
+    lazymatch n with
+    | 0%N => fail
+    | _ =>
+(*        idtac "Trying power: " n;*)
+        (let r := eval compute in (Nminus radicalmax (Npred n)) in
+         nsatz_call_n info nparam p r lp kont) ||
+         let n' := eval compute in (Npred n) in try_n n'
+    end in
+  try_n radicalmax.
+
+
+Set Implicit Arguments.
+Class Cclosed_seq T (l:list T) := {}.
+Instance Iclosed_nil T : Cclosed_seq (T:=T) nil.
+Instance Iclosed_cons T t l `{Cclosed_seq (T:=T) l} : Cclosed_seq (T:=T) (t::l).
+
+Class Cfind_at (R:Type) (b:R) (l:list R) (i:nat) := {}.
+Instance  Ifind0 (R:Type) (b:R) l: Cfind_at b (b::l) 0.
+Instance  IfindS (R:Type) (b2 b1:R) l i `{Cfind_at R b1 l i} : Cfind_at b1 (b2::l) (S i) | 1.
+Definition Ifind0' := Ifind0.
+Definition IfindS' := IfindS.
+
+Definition li_find_at (R:Type) (b:R) l i `{Cfind_at R b l i} {H:Cclosed_seq (T:=R) l} := (l,i).
+
+Class Creify (R:Type) (e:PExpr Z) (l:list R) (b:R) := {}.
+Instance  Ireify_zero (R:Type) (Rd:Domain R) l : Creify (PEc 0%Z) l ring0.
+Instance  Ireify_one (R:Type)  (Rd:Domain R) l : Creify (PEc 1%Z) l ring1.
+Instance  Ireify_plus (R:Type)  (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
+ : Creify (PEadd e1 e2) l (ring_plus b1 b2).
+Instance  Ireify_mult (R:Type)  (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
+ : Creify (PEmul e1 e2) l (ring_mult b1 b2).
+Instance  Ireify_sub (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
+ : Creify (PEsub e1 e2) l (ring_sub b1 b2).
+Instance  Ireify_opp (R:Type) (Rd:Domain R) e1 l b1 `{Creify R e1 l b1}
+ : Creify (PEopp e1) l (ring_opp b1).
+Instance  Ireify_var (R:Type) b l i `{Cfind_at R b l i}
+ : Creify (PEX _ (P_of_succ_nat i)) l b | 100.
+
+
+Class Creifylist (R:Type) (le:list (PExpr Z)) (l:list R) (lb:list R) := {}.
+Instance Creify_nil (R:Type) l : Creifylist nil l (@nil R).
+Instance Creify_cons (R:Type) e1 l b1 le2 lb2 `{Creify R e1 l b1} `{Creifylist R le2 l lb2}
+ : Creifylist (e1::le2) l (b1::lb2).
+
+Definition li_reifyl (R:Type) le l lb `{Creifylist R le l lb}
+ {H:Cclosed_seq (T:=R) l} := (l,le).
+
+Unset Implicit Arguments.
+
+Ltac lterm_goal g :=
+  match g with
+  ?b1 = ?b2 => constr:(b1::b2::nil)
+  | ?b1 = ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l)
+  end.
+
+Ltac reify_goal l le lb:=
+  match le with
+     nil => idtac
+   | ?e::?le1 =>
+        match lb with
+         ?b::?lb1 =>
+           let x := fresh "B" in
+           set (x:= b) at 1;
+           change x with (@interpret3 _ _ e l);
+          clear x;
+           reify_goal l le1 lb1
+        end
+  end.
+
+Ltac get_lpol g :=
+  match g with
+  (interpret3 _ _ ?p _) = _ => constr:(p::nil)
+  | (interpret3 _ _ ?p _) = _ -> ?g =>
+       let l := get_lpol g in constr:(p::l)
+  end.
+
+Ltac nsatz_domain_generic radicalmax info lparam lvar tacsimpl Rd :=
+  match goal with
+  |- ?g => let lb := lterm_goal g in
+     (*idtac "lb"; idtac lb;*)
+     match eval red in (li_reifyl (lb:=lb)) with
+     | (?fv, ?le) =>
+        let fv := match lvar with
+                     (@nil _) => fv
+                    | _ => lvar
+                  end in
+        (* idtac "variables:";idtac fv;*)
+        let nparam := eval compute in (Z_of_nat (List.length lparam)) in
+        let fv := parametres_en_tete fv lparam in
+        (*idtac "variables:"; idtac fv;
+        idtac "nparam:"; idtac nparam;*)
+        match eval red in (li_reifyl (l:=fv) (lb:=lb)) with
+          | (?fv, ?le) =>
+              idtac "variables:";idtac fv;
+              reify_goal fv le lb;
+                match goal with
+                   |- ?g =>
+                       let lp := get_lpol g in
+                       let lpol := eval compute in (List.rev lp) in
+                       (*idtac "polynomes:"; idtac lpol;*)
+                       tacsimpl; intros;
+
+  let SplitPolyList kont :=
+    match lpol with
+    | ?p2::?lp2 => kont p2 lp2
+    | _ => idtac "polynomial not in the ideal"
+    end in
+  tacsimpl;
+  SplitPolyList ltac:(fun p lp =>
+    set (p21:=p) ;
+    set (lp21:=lp);
+    (*idtac "lp:"; idtac lp; *)
+    nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci =>
+      set (q := PEmul c (PEpow p21 r));
+      let Hg := fresh "Hg" in
+      assert (Hg:check lp21 q (lci,lq) = true);
+      [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate"
+      | let Hg2 := fresh "Hg" in
+            assert (Hg2: interpret3 _ _ q fv = ring0);
+        [ tacsimpl;
+          apply (@check_correct _ Rd fv lp21 q (lci,lq) Hg);
+          tacsimpl;
+          repeat (split;[assumption|idtac]); exact I
+        | simpl in Hg2; tacsimpl;
+          apply Rdomain_pow with (interpret3 _ _ c fv) (Nnat.nat_of_N r); tacsimpl;
+          [ apply domain_axiom_one_zero || idtac "could not prove discrimination result"
+          | exact Hg2]
+        ]
+      ]
+)
+)
+end end end end .
+
+Ltac nsatz_domainpv radicalmax info lparam lvar tacsimpl rd:=
+  nsatz_domain_begin tacsimpl;
+  nsatz_domain_generic radicalmax info lparam lvar tacsimpl rd.
+
+Ltac nsatz_domain:=
+  intros;
+  match goal with
+    |- (@eq ?r _ _ ) =>
+       let a := constr:(@Ireify_zero _ _  (@nil r)) in
+       match a with
+          (@Ireify_zero _ ?rd _) =>
+          nsatz_domainpv 6%N 1%Z (@nil r) (@nil r) ltac:(simpl) rd
+       end
+  end.
+
+
+
+(* Dans Z *)
+Instance Zri : Ring Z := {
+  ring0 := 0%Z;
+  ring1 := 1%Z;
+  ring_plus := Zplus;
+  ring_mult := Zmult;
+  ring_sub := Zminus;
+  ring_opp := Zopp;
+  ring_ring := Zth}.
+
+Lemma Zaxiom_one_zero: 1%Z <> 0%Z.
+discriminate.
+Qed.
+
+Instance Zdi : Domain Z := {
+  domain_ring := Zri;
+  domain_axiom_product := Zmult_integral;
+  domain_axiom_one_zero := Zaxiom_one_zero}.
+
+
+Ltac simplZ:=
+  simpl;
+replace 0%Z with (@ring0 _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace 1%Z with (@ring1 _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zplus with (@ring_plus _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zmult with (@ring_mult _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zminus with (@ring_sub _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zopp with (@ring_opp _ (@domain_ring _ Zdi));[idtac|reflexivity].
+
+Ltac nsatz_domainZ:= nsatz_domainpv 6%N 1%Z (@nil Z) (@nil Z) ltac:simplZ Zdi.
+
+
+(* Dans R *)
+Require Import Reals.
+Require Import RealField.
+
+Instance Rri : Ring R := {
+  ring0 := 0%R;
+  ring1 := 1%R;
+  ring_plus := Rplus;
+  ring_mult := Rmult;
+  ring_sub := Rminus;
+  ring_opp := Ropp;
+  ring_ring := RTheory}.
+
+Lemma Raxiom_one_zero: 1%R <> 0%R.
+discrR.
+Qed.
+
+Instance Rdi : Domain R := {
+  domain_ring := Rri;
+  domain_axiom_product := Rmult_integral;
+  domain_axiom_one_zero := Raxiom_one_zero}.
+
+
+Ltac simplR:=
+  simpl;
+replace 0%R with (@ring0 _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace 1%R with (@ring1 _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Rplus with (@ring_plus _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Rmult with (@ring_mult _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Rminus with (@ring_sub _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Ropp with (@ring_opp _ (@domain_ring _ Rdi));[idtac|reflexivity].
+
+Ltac nsatz_domainR:= nsatz_domainpv 6%N 1%Z (@List.nil R) (@List.nil R) ltac:simplR Rdi.
diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml
new file mode 100644
index 00000000..b91f01d1
--- /dev/null
+++ b/plugins/nsatz/ideal.ml
@@ -0,0 +1,1057 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* Nullstellensatz with Groebner basis computation
+
+We use a sparse representation for polynomials:
+a monomial is an array of exponents (one for each variable)
+with its degree in head
+a polynomial is a sorted list of (coefficient, monomial)
+
+ *)
+
+open Utile
+open List
+
+exception NotInIdeal
+
+module type S = sig
+
+(* Monomials *)
+type mon = int array
+
+val mult_mon : mon -> mon -> mon
+val deg : mon -> int
+val compare_mon : mon -> mon -> int
+val div_mon : mon -> mon -> mon
+val div_mon_test : mon -> mon -> bool
+val ppcm_mon : mon -> mon -> mon
+
+(* Polynomials *)
+
+type deg = int
+type coef
+type poly
+type polynom 
+
+val repr : poly -> (coef * mon) list
+val polconst : coef -> poly
+val zeroP : poly
+val gen : int -> poly
+
+val equal : poly -> poly -> bool
+val name_var : string list ref
+val getvar : string list -> int -> string
+val lstringP : poly list -> string
+val printP : poly -> unit
+val lprintP : poly list -> unit
+
+val div_pol_coef : poly -> coef -> poly
+val plusP : poly -> poly -> poly
+val mult_t_pol : coef -> mon -> poly -> poly
+val selectdiv : mon -> poly list -> poly
+val oppP : poly -> poly
+val emultP : coef -> poly -> poly
+val multP : poly -> poly -> poly
+val puisP : poly -> int -> poly
+val contentP : poly -> coef
+val contentPlist : poly list -> coef
+val pgcdpos : coef -> coef -> coef
+val div_pol : poly -> poly -> coef -> coef -> mon -> poly
+val reduce2 : poly -> poly list -> coef * poly
+
+val poldepcontent : coef list ref
+val coefpoldep_find : poly -> poly -> poly
+val coefpoldep_set : poly -> poly -> poly -> unit
+val initcoefpoldep : poly list -> unit
+val reduce2_trace : poly -> poly list -> poly list -> poly list * poly
+val spol : poly -> poly -> poly
+val etrangers : poly -> poly -> bool
+val div_ppcm : poly -> poly -> poly -> bool
+
+val genPcPf : poly -> poly list -> poly list -> poly list
+val genOCPf : poly list -> poly list
+
+val is_homogeneous : poly -> bool
+
+type certificate =
+    { coef : coef; power : int;
+      gb_comb : poly list list; last_comb : poly list }
+
+val test_dans_ideal : poly -> poly list -> poly list ->
+  poly list * poly * certificate
+val in_ideal : deg -> poly list -> poly -> poly list * poly * certificate
+
+end
+
+(***********************************************************************
+   Global options
+*)
+let lexico = ref false
+let use_hmon = ref false
+
+(* division of tail monomials *)
+
+let reduire_les_queues = false
+
+(* divide first with new polynomials *)
+
+let nouveaux_pol_en_tete = false
+
+(***********************************************************************
+   Functor
+*)
+
+module Make (P:Polynom.S) = struct
+
+  type coef = P.t
+  let coef0 = P.of_num (Num.Int 0)
+  let coef1 = P.of_num (Num.Int 1)
+  let coefm1 = P.of_num (Num.Int (-1))
+  let string_of_coef c = "["^(P.to_string c)^"]"
+
+(***********************************************************************
+   Monomials
+ array of integers, first is the degree
+*)
+
+type mon = int array
+type deg = int
+type poly = (coef * mon) list
+type polynom = 
+   {pol : poly ref;
+    num : int;
+    sugar : int}
+
+let nvar m =  Array.length m - 1
+
+let deg m = m.(0)
+
+let mult_mon m m' =
+  let d = nvar m in
+  let m'' = Array.create (d+1) 0 in
+  for i=0 to d do
+    m''.(i)<- (m.(i)+m'.(i));
+  done;
+  m''
+
+
+let compare_mon m m' =
+  let d = nvar m in
+  if !lexico
+  then (
+    (* Comparaison de monomes avec ordre du degre lexicographique = on commence par regarder la 1ere variable*)
+    let res=ref 0 in
+    let i=ref 1 in (* 1 si lexico pur 0 si degre*)
+    while (!res=0) && (!i<=d) do
+      res:= (compare m.(!i) m'.(!i));
+      i:=!i+1;
+    done;
+    !res)
+  else (
+     (* degre lexicographique inverse *)
+    match compare m.(0) m'.(0) with
+    | 0 -> (* meme degre total *)
+	let res=ref 0 in
+	let i=ref d in
+	while (!res=0) && (!i>=1) do
+	  res:= - (compare m.(!i) m'.(!i));
+	  i:=!i-1;
+	done;
+	!res
+    | x -> x)
+
+let div_mon m m' =
+  let d = nvar m in
+  let m'' = Array.create (d+1) 0 in
+  for i=0 to d do
+    m''.(i)<- (m.(i)-m'.(i));
+  done;
+  m''
+
+let div_pol_coef p c =
+  List.map (fun (a,m) -> (P.divP a c,m)) p
+
+(* m' divides m  *)
+let div_mon_test m m' =
+  let d = nvar m in
+  let res=ref true in
+  let i=ref 0 in (*il faut que le degre total soit bien mis sinon, i=ref 1*)
+  while (!res) && (!i<=d) do
+    res:= (m.(!i) >= m'.(!i));
+    i:=succ !i;
+  done;
+  !res
+
+let set_deg m =
+  let d = nvar m in
+  m.(0)<-0;
+  for i=1 to d do
+    m.(0)<-  m.(i)+m.(0);
+  done;
+  m
+
+(* lcm *)
+let ppcm_mon m m' =
+  let d = nvar m in
+  let m'' = Array.create (d+1) 0 in
+  for i=1 to d do
+    m''.(i)<- (max m.(i) m'.(i));
+  done;
+  set_deg m''
+
+
+
+(**********************************************************************
+  Polynomials
+  list of (coefficient, monomial) decreasing order 
+*)
+
+let repr p = p
+
+let equal =
+  Util.list_for_all2eq
+    (fun (c1,m1) (c2,m2) -> P.equal c1 c2 && m1=m2)
+
+let hash p =
+  let c = map fst p in
+  let m = map snd p in
+  fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c
+
+module Hashpol = Hashtbl.Make(
+  struct
+    type t = poly
+    let equal = equal
+    let hash = hash
+  end)
+
+
+(* A pretty printer for polynomials, with Maple-like syntax. *)
+
+open Format
+
+let getvar lv i =
+  try (nth lv i)
+  with _ -> (fold_left (fun r x -> r^" "^x) "lv= " lv)
+    ^" i="^(string_of_int i)
+
+let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef
+    dimmon string_of_exp lvar p =
+
+
+  let rec string_of_mon m coefone =
+    let s=ref [] in
+    for i=1 to (dimmon m) do
+      (match (string_of_exp m i) with
+        "0" -> ()
+      | "1" -> s:= (!s) @ [(getvar !lvar (i-1))]
+      | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]);
+    done;
+    (match !s with
+      [] -> if coefone 
+      then  "1"
+      else ""
+    | l -> if coefone 
+    then  (String.concat "*" l)
+    else ( "*" ^
+           (String.concat "*" l)))
+  and string_of_term t start = let a = coefterm t and m = monterm t in
+  match (string_of_coef a) with
+    "0" -> ""
+  | "1" ->(match start with
+      true -> string_of_mon m true
+    |false -> ( "+ "^
+                (string_of_mon m true)))
+  | "-1" ->( "-" ^" "^(string_of_mon m true))
+  | c -> if (String.get c 0)='-'
+  then ( "- "^
+         (String.sub c 1 
+            ((String.length c)-1))^
+         (string_of_mon m false))
+  else (match start with
+    true -> ( c^(string_of_mon m false))
+  |false -> ( "+ "^
+              c^(string_of_mon m false)))
+  and stringP p start = 
+    if (zeroP p)
+    then (if start 
+    then ("0")
+    else "")
+    else ((string_of_term (hdP p) start)^
+          " "^
+          (stringP (tlP p) false))
+  in 
+  (stringP p true)
+
+
+
+let print_pol zeroP hdP tlP coefterm monterm string_of_coef
+    dimmon string_of_exp lvar p =
+
+  let rec print_mon m coefone =
+    let s=ref [] in
+    for i=1 to (dimmon m) do
+      (match (string_of_exp m i) with
+        "0" -> ()
+      | "1" -> s:= (!s) @ [(getvar !lvar (i-1))]
+      | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]);
+    done;
+    (match !s with
+      [] -> if coefone 
+      then print_string "1"
+      else ()
+    | l -> if coefone 
+    then print_string (String.concat "*" l)
+    else (print_string "*"; 
+          print_string (String.concat "*" l)))
+  and print_term t start = let a = coefterm t and m = monterm t in
+  match (string_of_coef a) with
+    "0" -> ()
+  | "1" ->(match start with
+      true -> print_mon m true
+    |false -> (print_string "+ ";
+               print_mon m true))
+  | "-1" ->(print_string "-";print_space();print_mon m true)
+  | c -> if (String.get c 0)='-'
+  then (print_string "- ";
+        print_string (String.sub c 1 
+                        ((String.length c)-1));
+        print_mon m false)
+  else (match start with
+    true -> (print_string c;print_mon m false)
+  |false -> (print_string "+ ";
+             print_string c;print_mon m false))
+  and printP p start = 
+    if (zeroP p)
+    then (if start 
+    then print_string("0")
+    else ())
+    else (print_term (hdP p) start;
+          if start then open_hovbox 0;
+          print_space();
+          print_cut();
+          printP (tlP p) false)
+  in open_hovbox 3;
+  printP p true;
+  print_flush()
+
+
+let name_var= ref []
+
+let stringP p =
+  string_of_pol 
+    (fun p -> match p with [] -> true | _ -> false)
+    (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal")
+    (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal")
+    (fun (a,m) -> a)
+    (fun (a,m) -> m)
+    string_of_coef
+    (fun m -> (Array.length m)-1)
+    (fun m i -> (string_of_int (m.(i))))
+    name_var
+    p
+
+let nsP2 = ref max_int
+
+let stringPcut p =
+  (*Polynomesrec.nsP1:=20;*)
+  nsP2:=10;
+  let res =
+    if (length p)> !nsP2
+    then (stringP [hd p])^" + "^(string_of_int (length p))^" termes"
+    else  stringP p in
+  (*Polynomesrec.nsP1:= max_int;*)
+  nsP2:= max_int;
+  res
+
+let rec lstringP l =
+  match l with
+    [] -> ""
+  |p::l -> (stringP p)^("\n")^(lstringP l)
+
+let printP = print_pol 
+    (fun p -> match p with [] -> true | _ -> false)
+    (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal")
+    (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal")
+    (fun (a,m) -> a)
+    (fun (a,m) -> m)
+    string_of_coef
+    (fun m -> (Array.length m)-1)
+    (fun m i -> (string_of_int (m.(i))))
+    name_var
+
+
+let rec lprintP l =
+  match l with
+    [] -> ()
+  |p::l -> printP p;print_string "\n"; lprintP l
+
+
+(* Operations *)
+
+let zeroP = []
+
+(* returns a constant polynom ial with d variables *)
+let polconst d c =
+  let m = Array.create (d+1) 0 in
+  let m = set_deg m in 
+  [(c,m)]
+
+let plusP p q =
+  let rec plusP p q =
+    match p with
+      [] -> q
+    |t::p' -> 
+	match q with
+	  [] -> p
+	|t'::q' ->
+            match compare_mon (snd t) (snd t') with
+              1 -> t::(plusP p' q)
+            |(-1) -> t'::(plusP p q')
+            |_ -> let c=P.plusP (fst t) (fst t') in
+              match P.equal c coef0 with
+                true -> (plusP p' q')
+              |false -> (c,(snd t))::(plusP p' q')
+  in plusP p q
+
+(* multiplication by (a,monomial) *)
+let mult_t_pol a m p =
+  let rec mult_t_pol p =
+    match p with
+      [] -> []
+    |(b,m')::p -> ((P.multP a b),(mult_mon m m'))::(mult_t_pol p)
+  in mult_t_pol p
+
+let coef_of_int x = P.of_num (Num.Int x)
+
+(* variable i *)
+let gen d i =
+  let m = Array.create (d+1) 0 in
+  m.(i) <- 1;
+  let m = set_deg m in 
+  [((coef_of_int 1),m)]
+
+let oppP p =
+  let rec oppP p =
+    match p with
+      [] -> []
+    |(b,m')::p -> ((P.oppP b),m')::(oppP p)
+  in oppP p
+
+(* multiplication by a coefficient *)
+let emultP a p =
+  let rec emultP p =
+    match p with
+      [] -> []
+    |(b,m')::p -> ((P.multP a b),m')::(emultP p)
+  in emultP p
+
+let multP p q =
+  let rec aux p =
+    match p with
+      [] -> []
+    |(a,m)::p' -> plusP (mult_t_pol a m q) (aux p')
+  in aux p
+
+let puisP p n=
+  match p with
+    [] -> []
+  |_ ->
+      let d = nvar (snd (hd p)) in
+      let rec puisP n =
+	match n with
+	  0 -> [coef1, Array.create (d+1) 0]
+	| 1 -> p
+	|_ -> multP p (puisP (n-1))
+      in puisP n
+	
+let rec contentP p =
+  match p with
+  |[] -> coef1
+  |[a,m] -> a
+  |(a,m)::p1 ->
+      if P.equal a coef1 || P.equal a coefm1
+      then a
+      else P.pgcdP a (contentP p1)
+
+let contentPlist lp =
+  match lp with
+  |[] -> coef1
+  |p::l1 ->
+      fold_left
+	(fun r q ->
+	  if P.equal r coef1 || P.equal r coefm1
+	  then r
+	  else P.pgcdP r (contentP q))
+	(contentP p) l1
+	
+(***********************************************************************
+   Division of polynomials
+ *)
+
+let pgcdpos a b  = P.pgcdP a b
+
+let polynom0 =  {pol = ref []; num = 0; sugar = 0}
+   
+let ppol p = !(p.pol)
+
+let lm p = snd (hd (ppol p))
+
+let nallpol = ref 0
+
+let allpol = ref (Array.create 1000 polynom0)
+
+let new_allpol p s =
+  nallpol := !nallpol + 1;
+  if !nallpol >= Array.length !allpol
+  then
+    allpol := Array.append !allpol (Array.create !nallpol polynom0);
+  let p = {pol = ref p; num = !nallpol; sugar = s} in
+  !allpol.(!nallpol)<- p;
+  p
+
+(* returns a polynomial of l whose head monomial divides m, else [] *)
+
+let rec selectdiv m l =
+  match l with
+    [] -> polynom0
+  |q::r -> let m'= snd (hd (ppol q)) in
+    match (div_mon_test m m') with
+      true -> q
+    |false -> selectdiv m r
+
+let div_pol p q a b m = 
+(*  info ".";*)
+  plusP (emultP a p) (mult_t_pol b m q)
+
+let hmon = Hashtbl.create 1000
+
+let use_hmon = ref false
+
+let find_hmon m =
+  if !use_hmon
+  then Hashtbl.find hmon m
+  else raise Not_found
+
+let add_hmon m q =
+  if !use_hmon
+  then Hashtbl.add hmon m q
+  else ()
+
+let div_coef a b = P.divP a b
+
+
+(* remainder r of the division of p by polynomials of l, returns (c,r) where c is the coefficient for pseudo-division : c p = sum_i q_i p_i + r *)
+
+let reduce2 p l =
+  let l = if nouveaux_pol_en_tete then rev l else l in
+  let rec reduce p =
+    match p with
+      [] -> (coef1,[])
+    |t::p' ->
+	let (a,m)=t in
+      let q = (try find_hmon m 
+      with Not_found -> 
+	let q = selectdiv m l in
+	match (ppol q) with 
+          t'::q' -> (add_hmon m q;
+		     q)
+	|[] -> q) in
+      match (ppol q) with
+	[] -> if reduire_les_queues
+	then
+	  let (c,r)=(reduce p') in
+          (c,((P.multP a c,m)::r))
+	else (coef1,p)
+      |(b,m')::q' -> 
+          let c=(pgcdpos a b) in
+          let a'= (div_coef b c) in
+          let b'=(P.oppP (div_coef a c)) in
+          let (e,r)=reduce (div_pol p' q' a' b'
+                              (div_mon m m')) in
+          (P.multP a' e,r)
+  in let (c,r) = reduce p in
+  (c,r)
+
+(* trace of divisions *)
+
+(* list of initial polynomials *)
+let poldep = ref [] 
+let poldepcontent = ref []
+
+(* coefficients of polynomials when written with initial polynomials *)
+let coefpoldep = Hashtbl.create 51
+
+(* coef of q in p = sum_i c_i*q_i *)
+let coefpoldep_find p q =
+  try (Hashtbl.find coefpoldep (p.num,q.num))
+  with _ -> []
+
+let coefpoldep_remove p q =
+  Hashtbl.remove coefpoldep (p.num,q.num)
+
+let coefpoldep_set p q c =
+  Hashtbl.add coefpoldep (p.num,q.num) c
+
+let initcoefpoldep d lp =
+  poldep:=lp;
+  poldepcontent:= map (fun p -> contentP (ppol p)) lp;
+  iter
+    (fun p -> coefpoldep_set p p (polconst d (coef_of_int 1)))
+    lp
+
+(* keeps trace in coefpoldep 
+   divides without pseudodivisions *)
+
+let reduce2_trace p l lcp =
+  let l = if nouveaux_pol_en_tete then rev l else l in
+  (* rend (lq,r), ou r = p + sum(lq) *)
+  let rec reduce p =
+    match p with
+      [] -> ([],[])
+    |t::p' ->
+	let (a,m)=t in
+      let q =
+	(try find_hmon m 
+	with Not_found -> 
+	  let q = selectdiv m l in
+	  match (ppol q) with 
+            t'::q' -> (add_hmon m q;
+		       q)
+          |[] -> q) in
+      match (ppol q) with
+	[] ->
+	  if reduire_les_queues
+	  then
+	    let (lq,r)=(reduce p') in
+            (lq,((a,m)::r))
+	  else ([],p)
+      |(b,m')::q' -> 
+          let b'=(P.oppP (div_coef a b)) in
+          let m''= div_mon m m' in
+          let p1=plusP p' (mult_t_pol b' m'' q') in
+          let (lq,r)=reduce p1 in
+          ((b',m'',q)::lq, r)
+  in let (lq,r) = reduce p in
+  (*info "reduce2_trace:\n";
+     iter
+     (fun (a,m,s) ->
+     let x = mult_t_pol a m s in
+     info ((stringP x)^"\n"))
+     lq;
+     info "ok\n";*)
+  (map2
+     (fun c0 q ->
+       let c =
+	 fold_left
+	   (fun x (a,m,s) ->
+	     if equal (ppol s) (ppol q)
+	     then
+	       plusP x (mult_t_pol a m (polconst (nvar m) (coef_of_int 1)))
+	     else x)
+	   c0
+	   lq in
+       c)
+     lcp
+     !poldep,
+   r)     
+
+let homogeneous = ref false
+let pol_courant = ref polynom0
+
+(***********************************************************************
+   Completion
+ *)
+
+let sugar_flag = ref true
+
+let compute_sugar p =
+  fold_left (fun s (a,m) -> max s m.(0)) 0 p
+
+let mk_polynom p = 
+  new_allpol p (compute_sugar p)
+
+let spol ps qs=
+  let p = ppol ps in
+  let q = ppol qs in
+  let m = snd (hd p) in
+  let m'= snd (hd q) in
+  let a = fst (hd p) in
+  let b = fst (hd q) in
+  let p'= tl p in
+  let q'= tl q in
+  let c = (pgcdpos a b) in
+  let m''=(ppcm_mon m m') in
+  let m1 = div_mon m'' m in
+  let m2 = div_mon m'' m' in
+  let fsp p' q' =
+    plusP 
+      (mult_t_pol 
+	 (div_coef b c)
+	 m1 p')
+      (mult_t_pol 
+	 (P.oppP (div_coef a c))
+         m2 q') in
+  let sp = fsp p' q' in
+  let sps =
+    new_allpol
+      sp
+      (max (m1.(0) + ps.sugar) (m2.(0) + qs.sugar)) in
+  coefpoldep_set sps ps (fsp (polconst (nvar m) (coef_of_int 1)) []);
+  coefpoldep_set sps qs (fsp [] (polconst (nvar m) (coef_of_int 1)));
+  sps
+  
+
+let etrangers p p'=
+  let m = snd (hd p) in
+  let m'= snd (hd p') in
+  let d = nvar m in
+  let res=ref true in
+  let i=ref 1 in
+  while (!res) && (!i<=d) do
+    res:= (m.(!i) = 0) || (m'.(!i)=0);
+      i:=!i+1;
+  done;
+  !res
+
+(* teste if head monomial of p'' divides lcm of lhead monomials of p and p' *)
+
+let div_ppcm p p' p'' =
+  let m = snd (hd p) in
+  let m'= snd (hd p') in
+  let m''= snd (hd p'') in
+  let d = nvar m in
+  let res=ref true in
+  let i=ref 1 in
+  while (!res) && (!i<=d) do
+    res:= ((max m.(!i) m'.(!i)) >= m''.(!i));
+    i:=!i+1;
+  done;
+  !res
+
+(* code from extraction of Laurent Théry Coq program *)
+
+type 'poly cpRes =
+    Keep of ('poly list)
+  | DontKeep of ('poly list)
+
+let list_rec f0 f1 =
+  let rec f2 = function
+      [] -> f0
+    | a0::l0 -> f1 a0 l0 (f2 l0)
+  in f2
+
+let addRes i = function
+    Keep h'0 -> Keep (i::h'0)
+  | DontKeep h'0 -> DontKeep (i::h'0)
+
+let slice i a q =
+  list_rec
+    (match etrangers (ppol i) (ppol a) with
+      true -> DontKeep []
+    | false -> Keep [])
+    (fun b q1 rec_ren ->
+      match div_ppcm (ppol i) (ppol a) (ppol b) with
+	true ->  DontKeep (b::q1)
+      | false ->
+          (match div_ppcm (ppol i) (ppol b) (ppol a) with
+            true -> rec_ren
+          | false -> addRes b rec_ren)) q
+
+(* sugar strategy *)
+
+let rec addS x l =    l @ [x] (* oblige de mettre en queue sinon le certificat deconne *)
+			  
+let addSsugar x l =
+  if !sugar_flag
+  then 
+    let sx = x.sugar in
+    let rec insere l  =
+      match l with
+      | [] -> [x]
+      | y::l1 ->
+	  if sx <= y.sugar
+	  then x::l
+	  else y::(insere l1)
+    in insere l
+  else addS x l
+
+(* ajoute les spolynomes de i avec la liste de polynomes aP, 
+   a la liste q *)
+
+let genPcPf i aP q =
+  (let rec genPc aP0 =
+    match aP0 with
+      [] -> (fun r -> r)
+    | a::l1 -> 
+	(fun l ->
+          (match slice i a l1 with
+            Keep l2 -> addSsugar (spol i a) (genPc l2 l)
+          | DontKeep l2 -> genPc l2 l))
+  in genPc aP) q
+
+let genOCPf h' =
+  list_rec [] (fun a l rec_ren ->
+    genPcPf a l rec_ren) h'
+    
+(***********************************************************************
+ critical pairs/s-polynomials
+ *)
+    
+let ordcpair ((i1,j1),m1) ((i2,j2),m2) =
+(*  let s1 = (max
+	      (!allpol.(i1).sugar + m1.(0)
+		   - (snd (hd (ppol !allpol.(i1)))).(0))
+	      (!allpol.(j1).sugar + m1.(0)
+		   - (snd (hd (ppol !allpol.(j1)))).(0))) in 
+  let s2 = (max
+	      (!allpol.(i2).sugar + m2.(0)
+		   - (snd (hd (ppol !allpol.(i2)))).(0))
+	      (!allpol.(j2).sugar + m2.(0)
+		   - (snd (hd (ppol !allpol.(j2)))).(0))) in 
+  match compare s1 s2 with
+  | 1 -> 1
+  |(-1) -> -1
+  |0 ->  compare_mon m1 m2*)
+
+  compare_mon m1 m2 
+
+let sortcpairs lcp = 
+  sort ordcpair lcp
+
+let mergecpairs l1 l2 =
+  merge ordcpair l1 l2 
+
+let ord i j =
+  if i<j then (i,j) else (j,i)
+    
+let cpair p q =
+  if etrangers (ppol p) (ppol q)
+  then []
+  else [(ord p.num q.num,
+	 ppcm_mon (lm p) (lm q))]
+      
+let cpairs1 p lq =
+  sortcpairs (fold_left (fun r q -> r @ (cpair p q)) [] lq)
+    
+let cpairs lp =
+  let rec aux l =
+    match l with
+      []|[_] -> []
+    |p::l1 -> mergecpairs (cpairs1 p l1) (aux l1)
+  in aux lp
+    
+    
+let critere2 ((i,j),m) lp lcp =
+  exists
+    (fun h ->
+      h.num <> i && h.num <> j
+        && (div_mon_test m (lm h))
+	&& (let c1 = ord i h.num in
+	not (exists (fun (c,_) -> c1 = c) lcp))
+	&& (let c1 = ord j h.num in
+	not (exists (fun (c,_) -> c1 = c) lcp)))
+    lp
+
+let critere3 ((i,j),m) lp lcp =
+  exists
+    (fun h ->
+      h.num <> i && h.num <> j
+        && (div_mon_test m (lm h))
+	&& (h.num < j
+	   || not (m = ppcm_mon 
+		   (lm (!allpol.(i)))
+		   (lm h)))
+	&& (h.num < i
+	  || not (m = ppcm_mon 
+		   (lm (!allpol.(j)))
+		   (lm h))))
+    lp
+
+let add_cpairs p lp lcp =
+  mergecpairs (cpairs1 p lp) lcp 
+
+let step = ref 0
+
+let infobuch p q =
+  if !step = 0 
+  then (info ("[" ^ (string_of_int (length p))
+              ^ "," ^  (string_of_int (length q))
+              ^ "]"))
+
+(* in lp new polynomials are at the end *)
+
+let coef_courant = ref coef1
+
+type certificate =
+    { coef : coef; power : int;
+      gb_comb : poly list list; last_comb : poly list }
+
+let test_dans_ideal p lp lp0 =
+  let (c,r) = reduce2 (ppol !pol_courant) lp in
+  info ("remainder: "^(stringPcut r)^"\n");
+  coef_courant:= P.multP !coef_courant c;
+  pol_courant:= mk_polynom r;
+  if r=[]
+  then (info "polynomial reduced to 0\n";
+	let lcp = map (fun q -> []) !poldep in
+	let c = !coef_courant in
+	let (lcq,r) = reduce2_trace (emultP c p) lp lcp in
+	info "r ok\n";
+	info ("r: "^(stringP r)^"\n");
+        let res=ref  (emultP c p) in
+	iter2
+	  (fun cq q -> res:=plusP (!res) (multP cq (ppol q));
+	  )
+	  lcq !poldep;
+	info ("verif sum: "^(stringP (!res))^"\n");
+	info ("coefficient: "^(stringP (polconst 1 c))^"\n");
+	let rec aux lp =
+	  match lp with
+	  |[] -> []
+	  |p::lp ->
+	      (map
+		 (fun q -> coefpoldep_find p q)
+		 lp)::(aux lp)
+	in
+	let coefficient_multiplicateur = c in
+	let liste_polynomes_de_depart = rev lp0 in
+	let polynome_a_tester = p in
+	let liste_des_coefficients_intermediaires =
+	  (let lci = rev (aux (rev lp)) in
+	  let lci = ref lci (* (map rev lci) *) in
+	  iter (fun x -> lci := tl (!lci)) lp0;
+	  !lci) in
+	let liste_des_coefficients =
+	  map
+	    (fun cq -> emultP (coef_of_int (-1)) cq)
+	    (rev lcq) in
+	(liste_polynomes_de_depart,
+	 polynome_a_tester,
+	 {coef = coefficient_multiplicateur;
+	  power = 1;
+	  gb_comb = liste_des_coefficients_intermediaires;
+	  last_comb = liste_des_coefficients})
+       )
+  else ((*info "polynomial not reduced to 0\n";
+	   info ("\nremainder: "^(stringPcut r)^"\n");*)
+    raise NotInIdeal)
+      
+let divide_rem_with_critical_pair = ref false
+
+let list_diff l x =
+  filter (fun y -> y <> x) l
+
+let deg_hom p =
+  match p with
+  | [] -> -1
+  | (a,m)::_ -> m.(0)
+
+let pbuchf pq p lp0=
+  info "computation of the Groebner basis\n";
+  step:=0;
+  Hashtbl.clear hmon;
+  let rec pbuchf (lp, lpc) =
+      infobuch lp lpc;
+(*      step:=(!step+1)mod 10;*)
+      match lpc with
+        [] ->
+	  
+	 (* info ("List of polynomials:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));
+	  info "--------------------\n";*)
+	  test_dans_ideal (ppol p) lp lp0
+      | ((i,j),m) :: lpc2 ->
+(*          info "choosen pair\n";*)
+	  if critere3 ((i,j),m) lp lpc2
+	  then (info "c"; pbuchf (lp, lpc2))
+	  else    
+	    let a = spol !allpol.(i) !allpol.(j) in
+	    if !homogeneous && (ppol a)<>[] && deg_hom (ppol a)
+		> deg_hom (ppol !pol_courant)
+	    then (info "h"; pbuchf (lp, lpc2))
+	    else
+(*	      let sa = a.sugar in*)
+              let (ca,a0)= reduce2 (ppol a) lp in
+              match a0 with
+		[] -> info "0";pbuchf (lp, lpc2)
+              | _ ->
+(*		info "pair reduced\n";*)
+		  a.pol := emultP ca (ppol a);
+		  let (lca,a0) = reduce2_trace (ppol a) lp
+		      (map (fun q -> emultP ca (coefpoldep_find a q))
+			 !poldep) in
+(*		info "paire re-reduced";*)
+		  a.pol := a0;
+(*		  let a0 = new_allpol a0 sa in*)
+		  iter2 (fun c q ->
+		    coefpoldep_remove a q;
+		    coefpoldep_set a q c) lca !poldep;
+		  let a0 = a in
+		  info ("\nnew polynomials: "^(stringPcut (ppol a0))^"\n");
+		  let ct = coef1 (* contentP a0 *) in
+		  (*info ("content: "^(string_of_coef ct)^"\n");*)
+		  poldep:=addS a0 lp;
+		  poldepcontent:=addS ct (!poldepcontent);
+		  
+		  try test_dans_ideal (ppol p) (addS a0 lp) lp0
+		  with NotInIdeal ->
+		    let newlpc = add_cpairs a0 lp lpc2 in
+		    pbuchf (((addS a0 lp), newlpc))
+  in pbuchf pq
+    
+let is_homogeneous p =
+  match p with
+  | [] -> true
+  | (a,m)::p1 -> let d = m.(0) in
+    for_all (fun (b,m') -> m'.(0)=d) p1
+    
+(* returns
+   c
+   lp = [pn;...;p1]
+   p
+   lci = [[a(n+1,n);...;a(n+1,1)];
+   [a(n+2,n+1);...;a(n+2,1)];
+   ...
+   [a(n+m,n+m-1);...;a(n+m,1)]]
+   lc = [qn+m; ... q1]
+
+   such that
+   c*p = sum qi*pi 
+   where pn+k = a(n+k,n+k-1)*pn+k-1 + ... + a(n+k,1)* p1
+ *)
+
+let in_ideal d lp p =
+  Hashtbl.clear hmon;
+  Hashtbl.clear coefpoldep;
+  nallpol := 0;
+  allpol := Array.create 1000 polynom0;
+  homogeneous := for_all is_homogeneous (p::lp);
+  if !homogeneous then info "homogeneous polynomials\n";
+  info ("p: "^(stringPcut p)^"\n");
+  info ("lp:\n"^(fold_left (fun r p -> r^(stringPcut p)^"\n") "" lp));
+  (*info ("p: "^(stringP p)^"\n");
+  info ("lp:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));*)
+
+  let lp = map mk_polynom lp in
+  let p = mk_polynom p in
+  initcoefpoldep d lp;
+  coef_courant:=coef1;
+  pol_courant:=p;
+
+  let (lp1,p1,cert) =
+    try test_dans_ideal (ppol p) lp lp
+    with NotInIdeal -> pbuchf (lp, (cpairs lp)) p lp in
+  info "computed\n";
+
+  (map ppol lp1, p1, cert)
+    
+(* *)
+end
+
+	
+
diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml4
new file mode 100644
index 00000000..892d6037
--- /dev/null
+++ b/plugins/nsatz/nsatz.ml4
@@ -0,0 +1,608 @@
+(************************************************************************)
+(*  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 Pp
+open Util
+open Names
+open Term
+open Closure
+open Environ
+open Libnames
+open Tactics
+open Rawterm
+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
+
+open Num
+open Unix
+open Utile
+
+(***********************************************************************
+ Operations on coefficients
+*)
+
+let num_0 = Int 0
+and num_1 = Int 1
+and num_2 = Int 2
+and num_10 = Int 10
+
+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')
+
+module BigInt = struct
+  open Big_int
+
+  type t = big_int
+  let of_int = big_int_of_int
+  let coef0 = of_int 0
+  let coef1 = of_int 1
+  let of_num = Num.big_int_of_num
+  let to_num = Num.num_of_big_int
+  let equal = eq_big_int
+  let lt = lt_big_int
+  let le = le_big_int
+  let abs = abs_big_int
+  let plus =add_big_int
+  let mult = mult_big_int
+  let sub = sub_big_int
+  let opp = minus_big_int
+  let div = div_big_int
+  let modulo = mod_big_int
+  let to_string = string_of_big_int
+  let to_int x = int_of_big_int x
+  let hash x =
+    try (int_of_big_int x)
+    with _-> 1
+  let puis = power_big_int_positive_int
+
+  (* a et b positifs, résultat positif *)
+  let rec pgcd a b =
+    if equal b coef0
+    then a
+    else if lt a b then pgcd b a else pgcd b (modulo a b)
+
+
+  (* signe du pgcd = signe(a)*signe(b) si non nuls. *)
+  let pgcd2 a b =
+    if equal a coef0 then b
+    else if equal b coef0 then a
+    else let c = pgcd (abs a) (abs b) in
+    if ((lt coef0 a)&&(lt b coef0))
+      ||((lt coef0 b)&&(lt a coef0))
+    then opp c else c
+end
+
+(*
+module Ent = struct
+  type t = Entiers.entiers
+  let of_int = Entiers.ent_of_int
+  let of_num x = Entiers.ent_of_string(Num.string_of_num x)
+  let to_num x = Num.num_of_string (Entiers.string_of_ent x)
+  let equal = Entiers.eq_ent
+  let lt = Entiers.lt_ent
+  let le = Entiers.le_ent
+  let abs = Entiers.abs_ent
+  let plus =Entiers.add_ent
+  let mult = Entiers.mult_ent
+  let sub = Entiers.moins_ent
+  let opp = Entiers.opp_ent
+  let div = Entiers.div_ent
+  let modulo = Entiers.mod_ent
+  let coef0 = Entiers.ent0
+  let coef1 = Entiers.ent1
+  let to_string = Entiers.string_of_ent
+  let to_int x = Entiers.int_of_ent x
+  let hash x =Entiers.hash_ent x
+  let signe = Entiers.signe_ent
+
+  let rec puis p n = match n with
+      0 -> coef1
+    |_ -> (mult p (puis p (n-1)))
+
+  (* a et b positifs, résultat positif *)
+  let rec pgcd a b =
+    if equal b coef0
+    then a
+    else if lt a b then pgcd b a else pgcd b (modulo a b)
+
+
+  (* signe du pgcd = signe(a)*signe(b) si non nuls. *)
+  let pgcd2 a b =
+    if equal a coef0 then b
+    else if equal b coef0 then a
+    else let c = pgcd (abs a) (abs b) in
+    if ((lt coef0 a)&&(lt b coef0))
+      ||((lt coef0 b)&&(lt a coef0))
+    then opp c else c
+end
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* ------------------------------------------------------------------------- *)
+
+type vname = string
+
+type term =
+  | Zero
+  | Const of Num.num
+  | Var of vname
+  | Opp of term
+  | Add of term * term
+  | Sub of term * term
+  | Mul of term * term
+  | Pow of term * int
+
+let const n =
+  if eq_num n num_0 then Zero else Const n
+let pow(p,i) = if i=1 then p else Pow(p,i)
+let add = function
+    (Zero,q) -> q
+  | (p,Zero) -> p
+  | (p,q) -> Add(p,q)
+let mul = function
+    (Zero,_) -> Zero
+  | (_,Zero) -> Zero
+  | (p,Const n) when eq_num n num_1 -> p
+  | (Const n,q) when eq_num n num_1 -> q
+  | (p,q) -> Mul(p,q)
+
+let unconstr = mkRel 1
+
+let tpexpr =
+  lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr")
+let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc")
+let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX")
+let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd")
+let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub")
+let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul")
+let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp")
+let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow")
+
+let tlist = lazy (gen_constant "CC" ["Lists";"List"] "list")
+let lnil = lazy (gen_constant "CC" ["Lists";"List"] "nil")
+let lcons = lazy (gen_constant "CC" ["Lists";"List"] "cons")
+
+let tz = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Z")
+let z0 = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Z0")
+let zpos = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Zpos")
+let zneg = lazy(gen_constant "CC" ["ZArith";"BinInt"] "Zneg")
+
+let pxI = lazy(gen_constant "CC" ["NArith";"BinPos"] "xI")
+let pxO = lazy(gen_constant "CC" ["NArith";"BinPos"] "xO")
+let pxH = lazy(gen_constant "CC" ["NArith";"BinPos"] "xH")
+
+let nN0 = lazy (gen_constant "CC" ["NArith";"BinNat"] "N0")
+let nNpos = lazy(gen_constant "CC" ["NArith";"BinNat"] "Npos")
+
+let mkt_app name l =  mkApp (Lazy.force name, Array.of_list l)
+
+let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]]
+let tllp () = mkt_app tlist [tlp()]
+
+let rec mkt_pos n =
+  if n =/ num_1 then Lazy.force pxH
+  else if mod_num n num_2 =/ num_0 then
+    mkt_app pxO [mkt_pos (quo_num n num_2)]
+  else
+    mkt_app pxI [mkt_pos (quo_num n num_2)]
+
+let mkt_n n =
+  if n=num_0
+  then Lazy.force nN0
+  else mkt_app nNpos [mkt_pos n]
+
+let mkt_z z  =
+  if z =/ num_0 then  Lazy.force z0
+  else if z >/ num_0 then
+    mkt_app zpos [mkt_pos z]
+  else
+    mkt_app zneg [mkt_pos ((Int 0) -/ z)]
+
+let rec mkt_term t  =  match t with
+| Zero -> mkt_term (Const num_0)
+| Const r -> let (n,d) = numdom r in
+  mkt_app  ttconst [Lazy.force tz; mkt_z n]
+| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)]
+| Opp t1 -> mkt_app  ttopp [Lazy.force tz; mkt_term t1]
+| Add (t1,t2) -> mkt_app  ttadd [Lazy.force tz; mkt_term t1; mkt_term t2]
+| Sub (t1,t2) -> mkt_app  ttsub [Lazy.force tz; mkt_term t1; mkt_term t2]
+| Mul (t1,t2) -> mkt_app  ttmul [Lazy.force tz; mkt_term t1; mkt_term t2]
+| Pow (t1,n) ->  if (n = 0) then
+    mkt_app ttconst [Lazy.force tz; mkt_z num_1]
+else
+    mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)]
+
+let rec parse_pos p =
+  match kind_of_term p with
+| App (a,[|p2|]) ->
+    if a = Lazy.force pxO then num_2 */ (parse_pos p2)
+    else num_1 +/ (num_2 */ (parse_pos p2))
+| _ -> num_1
+
+let parse_z z =
+  match kind_of_term z with
+| App (a,[|p2|]) ->
+    if a = Lazy.force zpos then parse_pos p2 else (num_0 -/ (parse_pos p2))
+| _ -> num_0
+
+let parse_n z =
+  match kind_of_term z with
+| App (a,[|p2|]) ->
+    parse_pos p2
+| _ -> num_0
+
+let rec parse_term p =
+  match kind_of_term p with
+| App (a,[|_;p2|]) ->
+    if a = Lazy.force ttvar then Var (string_of_num (parse_pos p2))
+    else if a = Lazy.force ttconst then Const (parse_z p2)
+    else if a = Lazy.force ttopp then Opp (parse_term p2)
+    else Zero
+| App (a,[|_;p2;p3|]) ->
+    if a = Lazy.force ttadd then Add (parse_term p2, parse_term p3)
+    else if a = Lazy.force ttsub then Sub (parse_term p2, parse_term p3)
+    else if a = Lazy.force ttmul then Mul (parse_term p2, parse_term p3)
+    else if a = Lazy.force ttpow then
+      Pow (parse_term p2, int_of_num (parse_n p3))
+    else Zero
+| _ -> Zero
+
+let rec parse_request lp =
+  match kind_of_term lp with
+    | App (_,[|_|])  -> []
+    | App (_,[|_;p;lp1|])  ->
+	(parse_term p)::(parse_request lp1)
+    |_-> assert false
+
+let nvars = ref 0
+
+let set_nvars_term t =
+  let rec aux t =
+    match t with
+    | Zero -> ()
+    | Const r -> ()
+    | Var v -> let n = int_of_string v in
+      nvars:= max (!nvars) n
+    | Opp t1 -> aux t1
+    | Add (t1,t2) -> aux t1; aux t2
+    | Sub (t1,t2) -> aux t1; aux t2
+    | Mul (t1,t2) -> aux t1; aux t2
+    | Pow (t1,n) ->  aux t1
+  in aux t
+
+let string_of_term p =
+  let rec aux p =
+    match p with
+    | Zero -> "0"
+    | Const r -> string_of_num r
+    | Var v -> "x"^v
+    | Opp t1 -> "(-"^(aux t1)^")"
+    | Add (t1,t2) -> "("^(aux t1)^"+"^(aux t2)^")"
+    | Sub (t1,t2) ->  "("^(aux t1)^"-"^(aux t2)^")"
+    | Mul (t1,t2) ->  "("^(aux t1)^"*"^(aux t2)^")"
+    | Pow (t1,n) ->  (aux t1)^"^"^(string_of_int n)
+  in aux p
+
+
+(***********************************************************************
+   Coefficients: recursive polynomials
+ *)
+
+module Coef = BigInt
+(*module Coef = Ent*)
+module Poly = Polynom.Make(Coef)
+module PIdeal = Ideal.Make(Poly)
+open PIdeal
+
+(* term to sparse polynomial 
+   varaibles <=np are in the coefficients
+*)
+
+let term_pol_sparse np t=
+  let d = !nvars in
+  let rec aux t =
+    match t with
+    | Zero -> zeroP
+    | Const r ->
+	if r = num_0
+	then zeroP
+	else polconst d (Poly.Pint (Coef.of_num r))
+    | Var v ->
+	let v = int_of_string v in
+	if v <= np
+	then polconst d (Poly.x v)
+	else gen d v
+    | Opp t1 ->  oppP (aux t1)
+    | Add (t1,t2) -> plusP (aux t1) (aux t2)
+    | Sub (t1,t2) -> plusP (aux t1) (oppP (aux t2))
+    | Mul (t1,t2) -> multP (aux t1) (aux t2)
+    | Pow (t1,n) ->  puisP (aux t1) n
+  in (*info ("conversion de: "^(string_of_term t)^"\n");*)
+  let res= aux t in
+  (*info ("donne: "^(stringP res)^"\n");*)
+  res
+
+(* sparse polynomial to term *)
+
+let polrec_to_term p =
+  let rec aux p =
+  match p with
+   |Poly.Pint n -> const (Coef.to_num n)
+   |Poly.Prec (v,coefs) ->
+     let res = ref Zero in
+     Array.iteri
+      (fun i c ->
+	 res:=add(!res, mul(aux c,
+			    pow (Var (string_of_int v),
+				 i))))
+      coefs;
+     !res
+  in aux p
+
+(* approximation of the Horner form used in the tactic ring *)
+
+let pol_sparse_to_term n2 p =
+  info "pol_sparse_to_term ->\n";
+  let p = PIdeal.repr p in
+  let rec aux p =
+    match p with
+      [] -> const (num_of_string "0")
+    | (a,m)::p1 ->
+      let n = (Array.length m)-1 in
+      let (i0,e0) =
+	List.fold_left (fun (r,d) (a,m) ->
+	      let i0= ref 0 in
+	      for k=1 to n do
+		if m.(k)>0
+		then i0:=k
+	      done;
+	      if !i0 = 0
+	      then (r,d)
+	      else if !i0 > r
+	      then (!i0, m.(!i0))
+	      else if !i0 = r && m.(!i0)<d
+	      then (!i0, m.(!i0))
+	      else (r,d))
+	  (0,0)
+	  p in
+      if i0=0
+      then
+	let mp = ref (polrec_to_term a) in
+        if p1=[]
+	then !mp
+	else add(!mp,aux p1)
+      else (
+	let p1=ref [] in
+	let p2=ref [] in
+	List.iter
+	  (fun (a,m) ->
+	     if m.(i0)>=e0
+	     then (m.(i0)<-m.(i0)-e0;
+		   p1:=(a,m)::(!p1))
+	     else p2:=(a,m)::(!p2))
+	  p;
+	let vm =
+	  if e0=1
+	  then Var (string_of_int (i0))
+	  else pow (Var (string_of_int (i0)),e0) in
+	add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2))))
+  in   info "-> pol_sparse_to_term\n";
+  aux p
+
+
+let rec remove_list_tail l i =
+  let rec aux l i =
+    if l=[]
+    then []
+    else if i<0
+    then l
+    else if i=0
+    then List.tl l
+    else
+      match l with
+      |(a::l1) ->
+	  a::(aux l1 (i-1))
+      |_ -> assert false
+  in
+  List.rev (aux (List.rev l) i)
+
+(*
+   lq = [cn+m+1 n+m ...cn+m+1 1]
+   lci=[[cn+1 n,...,cn1 1]
+   ...
+   [cn+m n+m-1,...,cn+m 1]]
+
+   removes intermediate polynomials not useful to compute the last one.
+ *)
+
+let remove_zeros zero lci =
+  let n = List.length (List.hd lci) in
+  let m=List.length lci in
+  let u = Array.create m false in
+  let rec utiles k =
+    if k>=m
+    then ()
+    else (
+      u.(k)<-true;
+      let lc = List.nth lci k in
+      for i=0 to List.length lc - 1 do
+	if not (zero (List.nth lc i))
+	then utiles (i+k+1);
+      done)
+  in utiles 0;
+  let lr = ref [] in
+  for i=0 to m-1 do
+    if u.(i)
+    then lr:=(List.nth lci i)::(!lr)
+  done;
+  let lr=List.rev !lr in
+  let lr = List.map
+      (fun lc ->
+	let lcr=ref lc in
+	for i=0 to m-1 do
+	  if not u.(i)
+	  then lcr:=remove_list_tail !lcr (m-i+(n-m))
+	done;
+	!lcr)
+      lr in
+  info ("unuseful spolynomials: "
+	^string_of_int (m-List.length lr)^"\n");
+  info ("useful spolynomials: "
+	^string_of_int (List.length lr)^"\n");
+  lr
+
+let theoremedeszeros lpol p =
+  let t1 = Unix.gettimeofday() in
+  let m = !nvars in
+  let (lp0,p,cert) = in_ideal m lpol p in
+  let lpc = List.rev !poldepcontent in
+  info ("time: "^Format.sprintf "@[%10.3f@]s\n" (Unix.gettimeofday ()-.t1));
+  (cert,lp0,p,lpc)
+
+open Ideal
+
+let theoremedeszeros_termes lp =
+  nvars:=0;(* mise a jour par term_pol_sparse *)
+  List.iter set_nvars_term  lp;
+  match lp with
+  | Const (Int sugarparam)::Const (Int nparam)::lp ->
+      ((match sugarparam with
+      |0 -> info "calcul sans sugar\n";
+	  lexico:=false;
+	  sugar_flag := false;
+	  divide_rem_with_critical_pair := false
+      |1 -> info "calcul avec sugar\n";
+	  lexico:=false;
+	  sugar_flag := true;
+	  divide_rem_with_critical_pair := false
+      |2 -> info "ordre lexico calcul sans sugar\n";
+	  lexico:=true;
+	  sugar_flag := false;
+	  divide_rem_with_critical_pair := false
+      |3 -> info "ordre lexico calcul avec sugar\n";
+	  lexico:=true;
+	  sugar_flag := true;
+	  divide_rem_with_critical_pair := false
+      |4 -> info "calcul sans sugar, division par les paires\n";
+	  lexico:=false;
+	  sugar_flag := false;
+	  divide_rem_with_critical_pair := true
+      |5 -> info "calcul avec sugar, division par les paires\n";
+	  lexico:=false;
+	  sugar_flag := true;
+	  divide_rem_with_critical_pair := true
+      |6 -> info "ordre lexico calcul sans sugar, division par les paires\n";
+	  lexico:=true;
+	  sugar_flag := false;
+	  divide_rem_with_critical_pair := true
+      |7 -> info "ordre lexico calcul avec sugar, division par les paires\n";
+	  lexico:=true;
+	  sugar_flag := true;
+	  divide_rem_with_critical_pair := true
+      | _ -> error "nsatz: bad parameter"
+       );
+      let m= !nvars in
+      let lvar=ref [] in
+      for i=m downto 1 do lvar:=["x"^(string_of_int i)^""]@(!lvar); done;
+      lvar:=["a";"b";"c";"d";"e";"f";"g";"h";"i";"j";"k";"l";"m";"n";"o";"p";"q";"r";"s";"t";"u";"v";"w";"x";"y";"z"] @ (!lvar); (* pour macaulay *)
+      name_var:=!lvar;
+      let lp = List.map (term_pol_sparse nparam) lp in
+      match lp with
+      | [] -> assert false
+      | p::lp1 ->
+	  let lpol = List.rev lp1 in
+	  let (cert,lp0,p,_lct) = theoremedeszeros lpol p in
+	  let lc = cert.last_comb::List.rev cert.gb_comb in
+	  match remove_zeros (fun x -> x=zeroP) lc with
+	  | [] -> assert false
+	  | (lq::lci) ->
+	      (* lci commence par les nouveaux polynomes *)
+	      let m= !nvars in
+	      let c = pol_sparse_to_term m (polconst m cert.coef) in
+	      let r = Pow(Zero,cert.power) in
+	      let lci = List.rev lci in
+	      let lci = List.map (List.map (pol_sparse_to_term m)) lci in
+	      let lq = List.map (pol_sparse_to_term m) lq in
+	      info ("nombre de parametres: "^string_of_int nparam^"\n");
+	      info "terme calcule\n";
+	      (c,r,lci,lq)
+      )
+  |_ -> assert false
+
+
+(* version avec hash-consing du certificat:
+let nsatz lpol =
+  Hashtbl.clear Dansideal.hmon;
+  Hashtbl.clear Dansideal.coefpoldep;
+  Hashtbl.clear Dansideal.sugartbl;
+  Hashtbl.clear Polynomesrec.hcontentP;
+  init_constants ();
+  let lp= parse_request lpol in
+  let (_lp0,_p,c,r,_lci,_lq as rthz) = theoremedeszeros_termes lp in
+  let certif = certificat_vers_polynome_creux rthz in
+  let certif = hash_certif certif in
+  let certif = certif_term certif in
+  let c = mkt_term c in
+  info "constr calcule\n";
+  (c, certif)
+*)
+
+let nsatz lpol =
+  let lp= parse_request lpol in
+  let (c,r,lci,lq) = theoremedeszeros_termes lp in
+  let res = [c::r::lq]@lci in
+  let res = List.map (fun lx -> List.map mkt_term lx) res in
+  let res =
+    List.fold_right
+      (fun lt r ->
+	 let ltterm =
+	   List.fold_right
+	     (fun t r ->
+		mkt_app lcons [mkt_app tpexpr [Lazy.force tz];t;r])
+	     lt
+	     (mkt_app lnil [mkt_app tpexpr [Lazy.force tz]]) in
+	 mkt_app lcons [tlp ();ltterm;r])
+      res
+      (mkt_app lnil [tlp ()]) in
+  info "terme calcule\n";
+  res
+
+let return_term t =
+  let a =
+    mkApp(gen_constant "CC" ["Init";"Logic"] "refl_equal",[|tllp ();t|]) in
+  generalize [a]
+
+let nsatz_compute t =
+  let lpol =
+    try nsatz t
+    with Ideal.NotInIdeal ->
+      error "nsatz cannot solve this problem" in
+  return_term lpol
+
+TACTIC EXTEND nsatz_compute
+| [ "nsatz_compute"  constr(lt) ] -> [ nsatz_compute lt ]
+END
+
+
diff --git a/plugins/nsatz/nsatz_plugin.mllib b/plugins/nsatz/nsatz_plugin.mllib
new file mode 100644
index 00000000..a25e649d
--- /dev/null
+++ b/plugins/nsatz/nsatz_plugin.mllib
@@ -0,0 +1,5 @@
+Utile
+Polynom
+Ideal
+Nsatz
+Nsatz_plugin_mod
diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml
new file mode 100644
index 00000000..14e279b5
--- /dev/null
+++ b/plugins/nsatz/polynom.ml
@@ -0,0 +1,679 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* Recursive polynomials: R[x1]...[xn]. *)
+open Utile
+open Util
+
+(* 1. Coefficients: R *)
+
+module type Coef = sig
+  type t
+  val equal : t -> t -> bool
+  val lt : t -> t -> bool
+  val le : t -> t -> bool
+  val abs : t -> t
+  val plus : t -> t -> t
+  val mult : t -> t -> t
+  val sub : t -> t -> t
+  val opp : t -> t
+  val div : t -> t -> t
+  val modulo : t -> t -> t
+  val puis : t -> int -> t
+  val pgcd : t -> t -> t
+
+  val hash : t -> int
+  val of_num : Num.num -> t
+  val to_string : t -> string
+end
+
+module type S = sig
+  type coef
+  type variable = int
+  type t = Pint of coef | Prec of variable * t array
+
+  val of_num : Num.num -> t
+  val x : variable -> t
+  val monome : variable -> int -> t
+  val is_constantP : t -> bool
+  val is_zero : t -> bool
+
+  val max_var_pol : t -> variable
+  val max_var_pol2 : t -> variable
+  val max_var : t array -> variable
+  val equal : t -> t -> bool
+  val norm : t -> t
+  val deg : variable -> t -> int
+  val deg_total : t -> int
+  val copyP : t -> t
+  val coef : variable -> int -> t -> t
+
+  val plusP : t -> t -> t
+  val content : t -> coef
+  val div_int : t -> coef -> t
+  val vire_contenu : t -> t
+  val vars : t -> variable list
+  val int_of_Pint : t -> coef
+  val multx : int -> variable -> t -> t
+  val multP : t -> t -> t
+  val deriv : variable -> t -> t
+  val oppP : t -> t
+  val moinsP : t -> t -> t
+  val puisP : t -> int -> t
+  val ( @@ ) : t -> t -> t
+  val ( -- ) : t -> t -> t
+  val ( ^^ ) : t -> int -> t
+  val coefDom : variable -> t -> t
+  val coefConst : variable -> t -> t
+  val remP : variable -> t -> t
+  val coef_int_tete : t -> coef
+  val normc : t -> t
+  val coef_constant : t -> coef
+  val univ : bool ref
+  val string_of_var : int -> string
+  val nsP : int ref
+  val to_string : t -> string
+  val printP : t -> unit
+  val print_tpoly : t array -> unit
+  val print_lpoly : t list -> unit
+  val quo_rem_pol : t -> t -> variable -> t * t
+  val div_pol : t -> t -> variable -> t
+  val divP : t -> t -> t
+  val div_pol_rat : t -> t -> bool
+  val pseudo_div : t -> t -> variable -> t * t * int * t
+  val pgcdP : t -> t -> t
+  val pgcd_pol : t -> t -> variable -> t
+  val content_pol : t -> variable -> t
+  val pgcd_coef_pol : t -> t -> variable -> t
+  val pgcd_pol_rec : t -> t -> variable -> t
+  val gcd_sub_res : t -> t -> variable -> t
+  val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t
+  val lazard_power : t -> t -> int -> variable -> t
+  val hash : t -> int
+  module Hashpol : Hashtbl.S with type key=t
+end
+
+(***********************************************************************
+  2. Type of polynomials, operations.
+*)
+module Make (C:Coef) = struct
+
+type coef = C.t
+let coef_of_int i = C.of_num (Num.Int i)
+let coef0 = coef_of_int 0
+let coef1 = coef_of_int 1
+
+type variable = int
+
+type t =
+    Pint of coef                    (* constant polynomial *)
+  | Prec of variable * (t array)    (* coefficients, increasing degree *)
+
+(* by default, operations work with normalized polynomials:
+- variables are positive integers
+- coefficients of a polynomial in x only use variables < x
+- no zero coefficient at beginning
+- no Prec(x,a) where a is constant in x
+*)
+
+(* constant polynomials *)
+let of_num x = Pint (C.of_num x)
+let cf0 = of_num (Num.Int 0)
+let cf1 = of_num (Num.Int 1)
+
+(* nth variable *)
+let x n = Prec (n,[|cf0;cf1|])
+
+(* create v^n *)
+let monome v n =
+  match n with
+      0->Pint coef1;
+    |_->let tmp = Array.create (n+1) (Pint coef0) in
+        tmp.(n)<-(Pint coef1);
+        Prec (v, tmp)
+
+let is_constantP = function
+    Pint _ -> true
+  | Prec _ -> false
+
+let int_of_Pint = function
+    Pint x -> x
+  | _ -> failwith "non"
+
+let is_zero p =
+  match p with Pint n -> if C.equal n coef0 then true else false |_-> false
+
+let max_var_pol p =
+  match p with
+      Pint _ -> 0
+    |Prec(x,_) -> x
+
+(* p not normalized *)
+let rec max_var_pol2 p =
+  match p with
+      Pint _ -> 0
+    |Prec(v,c)-> Array.fold_right (fun q m -> max (max_var_pol2 q) m) c v
+
+let rec max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0
+
+(* equality between polynomials *)
+
+let rec equal p q =
+  match (p,q) with
+      (Pint a,Pint b) -> C.equal a b
+    |(Prec(x,p1),Prec(y,q1)) ->
+       if x<>y then false
+       else if (Array.length p1)<>(Array.length q1) then false
+       else (try (Array.iteri (fun i a -> if not (equal a q1.(i))
+			       then failwith "raté")
+		    p1;
+		  true)
+	     with _ -> false)
+    | (_,_) -> false
+
+(* normalize polynomial: remove head zeros, coefficients are normalized
+   if constant, returns the coefficient
+*)
+
+let rec norm p = match p with
+    Pint _ -> p
+  |Prec (x,a)->
+     let d = (Array.length a -1) in
+     let n = ref d in
+       while !n>0 && (equal a.(!n) (Pint coef0)) do
+	 n:=!n-1;
+       done;
+       if !n<0 then Pint coef0
+       else if !n=0 then a.(0)
+       else if !n=d then p
+       else (let b=Array.create (!n+1) (Pint coef0) in
+               for i=0 to !n do b.(i)<-a.(i);done;
+               Prec(x,b))
+
+
+(* degree in v, v >= max var of p *)
+let rec deg v p =
+  match p with
+      Prec(x,p1) when x=v -> Array.length p1 -1
+    |_ -> 0
+
+
+(* total degree *)
+let rec deg_total p =
+  match p with
+      Prec (x,p1) -> let d = ref 0 in
+        Array.iteri (fun i q -> d:= (max !d (i+(deg_total q)))) p1;
+        !d
+    |_ -> 0
+
+let rec copyP p =
+  match p with
+      Pint i -> Pint i
+    |Prec(x,q) -> Prec(x,Array.map copyP q)
+
+(* coefficient of degree i in v, v >= max var of p *)
+let coef v i p =
+  match p with
+      Prec (x,p1) when x=v  -> if i<(Array.length p1) then p1.(i) else Pint coef0
+    |_ -> if i=0 then p else Pint coef0
+
+(* addition *)
+
+let rec plusP p q =
+  let res =
+    (match (p,q) with
+	 (Pint a,Pint b) -> Pint (C.plus a b)
+       |(Pint a, Prec (y,q1)) -> let q2=Array.map copyP q1 in
+           q2.(0)<- plusP p q1.(0);
+           Prec (y,q2)
+       |(Prec (x,p1),Pint b) -> let p2=Array.map copyP p1 in
+           p2.(0)<- plusP p1.(0) q;
+           Prec (x,p2)
+       |(Prec (x,p1),Prec (y,q1)) ->
+          if x<y then (let q2=Array.map copyP q1 in
+                         q2.(0)<- plusP p q1.(0);
+                         Prec (y,q2))
+          else if x>y then (let p2=Array.map copyP p1 in
+                              p2.(0)<- plusP p1.(0) q;
+                              Prec (x,p2))
+          else
+            (let n=max (deg x p) (deg x q) in
+             let r=Array.create (n+1) (Pint coef0) in
+               for i=0 to n do
+                 r.(i)<- plusP (coef x i p) (coef x i q);
+               done;
+               Prec(x,r)))
+  in norm res
+
+
+(* content, positive integer *)
+let rec content p =
+  match p with
+      Pint a -> C.abs a
+    | Prec (x ,p1) ->
+       Array.fold_left C.pgcd coef0 (Array.map content p1)
+
+let rec div_int p a=
+  match p with
+      Pint b -> Pint (C.div b a)
+    | Prec(x,p1) -> Prec(x,Array.map (fun x -> div_int x a) p1)
+
+let vire_contenu p =
+  let c = content p in
+    if C.equal c coef0 then p else div_int p c
+
+(* sorted list of variables of a polynomial *)
+
+let rec vars=function
+    Pint _->[]
+  | Prec (x,l)->(List.flatten ([x]::(List.map vars (Array.to_list l))))
+
+
+(* multiply p by v^n, v >= max_var p *)
+let rec multx n v p =
+  match p with
+      Prec (x,p1) when x=v -> let p2= Array.create ((Array.length p1)+n) (Pint coef0) in
+        for i=0 to (Array.length p1)-1 do
+          p2.(i+n)<-p1.(i);
+        done;
+        Prec (x,p2)
+    |_ -> if p = (Pint coef0) then (Pint coef0)
+       else (let p2=Array.create (n+1) (Pint coef0) in
+               p2.(n)<-p;
+               Prec (v,p2))
+
+
+(* product *)
+let rec multP p q =
+  match (p,q) with
+      (Pint a,Pint b) -> Pint (C.mult a b)
+    |(Pint a, Prec (y,q1)) ->
+       if C.equal a coef0 then Pint coef0
+       else let q2 = Array.map (fun z-> multP p z) q1 in
+         Prec (y,q2)
+
+    |(Prec (x,p1), Pint b) ->
+       if C.equal b coef0 then Pint coef0
+       else let p2 = Array.map (fun z-> multP z q) p1 in
+         Prec (x,p2)
+    |(Prec (x,p1), Prec(y,q1)) ->
+       if x<y
+       then (let q2 = Array.map (fun z-> multP p z) q1 in
+               Prec (y,q2))
+       else if x>y
+       then (let p2 = Array.map (fun z-> multP z q) p1 in
+               Prec (x,p2))
+       else Array.fold_left plusP (Pint coef0)
+         (Array.mapi (fun i z-> (multx i x (multP z q))) p1)
+
+
+
+(* derive p with variable v, v >= max_var p *)
+let rec deriv v p =
+  match p with
+      Pint a -> Pint coef0
+    | Prec(x,p1) when x=v ->
+       let d = Array.length p1 -1 in
+         if d=1 then p1.(1)
+         else
+           (let p2 = Array.create d (Pint coef0) in
+              for i=0 to d-1 do
+		p2.(i)<- multP (Pint (coef_of_int (i+1))) p1.(i+1);
+              done;
+              Prec (x,p2))
+    | Prec(x,p1)-> Pint coef0
+
+
+(* opposite *)
+let rec oppP p =
+  match p with
+      Pint a -> Pint (C.opp a)
+    |Prec(x,p1) -> Prec(x,Array.map oppP p1)
+
+let moinsP p q=plusP p (oppP q)
+
+let rec puisP p n = match n with
+    0 -> cf1
+  |_ -> (multP p (puisP p (n-1)))
+
+
+(* infix notations *)
+(*let (++) a b = plusP a b
+*)
+let (@@) a b = multP a b
+
+let (--) a b = moinsP a b
+
+let (^^) a b = puisP a b
+
+
+(* leading coefficient in v,  v>= max_var p *)
+
+let coefDom v p= coef v (deg v p) p
+
+let coefConst v p = coef v 0 p
+
+(* tail of a polynomial *)
+let remP v p =
+  moinsP p (multP (coefDom v p) (puisP (x v) (deg v p)))
+
+
+(* first interger coefficient of p *)
+let rec coef_int_tete p =
+  let v = max_var_pol p in
+    if v>0
+    then coef_int_tete (coefDom v p)
+    else (match p with | Pint a -> a |_ -> assert false)
+
+
+(* divide by the content and make the head int coef positive *)
+let normc p =
+  let p = vire_contenu p in
+  let a = coef_int_tete p in
+    if C.le coef0 a then p else oppP p
+
+
+(* constant coef of normalized polynomial *)
+let rec coef_constant p =
+  match p with
+      Pint a->a
+    |Prec(_,q)->coef_constant q.(0)
+
+
+(***********************************************************************
+  3. Printing polynomials.
+*)
+
+(* if univ = false, we use x,y,z,a,b,c,d... as variables, else x1,x2,...
+*)
+let univ=ref true
+
+let string_of_var x=
+  if !univ then
+    "u"^(string_of_int x)
+  else
+    if x<=3 then String.make 1 (Char.chr(x+(Char.code 'w')))
+    else String.make 1 (Char.chr(x-4+(Char.code 'a')))
+
+let nsP = ref 0
+
+let rec string_of_Pcut p =
+  if (!nsP)<=0
+  then "..."
+  else
+  match p with
+  |Pint a-> nsP:=(!nsP)-1;
+      if C.le coef0 a
+      then C.to_string a
+      else "("^(C.to_string a)^")"
+  |Prec (x,t)->
+      let v=string_of_var x
+      and s=ref ""
+      and sp=ref "" in
+    let st0 = string_of_Pcut t.(0) in
+      if st0<>"0"
+      then s:=st0;
+    let fin = ref false in
+    for i=(Array.length t)-1 downto 1 do
+      if (!nsP)<0
+      then (sp:="...";
+	    if not (!fin) then s:=(!s)^"+"^(!sp);
+	    fin:=true)
+      else (
+	let si=string_of_Pcut  t.(i) in
+	sp:="";
+	if i=1
+	then (
+	  if si<>"0"
+	  then (nsP:=(!nsP)-1;
+		if si="1"
+		then sp:=v
+		else
+		  (if (String.contains si '+')
+		  then sp:="("^si^")*"^v
+		  else sp:=si^"*"^v)))
+	else (
+	  if si<>"0"
+	  then (nsP:=(!nsP)-1;
+		if si="1"
+		then sp:=v^"^"^(string_of_int i)
+		else (if (String.contains si '+')
+		then sp:="("^si^")*"^v^"^"^(string_of_int i)
+		else  sp:=si^"*"^v^"^"^(string_of_int i))));
+	if !sp<>"" && not (!fin)
+	then (nsP:=(!nsP)-1;
+	      if !s=""
+	      then s:=!sp
+	      else s:=(!s)^"+"^(!sp)));
+    done;
+    if !s="" then (nsP:=(!nsP)-1;
+		   (s:="0"));
+    !s
+
+let to_string p =
+  nsP:=20;
+  string_of_Pcut p
+
+let printP p = Format.printf "@[%s@]" (to_string p)
+
+let print_tpoly lp =
+  let s = ref "\n{ " in
+    Array.iter (fun p -> s:=(!s)^(to_string p)^"\n") lp;
+    prt0 ((!s)^"}")
+
+let print_lpoly lp = print_tpoly (Array.of_list lp)
+
+(***********************************************************************
+  4. Exact division of polynomials.
+*)
+
+(* return (s,r) s.t. p = s*q+r *)
+let rec quo_rem_pol p q x =
+  if x=0
+  then (match (p,q) with
+          |(Pint a, Pint b) ->
+	     if C.equal (C.modulo a b) coef0
+             then (Pint (C.div a b), cf0)
+             else failwith "div_pol1"
+	  |_ -> assert false)
+  else
+    let m = deg x q in
+    let b = coefDom x q in
+    let q1 = remP x q in (* q = b*x^m+q1 *)
+    let r = ref p in
+    let s = ref cf0 in
+    let continue =ref true in
+      while (!continue) && (not (equal !r cf0)) do
+	let n = deg x !r in
+	  if n<m
+	  then continue:=false
+	  else (
+            let a = coefDom x !r in
+            let p1 = remP x !r in  (* r = a*x^n+p1 *)
+            let c = div_pol a b (x-1) in  (* a = c*b *)
+	    let s1 = c @@ ((monome x (n-m))) in
+              s:= plusP (!s) s1;
+              r:= p1 -- (s1 @@ q1);
+          )
+      done;
+      (!s,!r)
+
+(* returns quotient p/q if q divides p, else fails *)
+and div_pol p q x =
+  let (s,r) = quo_rem_pol p q x in
+    if equal r cf0
+    then s
+    else  failwith ("div_pol:\n"
+		   ^"p:"^(to_string p)^"\n"
+		   ^"q:"^(to_string q)^"\n"
+		   ^"r:"^(to_string r)^"\n"
+		   ^"x:"^(string_of_int x)^"\n"
+		   )
+let divP p q=
+  let x = max (max_var_pol p) (max_var_pol q) in
+  div_pol p q x
+
+let div_pol_rat p q=
+  let x = max (max_var_pol p) (max_var_pol q) in
+    try (let s = div_pol (multP p (puisP (Pint(coef_int_tete q))
+				     (1+(deg x p) - (deg x q))))
+		   q x in
+         (* degueulasse, mais c 'est pour enlever un warning *)
+         if s==s then true else true)
+    with _ -> false
+
+(***********************************************************************
+  5. Pseudo-division and gcd with subresultants.
+*)
+
+(* pseudo division :
+   q = c*x^m+q1
+   retruns (r,c,d,s) s.t. c^d*p = s*q + r.
+*)
+
+let pseudo_div p q x =
+  match q with
+      Pint _ -> (cf0, q,1, p)
+    | Prec (v,q1) when x<>v -> (cf0, q,1, p)
+    | Prec (v,q1) ->
+	(
+	  (*  pr "pseudo_division: c^d*p = s*q + r";*)
+	  let delta = ref 0 in
+	  let r = ref p in
+	  let c = coefDom x q in
+	  let q1 = remP x q in
+	  let d' = deg x q in
+	  let s = ref cf0 in
+	    while (deg x !r)>=(deg x q) do
+	      let d = deg x !r in
+	      let a = coefDom x !r in
+	      let r1=remP x !r in
+	      let u = a @@ ((monome x (d-d'))) in
+		r:=(c @@ r1) -- (u @@ q1);
+		s:=plusP (c @@ (!s)) u;
+		delta := (!delta) + 1;
+	    done;
+	    (*
+	      pr ("deg d: "^(string_of_int (!delta))^", deg c: "^(string_of_int (deg_total c)));
+	      pr ("deg r:"^(string_of_int (deg_total !r)));
+	    *)
+	    (!r,c,!delta, !s)
+	)
+
+(* gcd with subresultants *)
+
+let rec pgcdP p q =
+  let x = max (max_var_pol p) (max_var_pol q) in
+    pgcd_pol p q x
+
+and pgcd_pol p q x =
+  pgcd_pol_rec p q x
+
+and content_pol p x =
+  match p with
+      Prec(v,p1) when v=x ->
+        Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) cf0 p1
+    | _ -> p
+
+and pgcd_coef_pol c p x =
+  match p with
+      Prec(v,p1) when x=v ->
+        Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) c  p1
+    |_ -> pgcd_pol_rec c p (x-1)
+
+and pgcd_pol_rec p q x =
+ match (p,q) with
+	(Pint a,Pint b) -> Pint (C.pgcd (C.abs a) (C.abs b))
+      |_ ->
+	  if equal p cf0
+	  then q
+	  else if equal q cf0
+	  then p
+	  else if (deg x q) = 0
+	  then pgcd_coef_pol q p x
+	  else if (deg x p) = 0
+	  then pgcd_coef_pol p q x
+	  else (
+	    let a = content_pol p x in
+	    let b = content_pol q x in
+	    let c = pgcd_pol_rec a b (x-1) in
+	    pr (string_of_int x);
+	    let p1 = div_pol p c x in
+	    let q1 = div_pol q c x in
+	    let r = gcd_sub_res p1 q1 x in
+	    let cr = content_pol r x in
+	    let res = c @@ (div_pol r cr x) in
+	    res
+	   )
+
+(* Sub-résultants:
+
+   ai*Ai = Qi*Ai+1 + bi*Ai+2
+
+   deg Ai+2 < deg Ai+1
+
+   Ai = ci*X^ni + ...
+   di = ni - ni+1
+
+   ai = (- ci+1)^(di + 1)
+   b1 = 1
+   bi = ci*si^di  si i>1
+
+   s1 = 1
+   si+1 = ((ci+1)^di*si)/si^di
+
+*)
+and gcd_sub_res p q x =
+  if equal q cf0
+  then p
+  else
+    let d = deg x p in
+    let d' = deg x q in
+      if d<d'
+      then gcd_sub_res q p x
+      else
+	let delta = d-d' in
+	let c' = coefDom x q in
+	let r = snd (quo_rem_pol (((oppP c')^^(delta+1))@@p) (oppP q) x) in
+	  gcd_sub_res_rec q r (c'^^delta) c' d' x
+
+and gcd_sub_res_rec p q s c d x =
+  if equal q cf0
+  then p
+  else (
+    let d' = deg x q in
+    let c' = coefDom x q in
+    let delta = d-d' in
+    let r = snd (quo_rem_pol (((oppP c')^^(delta+1))@@p) (oppP q) x) in
+    let s'= lazard_power c' s delta x in
+      gcd_sub_res_rec q (div_pol r (c @@ (s^^delta)) x) s' c' d' x
+  )
+
+and lazard_power c s d x =
+  let res = ref c in
+    for i=1 to d-1 do
+      res:= div_pol ((!res)@@c) s x;
+    done;
+    !res
+
+(* memoizations *)
+
+let rec hash = function
+    Pint a -> (C.hash a)
+  | Prec (v,p) ->
+      Array.fold_right (fun q h -> h + hash q) p 0
+
+module Hashpol = Hashtbl.Make(
+  struct
+    type poly = t
+    type t = poly
+    let equal = equal
+    let hash = hash
+  end)
+
+end
diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli
new file mode 100644
index 00000000..623d901e
--- /dev/null
+++ b/plugins/nsatz/polynom.mli
@@ -0,0 +1,97 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* Building recursive polynom operations from a type of coefficients *)
+
+module type Coef = sig
+  type t
+  val equal : t -> t -> bool
+  val lt : t -> t -> bool
+  val le : t -> t -> bool
+  val abs : t -> t
+  val plus : t -> t -> t
+  val mult : t -> t -> t
+  val sub : t -> t -> t
+  val opp : t -> t
+  val div : t -> t -> t
+  val modulo : t -> t -> t
+  val puis : t -> int -> t
+  val pgcd : t -> t -> t
+
+  val hash : t -> int
+  val of_num : Num.num -> t
+  val to_string : t -> string
+end
+
+module type S = sig
+  type coef
+  type variable = int
+  type t = Pint of coef | Prec of variable * t array
+
+  val of_num : Num.num -> t
+  val x : variable -> t
+  val monome : variable -> int -> t
+  val is_constantP : t -> bool
+  val is_zero : t -> bool
+
+  val max_var_pol : t -> variable
+  val max_var_pol2 : t -> variable
+  val max_var : t array -> variable
+  val equal : t -> t -> bool
+  val norm : t -> t
+  val deg : variable -> t -> int
+  val deg_total : t -> int
+  val copyP : t -> t
+  val coef : variable -> int -> t -> t
+
+  val plusP : t -> t -> t
+  val content : t -> coef
+  val div_int : t -> coef -> t
+  val vire_contenu : t -> t
+  val vars : t -> variable list
+  val int_of_Pint : t -> coef
+  val multx : int -> variable -> t -> t
+  val multP : t -> t -> t
+  val deriv : variable -> t -> t
+  val oppP : t -> t
+  val moinsP : t -> t -> t
+  val puisP : t -> int -> t
+  val ( @@ ) : t -> t -> t
+  val ( -- ) : t -> t -> t
+  val ( ^^ ) : t -> int -> t
+  val coefDom : variable -> t -> t
+  val coefConst : variable -> t -> t
+  val remP : variable -> t -> t
+  val coef_int_tete : t -> coef
+  val normc : t -> t
+  val coef_constant : t -> coef
+  val univ : bool ref
+  val string_of_var : int -> string
+  val nsP : int ref
+  val to_string : t -> string
+  val printP : t -> unit
+  val print_tpoly : t array -> unit
+  val print_lpoly : t list -> unit
+  val quo_rem_pol : t -> t -> variable -> t * t
+  val div_pol : t -> t -> variable -> t
+  val divP : t -> t -> t
+  val div_pol_rat : t -> t -> bool
+  val pseudo_div : t -> t -> variable -> t * t * int * t
+  val pgcdP : t -> t -> t
+  val pgcd_pol : t -> t -> variable -> t
+  val content_pol : t -> variable -> t
+  val pgcd_coef_pol : t -> t -> variable -> t
+  val pgcd_pol_rec : t -> t -> variable -> t
+  val gcd_sub_res : t -> t -> variable -> t
+  val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t
+  val lazard_power : t -> t -> int -> variable -> t
+  val hash : t -> int
+  module Hashpol : Hashtbl.S with type key=t
+end
+
+module Make (C:Coef) : S with type coef = C.t
diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml
new file mode 100644
index 00000000..c16bd425
--- /dev/null
+++ b/plugins/nsatz/utile.ml
@@ -0,0 +1,130 @@
+(* Printing *)
+
+let pr x =
+  if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else ()
+
+let prn x =
+  if !Flags.debug then (Format.printf "@[%s\n@]" x; flush(stdout);) else ()
+
+let prt0 s = () (* print_string s;flush(stdout)*)
+
+let prt s =
+  if !Flags.debug then (print_string (s^"\n");flush(stdout)) else ()
+
+let info s =
+  Flags.if_verbose prerr_string s
+
+(* Lists *)
+
+let rec list_mem_eq eq x l =
+  match l with
+    [] -> false
+   |y::l1 -> if (eq x y) then true else (list_mem_eq eq x l1)
+
+let set_of_list_eq eq l =
+   let res = ref [] in
+   List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l;
+   List.rev !res
+
+
+(* Memoization
+   f is compatible with nf: f(nf(x)) = f(x)
+*)
+
+let memos s memoire nf f x =
+   try (let v = Hashtbl.find memoire (nf x) in pr s;v)
+   with _ -> (pr "#";
+	      let v = f x in
+	      Hashtbl.add memoire (nf x) v;
+	      v)
+
+
+(**********************************************************************
+  Eléments minimaux pour un ordre partiel de division.
+  E est un ensemble, avec une multiplication
+  et une division partielle div (la fonction div peut échouer),
+  constant est un prédicat qui définit un sous-ensemble C de E.
+*)
+(*
+  Etant donnée une partie A de E, on calcule une partie B de E disjointe de C
+  telle que:
+    - les éléments de A sont des produits d'éléments de B et d'un de C.
+    - B est minimale pour cette propriété.
+*)
+
+let facteurs_liste div constant lp =
+   let lp = List.filter (fun x -> not (constant x)) lp in
+   let rec factor lmin lp = (* lmin: ne se divisent pas entre eux *)
+      match lp with
+        [] -> lmin
+       |p::lp1 ->
+         (let l1 = ref [] in
+          let p_dans_lmin = ref false in
+          List.iter (fun q -> try (let r = div p q in
+                                   if not (constant r)
+				   then l1:=r::(!l1)
+                                   else p_dans_lmin:=true)
+			      with _ -> ())
+                     lmin;
+          if !p_dans_lmin
+          then factor lmin lp1
+          else if (!l1)=[]
+          (* aucun q de lmin ne divise p *)
+          then (let l1=ref lp1 in
+		let lmin1=ref [] in
+                List.iter (fun q -> try (let r = div q p in
+					 if not (constant r)
+					 then l1:=r::(!l1))
+				    with _ -> lmin1:=q::(!lmin1))
+                          lmin;
+	        factor (List.rev (p::(!lmin1))) !l1)
+          (* au moins un q de lmin divise p non trivialement *)
+          else factor lmin ((!l1)@lp1))
+    in
+    factor [] lp
+
+
+(* On suppose que tout élément de A est produit d'éléments de B et d'un de C:
+   A et B sont deux tableaux,  rend un tableau de couples
+      (élément de C, listes d'indices l)
+   tels que A.(i) = l.(i)_1*Produit(B.(j), j dans l.(i)_2)
+   zero est un prédicat sur E tel que (zero x) => (constant x):
+         si (zero x) est vrai on ne decompose pas x
+   c est un élément quelconque de E.
+*)
+let factorise_tableau div zero c f l1 =
+    let res = Array.create (Array.length f) (c,[]) in
+    Array.iteri (fun i p ->
+      let r = ref p in
+      let li = ref [] in
+      if not (zero p)
+      then
+      Array.iteri (fun j q ->
+	              try (while true do
+                               let rr = div !r q in
+      	                       li:=j::(!li);
+                               r:=rr;
+			   done)
+                      with _ -> ())
+                  l1;
+      res.(i)<-(!r,!li))
+     f;
+    (l1,res)
+
+
+(* exemples:
+
+let l =  [1;2;6;24;720]
+and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div")
+and constant = (fun x -> x<2)
+and zero = (fun x -> x=0)
+
+
+let f = facteurs_liste div1 constant l
+
+
+factorise_tableau div1 zero 0 (Array.of_list l) (Array.of_list f)
+
+*)
+
+
diff --git a/plugins/nsatz/utile.mli b/plugins/nsatz/utile.mli
new file mode 100644
index 00000000..83b2ac39
--- /dev/null
+++ b/plugins/nsatz/utile.mli
@@ -0,0 +1,22 @@
+
+(* Printing *)
+val pr : string -> unit
+val prn : string -> unit
+val prt0 : 'a -> unit
+val prt : string -> unit
+val info : string -> unit
+
+(* Listes *)
+val list_mem_eq : ('a -> 'b -> bool) -> 'a -> 'b list -> bool
+val set_of_list_eq : ('a -> 'a -> bool) -> 'a list -> 'a list
+
+(* Memoization *)
+val memos :
+  string -> ('a, 'b) Hashtbl.t -> ('c -> 'a) -> ('c -> 'b) -> 'c -> 'b
+
+
+val facteurs_liste : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a list -> 'a list
+val factorise_tableau :
+  ('a -> 'b -> 'a) ->
+  ('a -> bool) ->
+  'a -> 'a array -> 'b array -> 'b array * ('a * int list) array
diff --git a/plugins/nsatz/vo.itarget b/plugins/nsatz/vo.itarget
new file mode 100644
index 00000000..4af4786d
--- /dev/null
+++ b/plugins/nsatz/vo.itarget
@@ -0,0 +1,3 @@
+NsatzR.vo
+Nsatz_domain.vo
+NsatzZ.vo
diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v
new file mode 100644
index 00000000..30b94571
--- /dev/null
+++ b/plugins/omega/Omega.v
@@ -0,0 +1,59 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(**************************************************************************)
+(*                                                                        *)
+(* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
+(*                                                                        *)
+(* Pierre Crégut (CNET, Lannion, France)                                  *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id$ *)
+
+(* We do not require [ZArith] anymore, but only what's necessary for Omega *)
+Require Export ZArith_base.
+Require Export OmegaLemmas.
+Require Export PreOmega.
+Declare ML Module "omega_plugin".
+
+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/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v
new file mode 100644
index 00000000..56a854d6
--- /dev/null
+++ b/plugins/omega/OmegaLemmas.v
@@ -0,0 +1,302 @@
+(***********************************************************************)
+(*  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$ 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/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v
new file mode 100644
index 00000000..21535f0d
--- /dev/null
+++ b/plugins/omega/OmegaPlugin.v
@@ -0,0 +1,11 @@
+(************************************************************************)
+(*  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$ *)
+
+Declare ML Module "omega_plugin".
diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v
new file mode 100644
index 00000000..a5a085a9
--- /dev/null
+++ b/plugins/omega/PreOmega.v
@@ -0,0 +1,445 @@
+Require Import Arith Max Min ZArith_base NArith Nnat.
+
+Open Local Scope Z_scope.
+
+
+(** * zify: the Z-ification tactic *)
+
+(* This tactic searches for nat and N and positive elements in the goal and
+   translates everything into Z. It is meant as a pre-processor for
+   (r)omega; for instance a positivity hypothesis is added whenever
+     - a multiplication is encountered
+     - an atom is encountered (that is a variable or an unknown construct)
+
+   Recognized relations (can be handled as deeply as allowed by setoid rewrite):
+     - { eq, le, lt, ge, gt } on { Z, positive, N, nat }
+
+   Recognized operations:
+     - on Z: Zmin, Zmax, Zabs, Zsgn are translated in term of <= < =
+     - on nat: + * - S O pred min max nat_of_P nat_of_N Zabs_nat
+     - on positive: Zneg Zpos xI xO xH + * - Psucc Ppred Pmin Pmax P_of_succ_nat
+     - on N: N0 Npos + * - Nsucc Nmin Nmax N_of_nat Zabs_N
+*)
+
+
+
+
+(** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *)
+
+Ltac zify_unop_core t thm a :=
+ (* Let's introduce the specification theorem for t *)
+ let H:= fresh "H" in assert (H:=thm a);
+ (* Then we replace (t a) everywhere with a fresh variable *)
+ let z := fresh "z" in set (z:=t a) in *; clearbody z.
+
+Ltac zify_unop_var_or_term t thm a :=
+ (* If a is a variable, no need for aliasing *)
+ let za := fresh "z" in
+ (rename a into za; rename za into a; zify_unop_core t thm a) ||
+ (* Otherwise, a is a complex term: we alias it. *)
+ (remember a as za; zify_unop_core t thm za).
+
+Ltac zify_unop t thm a :=
+ (* if a is a scalar, we can simply reduce the unop *)
+ let isz := isZcst a in
+ match isz with
+  | true => simpl (t a) in *
+  | _ => zify_unop_var_or_term t thm a
+ end.
+
+Ltac zify_unop_nored t thm a :=
+ (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *)
+ let isz := isZcst a in
+ match isz with
+  | true => zify_unop_core t thm a
+  | _ => zify_unop_var_or_term t thm a
+ end.
+
+Ltac zify_binop t thm a b:=
+ (* works as zify_unop, except that we should be careful when
+    dealing with b, since it can be equal to a *)
+ let isza := isZcst a in
+ match isza with
+   | true => zify_unop (t a) (thm a) b
+   | _ =>
+       let za := fresh "z" in
+       (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) ||
+       (remember a as za; match goal with
+         | H : za = b |- _ => zify_unop_nored (t za) (thm za) za
+         | _ => zify_unop_nored (t za) (thm za) b
+        end)
+ end.
+
+Ltac zify_op_1 :=
+  match goal with
+   | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b
+   | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b
+   | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b
+   | H : context [ Zmin ?a ?b ] |- _ => zify_binop Zmin Zmin_spec a b
+   | |- context [ Zsgn ?a ] => zify_unop Zsgn Zsgn_spec a
+   | H : context [ Zsgn ?a ] |- _ => zify_unop Zsgn Zsgn_spec a
+   | |- context [ Zabs ?a ] => zify_unop Zabs Zabs_spec a
+   | H : context [ Zabs ?a ] |- _ => zify_unop Zabs Zabs_spec a
+  end.
+
+Ltac zify_op := repeat zify_op_1.
+
+
+
+
+
+(** II) Conversion from nat to Z *)
+
+
+Definition Z_of_nat' := Z_of_nat.
+
+Ltac hide_Z_of_nat t :=
+  let z := fresh "z" in set (z:=Z_of_nat t) in *;
+  change Z_of_nat with Z_of_nat' in z;
+  unfold z in *; clear z.
+
+Ltac zify_nat_rel :=
+ match goal with
+  (* I: equalities *)
+  | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H
+  | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b)
+  | H : context [ @eq nat ?a ?b ] |- _ => rewrite (inj_eq_iff a b) in H
+  | |- context [ @eq nat ?a ?b ] =>       rewrite (inj_eq_iff a b)
+  (* II: less than *)
+  | H : (lt ?a ?b) |- _ => generalize (inj_lt _ _ H); clear H; intro H
+  | |- (lt ?a ?b) => apply (inj_lt_rev a b)
+  | H : context [ lt ?a ?b ] |- _ => rewrite (inj_lt_iff a b) in H
+  | |- context [ lt ?a ?b ] =>       rewrite (inj_lt_iff a b)
+  (* III: less or equal *)
+  | H : (le ?a ?b) |- _ => generalize (inj_le _ _ H); clear H; intro H
+  | |- (le ?a ?b) => apply (inj_le_rev a b)
+  | H : context [ le ?a ?b ] |- _ => rewrite (inj_le_iff a b) in H
+  | |- context [ le ?a ?b ] =>       rewrite (inj_le_iff a b)
+  (* IV: greater than *)
+  | H : (gt ?a ?b) |- _ => generalize (inj_gt _ _ H); clear H; intro H
+  | |- (gt ?a ?b) => apply (inj_gt_rev a b)
+  | H : context [ gt ?a ?b ] |- _ => rewrite (inj_gt_iff a b) in H
+  | |- context [ gt ?a ?b ] =>       rewrite (inj_gt_iff a b)
+  (* V: greater or equal *)
+  | H : (ge ?a ?b) |- _ => generalize (inj_ge _ _ H); clear H; intro H
+  | |- (ge ?a ?b) => apply (inj_ge_rev a b)
+  | H : context [ ge ?a ?b ] |- _ => rewrite (inj_ge_iff a b) in H
+  | |- context [ ge ?a ?b ] =>       rewrite (inj_ge_iff a b)
+ end.
+
+Ltac zify_nat_op :=
+ match goal with
+  (* misc type conversions: positive/N/Z to nat *)
+  | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H
+  | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a)
+  | H : context [ Z_of_nat (nat_of_N ?a) ] |- _ => rewrite (Z_of_nat_of_N a) in H
+  | |- context [ Z_of_nat (nat_of_N ?a) ] => rewrite (Z_of_nat_of_N a)
+  | H : context [ Z_of_nat (Zabs_nat ?a) ] |- _ => rewrite (inj_Zabs_nat a) in H
+  | |- context [ Z_of_nat (Zabs_nat ?a) ] => rewrite (inj_Zabs_nat a)
+
+  (* plus -> Zplus *)
+  | H : context [ Z_of_nat (plus ?a ?b) ] |- _ => rewrite (inj_plus a b) in H
+  | |- context [ Z_of_nat (plus ?a ?b) ] => rewrite (inj_plus a b)
+
+  (* min -> Zmin *)
+  | H : context [ Z_of_nat (min ?a ?b) ] |- _ => rewrite (inj_min a b) in H
+  | |- context [ Z_of_nat (min ?a ?b) ] => rewrite (inj_min a b)
+
+  (* max -> Zmax *)
+  | H : context [ Z_of_nat (max ?a ?b) ] |- _ => rewrite (inj_max a b) in H
+  | |- context [ Z_of_nat (max ?a ?b) ] => rewrite (inj_max a b)
+
+  (* minus -> Zmax (Zminus ... ...) 0 *)
+  | H : context [ Z_of_nat (minus ?a ?b) ] |- _ => rewrite (inj_minus a b) in H
+  | |- context [ Z_of_nat (minus ?a ?b) ] => rewrite (inj_minus a b)
+
+  (* pred -> minus ... -1 -> Zmax (Zminus ... -1) 0 *)
+  | H : context [ Z_of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H
+  | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a)
+
+  (* mult -> Zmult and a positivity hypothesis *)
+  | H : context [ Z_of_nat (mult ?a ?b) ] |- _ =>
+        let H:= fresh "H" in
+        assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
+  | |- context [ Z_of_nat (mult ?a ?b) ] =>
+        let H:= fresh "H" in
+        assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
+
+  (* O -> Z0 *)
+  | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H
+  | |- context [ Z_of_nat O ] => simpl (Z_of_nat O)
+
+  (* S -> number or Zsucc *)
+  | H : context [ Z_of_nat (S ?a) ] |- _ =>
+     let isnat := isnatcst a in
+     match isnat with
+      | true => simpl (Z_of_nat (S a)) in H
+      | _ => rewrite (inj_S a) in H
+     end
+  | |- context [ Z_of_nat (S ?a) ] =>
+     let isnat := isnatcst a in
+     match isnat with
+      | true => simpl (Z_of_nat (S a))
+      | _ => rewrite (inj_S a)
+     end
+
+  (* atoms of type nat : we add a positivity condition (if not already there) *)
+  | H : context [ Z_of_nat ?a ] |- _ =>
+        match goal with
+          | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a
+          | H' : 0 <= Z_of_nat' a |- _ => fail
+          | _ => let H:= fresh "H" in
+                 assert (H:=Zle_0_nat a); hide_Z_of_nat a
+        end
+  | |- context [ Z_of_nat ?a ] =>
+        match goal with
+          | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a
+          | H' : 0 <= Z_of_nat' a |- _ => fail
+          | _ => let H:= fresh "H" in
+                 assert (H:=Zle_0_nat a); hide_Z_of_nat a
+        end
+ end.
+
+Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *.
+
+
+
+
+(* III) conversion from positive to Z *)
+
+Definition Zpos' := Zpos.
+Definition Zneg' := Zneg.
+
+Ltac hide_Zpos t :=
+  let z := fresh "z" in set (z:=Zpos t) in *;
+  change Zpos with Zpos' in z;
+  unfold z in *; clear z.
+
+Ltac zify_positive_rel :=
+ match goal with
+  (* I: equalities *)
+  | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H
+  | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b)
+  | H : context [ @eq positive ?a ?b ] |- _ => rewrite (Zpos_eq_iff a b) in H
+  | |- context [ @eq positive ?a ?b ] =>       rewrite (Zpos_eq_iff a b)
+  (* II: less than *)
+  | H : context [ (?a<?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H
+  | |- context [ (?a<?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b)
+  (* III: less or equal *)
+  | H : context [ (?a<=?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H
+  | |- context [ (?a<=?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b)
+  (* IV: greater than *)
+  | H : context [ (?a>?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H
+  | |- context [ (?a>?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b)
+  (* V: greater or equal *)
+  | H : context [ (?a>=?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H
+  | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b)
+ end.
+
+Ltac zify_positive_op :=
+ match goal with
+  (* Zneg -> -Zpos (except for numbers) *)
+  | H : context [ Zneg ?a ] |- _ =>
+     let isp := isPcst a in
+     match isp with
+      | true => change (Zneg a) with (Zneg' a) in H
+      | _ => change (Zneg a) with (- Zpos a) in H
+     end
+  | |- context [ Zneg ?a ] =>
+     let isp := isPcst a in
+     match isp with
+      | true => change (Zneg a) with (Zneg' a)
+      | _ => change (Zneg a) with (- Zpos a)
+     end
+
+  (* misc type conversions: nat to positive *)
+  | H : context [ Zpos (P_of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H
+  | |- context [ Zpos (P_of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a)
+
+  (* Pplus -> Zplus *)
+  | H : context [ Zpos (Pplus ?a ?b) ] |- _ => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) in H
+  | |- context [ Zpos (Pplus ?a ?b) ] => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b))
+
+  (* Pmin -> Zmin *)
+  | H : context [ Zpos (Pmin ?a ?b) ] |- _ => rewrite (Zpos_min a b) in H
+  | |- context [ Zpos (Pmin ?a ?b) ] => rewrite (Zpos_min a b)
+
+  (* Pmax -> Zmax *)
+  | H : context [ Zpos (Pmax ?a ?b) ] |- _ => rewrite (Zpos_max a b) in H
+  | |- context [ Zpos (Pmax ?a ?b) ] => rewrite (Zpos_max a b)
+
+  (* Pminus -> Zmax 1 (Zminus ... ...) *)
+  | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H
+  | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b)
+
+  (* Psucc -> Zsucc *)
+  | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H
+  | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a)
+
+  (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *)
+  | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H
+  | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a)
+
+  (* Pmult -> Zmult and a positivity hypothesis *)
+  | H : context [ Zpos (Pmult ?a ?b) ] |- _ =>
+        let H:= fresh "H" in
+        assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *
+  | |- context [ Zpos (Pmult ?a ?b) ] =>
+        let H:= fresh "H" in
+        assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *
+
+  (* xO *)
+  | H : context [ Zpos (xO ?a) ] |- _ =>
+     let isp := isPcst a in
+     match isp with
+      | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H
+      | _ => rewrite (Zpos_xO a) in H
+     end
+  | |- context [ Zpos (xO ?a) ] =>
+     let isp := isPcst a in
+     match isp with
+      | true => change (Zpos (xO a)) with (Zpos' (xO a))
+      | _ => rewrite (Zpos_xO a)
+     end
+  (* xI *)
+  | H : context [ Zpos (xI ?a) ] |- _ =>
+     let isp := isPcst a in
+     match isp with
+      | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H
+      | _ => rewrite (Zpos_xI a) in H
+     end
+  | |- context [ Zpos (xI ?a) ] =>
+     let isp := isPcst a in
+     match isp with
+      | true => change (Zpos (xI a)) with (Zpos' (xI a))
+      | _ => rewrite (Zpos_xI a)
+     end
+
+  (* xI : nothing to do, just prevent adding a useless positivity condition *)
+  | H : context [ Zpos xH ] |- _ => hide_Zpos xH
+  | |- context [ Zpos xH ] => hide_Zpos xH
+
+  (* atoms of type positive : we add a positivity condition (if not already there) *)
+  | H : context [ Zpos ?a ] |- _ =>
+        match goal with
+         | H' : Zpos a > 0 |- _ => hide_Zpos a
+         | H' : Zpos' a > 0 |- _ => fail
+         | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a
+        end
+  | |- context [ Zpos ?a ] =>
+        match goal with
+         | H' : Zpos a > 0 |- _ => hide_Zpos a
+         | H' : Zpos' a > 0 |- _ => fail
+         | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a
+        end
+ end.
+
+Ltac zify_positive :=
+ repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *.
+
+
+
+
+
+(* IV) conversion from N to Z *)
+
+Definition Z_of_N' := Z_of_N.
+
+Ltac hide_Z_of_N t :=
+  let z := fresh "z" in set (z:=Z_of_N t) in *;
+  change Z_of_N with Z_of_N' in z;
+  unfold z in *; clear z.
+
+Ltac zify_N_rel :=
+ match goal with
+  (* I: equalities *)
+  | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H
+  | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b)
+  | H : context [ @eq N ?a ?b ] |- _ => rewrite (Z_of_N_eq_iff a b) in H
+  | |- context [ @eq N ?a ?b ] =>       rewrite (Z_of_N_eq_iff a b)
+  (* II: less than *)
+  | H : (?a<?b)%N |- _ => generalize (Z_of_N_lt _ _ H); clear H; intro H
+  | |- (?a<?b)%N => apply (Z_of_N_lt_rev a b)
+  | H : context [ (?a<?b)%N ] |- _ => rewrite (Z_of_N_lt_iff a b) in H
+  | |- context [ (?a<?b)%N ] =>       rewrite (Z_of_N_lt_iff a b)
+  (* III: less or equal *)
+  | H : (?a<=?b)%N |- _ => generalize (Z_of_N_le _ _ H); clear H; intro H
+  | |- (?a<=?b)%N => apply (Z_of_N_le_rev a b)
+  | H : context [ (?a<=?b)%N ] |- _ => rewrite (Z_of_N_le_iff a b) in H
+  | |- context [ (?a<=?b)%N ] =>       rewrite (Z_of_N_le_iff a b)
+  (* IV: greater than *)
+  | H : (?a>?b)%N |- _ => generalize (Z_of_N_gt _ _ H); clear H; intro H
+  | |- (?a>?b)%N => apply (Z_of_N_gt_rev a b)
+  | H : context [ (?a>?b)%N ] |- _ => rewrite (Z_of_N_gt_iff a b) in H
+  | |- context [ (?a>?b)%N ] =>       rewrite (Z_of_N_gt_iff a b)
+  (* V: greater or equal *)
+  | H : (?a>=?b)%N |- _ => generalize (Z_of_N_ge _ _ H); clear H; intro H
+  | |- (?a>=?b)%N => apply (Z_of_N_ge_rev a b)
+  | H : context [ (?a>=?b)%N ] |- _ => rewrite (Z_of_N_ge_iff a b) in H
+  | |- context [ (?a>=?b)%N ] =>       rewrite (Z_of_N_ge_iff a b)
+ end.
+
+Ltac zify_N_op :=
+ match goal with
+  (* misc type conversions: nat to positive *)
+  | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H
+  | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a)
+  | H : context [ Z_of_N (Zabs_N ?a) ] |- _ => rewrite (Z_of_N_abs a) in H
+  | |- context [ Z_of_N (Zabs_N ?a) ] => rewrite (Z_of_N_abs a)
+  | H : context [ Z_of_N (Npos ?a) ] |- _ => rewrite (Z_of_N_pos a) in H
+  | |- context [ Z_of_N (Npos ?a) ] => rewrite (Z_of_N_pos a)
+  | H : context [ Z_of_N N0 ] |- _ => change (Z_of_N N0) with Z0 in H
+  | |- context [ Z_of_N N0 ] => change (Z_of_N N0) with Z0
+
+  (* Nplus -> Zplus *)
+  | H : context [ Z_of_N (Nplus ?a ?b) ] |- _ => rewrite (Z_of_N_plus a b) in H
+  | |- context [ Z_of_N (Nplus ?a ?b) ] => rewrite (Z_of_N_plus a b)
+
+  (* Nmin -> Zmin *)
+  | H : context [ Z_of_N (Nmin ?a ?b) ] |- _ => rewrite (Z_of_N_min a b) in H
+  | |- context [ Z_of_N (Nmin ?a ?b) ] => rewrite (Z_of_N_min a b)
+
+  (* Nmax -> Zmax *)
+  | H : context [ Z_of_N (Nmax ?a ?b) ] |- _ => rewrite (Z_of_N_max a b) in H
+  | |- context [ Z_of_N (Nmax ?a ?b) ] => rewrite (Z_of_N_max a b)
+
+  (* Nminus -> Zmax 0 (Zminus ... ...) *)
+  | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H
+  | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b)
+
+  (* Nsucc -> Zsucc *)
+  | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H
+  | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a)
+
+  (* Nmult -> Zmult and a positivity hypothesis *)
+  | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ =>
+        let H:= fresh "H" in
+        assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
+  | |- context [ Z_of_N  (Nmult ?a ?b) ] =>
+        let H:= fresh "H" in
+        assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
+
+  (* atoms of type N : we add a positivity condition (if not already there) *)
+  | H : context [ Z_of_N ?a ] |- _ =>
+        match goal with
+         | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a
+         | H' : 0 <= Z_of_N' a |- _ => fail
+         | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a
+        end
+  | |- context [ Z_of_N ?a ] =>
+        match goal with
+         | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a
+         | H' : 0 <= Z_of_N' a |- _ => fail
+         | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a
+        end
+ end.
+
+Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *.
+
+
+
+(** The complete Z-ification tactic *)
+
+Ltac zify :=
+ repeat progress (zify_nat; zify_positive; zify_N); zify_op.
+
diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml
new file mode 100644
index 00000000..60616845
--- /dev/null
+++ b/plugins/omega/coq_omega.ml
@@ -0,0 +1,1823 @@
+(************************************************************************)
+(*  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$ *)
+
+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   = ["Omega";"System"];
+      optread  = read display_system_flag;
+      optwrite = write display_system_flag }
+
+let _ =
+  declare_bool_option
+    { optsync  = false;
+      optname  = "Omega action display flag";
+      optkey   = ["Omega";"Action"];
+      optread  = read display_action_flag;
+      optwrite = write display_action_flag }
+
+let _ =
+  declare_bool_option
+    { optsync  = false;
+      optname  = "Omega old style flag";
+      optkey   = ["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 coq_modules =
+  init_modules @arith_modules @ [logic_dir] @ zarith_base_modules
+    @ [["Coq"; "omega"; "OmegaLemmas"]]
+
+let init_constant = gen_constant_in_modules "Omega" init_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_constant "le")
+let coq_lt = lazy (init_constant "lt")
+let coq_ge = lazy (init_constant "ge")
+let coq_gt = lazy (init_constant "gt")
+let coq_minus = lazy (init_constant "minus")
+let coq_plus = lazy (init_constant "plus")
+let coq_mult = lazy (init_constant "mult")
+let coq_pred = lazy (init_constant "pred")
+let coq_nat = lazy (init_constant "nat")
+let coq_S = lazy (init_constant "S")
+let coq_O = lazy (init_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 (basename_of_global (ConstRef sp))),args)
+    | Construct csp , args ->
+	Kapp (Other (string_of_id (basename_of_global (ConstructRef csp))), args)
+    | Ind isp, args ->
+	Kapp (Other (string_of_id (basename_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 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/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4
new file mode 100644
index 00000000..3bfdce7f
--- /dev/null
+++ b/plugins/omega/g_omega.ml4
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/omega/omega.ml b/plugins/omega/omega.ml
new file mode 100644
index 00000000..11ab9c03
--- /dev/null
+++ b/plugins/omega/omega.ml
@@ -0,0 +1,716 @@
+(************************************************************************)
+(*  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/plugins/omega/omega_plugin.mllib b/plugins/omega/omega_plugin.mllib
new file mode 100644
index 00000000..2b387fdc
--- /dev/null
+++ b/plugins/omega/omega_plugin.mllib
@@ -0,0 +1,4 @@
+Omega
+Coq_omega
+G_omega
+Omega_plugin_mod
diff --git a/plugins/omega/vo.itarget b/plugins/omega/vo.itarget
new file mode 100644
index 00000000..9d9a77a8
--- /dev/null
+++ b/plugins/omega/vo.itarget
@@ -0,0 +1,4 @@
+OmegaLemmas.vo
+OmegaPlugin.vo
+Omega.vo
+PreOmega.vo
diff --git a/plugins/plugins.itarget b/plugins/plugins.itarget
new file mode 100644
index 00000000..56aa42b0
--- /dev/null
+++ b/plugins/plugins.itarget
@@ -0,0 +1,3 @@
+pluginsopt.otarget
+pluginsbyte.otarget
+pluginsvo.otarget
\ No newline at end of file
diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget
new file mode 100644
index 00000000..1485c147
--- /dev/null
+++ b/plugins/pluginsbyte.itarget
@@ -0,0 +1,23 @@
+field/field_plugin.cma
+setoid_ring/newring_plugin.cma
+extraction/extraction_plugin.cma
+firstorder/ground_plugin.cma
+rtauto/rtauto_plugin.cma
+fourier/fourier_plugin.cma
+romega/romega_plugin.cma
+omega/omega_plugin.cma
+micromega/micromega_plugin.cma
+dp/dp_plugin.cma
+xml/xml_plugin.cma
+subtac/subtac_plugin.cma
+ring/ring_plugin.cma
+cc/cc_plugin.cma
+nsatz/nsatz_plugin.cma
+funind/recdef_plugin.cma
+syntax/ascii_syntax_plugin.cma
+syntax/nat_syntax_plugin.cma
+syntax/numbers_syntax_plugin.cma
+syntax/r_syntax_plugin.cma
+syntax/string_syntax_plugin.cma
+syntax/z_syntax_plugin.cma
+quote/quote_plugin.cma
diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget
new file mode 100644
index 00000000..5d502411
--- /dev/null
+++ b/plugins/pluginsdyn.itarget
@@ -0,0 +1,23 @@
+field/field_plugin.cmxs
+setoid_ring/newring_plugin.cmxs
+extraction/extraction_plugin.cmxs
+firstorder/ground_plugin.cmxs
+rtauto/rtauto_plugin.cmxs
+fourier/fourier_plugin.cmxs
+romega/romega_plugin.cmxs
+omega/omega_plugin.cmxs
+micromega/micromega_plugin.cmxs
+dp/dp_plugin.cmxs
+xml/xml_plugin.cmxs
+subtac/subtac_plugin.cmxs
+ring/ring_plugin.cmxs
+cc/cc_plugin.cmxs
+nsatz/nsatz_plugin.cmxs
+funind/recdef_plugin.cmxs
+syntax/ascii_syntax_plugin.cmxs
+syntax/nat_syntax_plugin.cmxs
+syntax/numbers_syntax_plugin.cmxs
+syntax/r_syntax_plugin.cmxs
+syntax/string_syntax_plugin.cmxs
+syntax/z_syntax_plugin.cmxs
+quote/quote_plugin.cmxs
diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget
new file mode 100644
index 00000000..2f72dab8
--- /dev/null
+++ b/plugins/pluginsopt.itarget
@@ -0,0 +1,23 @@
+field/field_plugin.cmxa
+setoid_ring/newring_plugin.cmxa
+extraction/extraction_plugin.cmxa
+firstorder/ground_plugin.cmxa
+rtauto/rtauto_plugin.cmxa
+fourier/fourier_plugin.cmxa
+romega/romega_plugin.cmxa
+omega/omega_plugin.cmxa
+micromega/micromega_plugin.cmxa
+dp/dp_plugin.cmxa
+xml/xml_plugin.cmxa
+subtac/subtac_plugin.cmxa
+ring/ring_plugin.cmxa
+cc/cc_plugin.cmxa
+nsatz/nsatz_plugin.cmxa
+funind/recdef_plugin.cmxa
+syntax/ascii_syntax_plugin.cmxa
+syntax/nat_syntax_plugin.cmxa
+syntax/numbers_syntax_plugin.cmxa
+syntax/r_syntax_plugin.cmxa
+syntax/string_syntax_plugin.cmxa
+syntax/z_syntax_plugin.cmxa
+quote/quote_plugin.cmxa
diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget
new file mode 100644
index 00000000..db56534c
--- /dev/null
+++ b/plugins/pluginsvo.itarget
@@ -0,0 +1,13 @@
+dp/vo.otarget
+field/vo.otarget
+fourier/vo.otarget
+funind/vo.otarget
+nsatz/vo.otarget
+micromega/vo.otarget
+omega/vo.otarget
+quote/vo.otarget
+ring/vo.otarget
+romega/vo.otarget
+rtauto/vo.otarget
+setoid_ring/vo.otarget
+extraction/vo.otarget
\ No newline at end of file
diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v
new file mode 100644
index 00000000..11726675
--- /dev/null
+++ b/plugins/quote/Quote.v
@@ -0,0 +1,87 @@
+(************************************************************************)
+(*  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$ *)
+
+Declare ML Module "quote_plugin".
+
+(***********************************************************************
+  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/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
new file mode 100644
index 00000000..bdeb9844
--- /dev/null
+++ b/plugins/quote/g_quote.ml4
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Util
+open Tacexpr
+open Quote
+
+let make_cont k x =
+  let k = TacDynamic(dummy_loc, Tacinterp.tactic_in (fun _ -> fst k)) in
+  let x = TacDynamic(dummy_loc, Pretyping.constr_in x) in
+  let tac = <:tactic<let cont := $k in cont $x>> in
+  Tacinterp.interp tac
+
+TACTIC EXTEND quote
+  [ "quote" ident(f) ] -> [ quote f [] ]
+| [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ]
+| [ "quote" ident(f) "in" constr(c) "using" tactic(k) ] ->
+  [ gen_quote (make_cont k) c f [] ]
+| [ "quote" ident(f) "[" ne_ident_list(lc) "]"
+    "in" constr(c) "using" tactic(k) ] ->
+  [ gen_quote (make_cont k) c f lc ]
+END
diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml
new file mode 100644
index 00000000..2e4d07d6
--- /dev/null
+++ b/plugins/quote/quote.ml
@@ -0,0 +1,504 @@
+(************************************************************************)
+(*  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$ *)
+
+(* 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 \texttt{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 variable 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 or 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
+     variable 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 maps 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 \texttt{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 variable 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" ("quote"::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) :=
+     match f with
+       | 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.
+\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 (snd (pattern_of_constr Evd.empty f), Array.map aux args)
+      | Cast (c,_,_) -> aux c
+      | _ -> snd (pattern_of_constr Evd.empty 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";"quote";"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 a single
+  term. Ring for example needs that, but Ring doesn't use 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
+
+let gen_quote cont c 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 [c] gl with
+    | [p], vm -> (p,vm)
+    | _ -> assert false
+  in
+  match ivs.variable_lhs with
+    | None -> cont (mkApp (f, [| p |])) gl
+    | Some _ -> cont (mkApp (f, [| vm; p |])) 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/plugins/quote/quote_plugin.mllib b/plugins/quote/quote_plugin.mllib
new file mode 100644
index 00000000..d1b3ccbe
--- /dev/null
+++ b/plugins/quote/quote_plugin.mllib
@@ -0,0 +1,3 @@
+Quote
+G_quote
+Quote_plugin_mod
diff --git a/plugins/quote/vo.itarget b/plugins/quote/vo.itarget
new file mode 100644
index 00000000..7a44fc5a
--- /dev/null
+++ b/plugins/quote/vo.itarget
@@ -0,0 +1 @@
+Quote.vo
\ No newline at end of file
diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v
new file mode 100644
index 00000000..231b5fbb
--- /dev/null
+++ b/plugins/ring/LegacyArithRing.v
@@ -0,0 +1,90 @@
+(************************************************************************)
+(*  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$ *)
+
+(* 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/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v
new file mode 100644
index 00000000..ee9fb376
--- /dev/null
+++ b/plugins/ring/LegacyNArithRing.v
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  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$ *)
+
+(* 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/plugins/ring/LegacyRing.v b/plugins/ring/LegacyRing.v
new file mode 100644
index 00000000..4ae85baf
--- /dev/null
+++ b/plugins/ring/LegacyRing.v
@@ -0,0 +1,37 @@
+(************************************************************************)
+(*  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$ *)
+
+Require Export Bool.
+Require Export LegacyRing_theory.
+Require Export Quote.
+Require Export Ring_normalize.
+Require Export Ring_abstract.
+Declare ML Module "ring_plugin".
+
+(* 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/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v
new file mode 100644
index 00000000..30d29515
--- /dev/null
+++ b/plugins/ring/LegacyRing_theory.v
@@ -0,0 +1,376 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v
new file mode 100644
index 00000000..68a0dd27
--- /dev/null
+++ b/plugins/ring/LegacyZArithRing.v
@@ -0,0 +1,37 @@
+(************************************************************************)
+(*  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$ *)
+
+(* 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/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v
new file mode 100644
index 00000000..2a9df21b
--- /dev/null
+++ b/plugins/ring/Ring_abstract.v
@@ -0,0 +1,706 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v
new file mode 100644
index 00000000..7aeee218
--- /dev/null
+++ b/plugins/ring/Ring_normalize.v
@@ -0,0 +1,902 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/ring/Setoid_ring.v b/plugins/ring/Setoid_ring.v
new file mode 100644
index 00000000..93b9bc7c
--- /dev/null
+++ b/plugins/ring/Setoid_ring.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  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$ *)
+
+Require Export Setoid_ring_theory.
+Require Export Quote.
+Require Export Setoid_ring_normalize.
+Declare ML Module "ring_plugin".
diff --git a/plugins/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v
new file mode 100644
index 00000000..9b4c46fe
--- /dev/null
+++ b/plugins/ring/Setoid_ring_normalize.v
@@ -0,0 +1,1165 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v
new file mode 100644
index 00000000..2c2314af
--- /dev/null
+++ b/plugins/ring/Setoid_ring_theory.v
@@ -0,0 +1,427 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4
new file mode 100644
index 00000000..d766e344
--- /dev/null
+++ b/plugins/ring/g_ring.ml4
@@ -0,0 +1,136 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/ring/ring.ml b/plugins/ring/ring.ml
new file mode 100644
index 00000000..1e3765da
--- /dev/null
+++ b/plugins/ring/ring.ml
@@ -0,0 +1,924 @@
+(************************************************************************)
+(*  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$ *)
+
+(* 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) }
+
+(* 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) 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) }
+
+(* 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 = full_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.quote.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 false c'i_eq_c''i)
+                   (Equality.general_rewrite false
+		     Termops.all_occurrences false c'i_eq_c''i))
+                 [tac]))
+	 else
+           (tclORELSE
+              (tclORELSE
+		 (h_exact c'i_eq_c''i)
+		 (h_exact (mkApp(build_coq_eq_sym (),
+				 [|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 *)
+    | [] ->
+	(try
+	  match Hipattern.match_with_equation (pf_concl gl) with
+	   | _,_,Hipattern.PolymorphicLeibnizEq (t,c1,c2) ->
+	       let th = guess_theory t in
+	       (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl
+	   | _,_,Hipattern.HeterogenousEq (t1,c1,t2,c2)
+	       when safe_pf_conv_x gl t1 t2 ->
+	       let th = guess_theory t1 in
+	       (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl
+	   | _ -> raise Exit
+	  with Hipattern.NoEquationFound | Exit ->
+	          (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/plugins/ring/ring_plugin.mllib b/plugins/ring/ring_plugin.mllib
new file mode 100644
index 00000000..3c5f995f
--- /dev/null
+++ b/plugins/ring/ring_plugin.mllib
@@ -0,0 +1,3 @@
+Ring
+G_ring
+Ring_plugin_mod
diff --git a/plugins/ring/vo.itarget b/plugins/ring/vo.itarget
new file mode 100644
index 00000000..da387be8
--- /dev/null
+++ b/plugins/ring/vo.itarget
@@ -0,0 +1,10 @@
+LegacyArithRing.vo
+LegacyNArithRing.vo
+LegacyRing_theory.vo
+LegacyRing.vo
+LegacyZArithRing.vo
+Ring_abstract.vo
+Ring_normalize.vo
+Setoid_ring_normalize.vo
+Setoid_ring_theory.vo
+Setoid_ring.vo
diff --git a/plugins/romega/README b/plugins/romega/README
new file mode 100644
index 00000000..86c9e58a
--- /dev/null
+++ b/plugins/romega/README
@@ -0,0 +1,6 @@
+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/plugins/romega/ROmega.v b/plugins/romega/ROmega.v
new file mode 100644
index 00000000..3ddb6bed
--- /dev/null
+++ b/plugins/romega/ROmega.v
@@ -0,0 +1,14 @@
+(*************************************************************************
+
+   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.
+Require Import OmegaPlugin.
+Declare ML Module "romega_plugin".
\ No newline at end of file
diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v
new file mode 100644
index 00000000..c82abfc8
--- /dev/null
+++ b/plugins/romega/ReflOmegaCore.v
@@ -0,0 +1,3216 @@
+(* -*- 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; exfalso.
+
+ 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/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml
new file mode 100644
index 00000000..f4368a1b
--- /dev/null
+++ b/plugins/romega/const_omega.ml
@@ -0,0 +1,352 @@
+(*************************************************************************
+
+   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.basename_of_global (Libnames.ConstRef sp)),
+	      args)
+    | Term.Construct csp , args ->
+	Kapp (Names.string_of_id
+		(Nametab.basename_of_global (Libnames.ConstructRef csp)),
+	      args)
+    | Term.Ind isp, args ->
+	Kapp (Names.string_of_id
+		(Nametab.basename_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.basename_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 init_constant = Coqlib.gen_constant_in_modules "Omega" Coqlib.init_modules
+let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules
+
+(* Logic *)
+let coq_eq = lazy(init_constant  "eq")
+let coq_refl_equal = lazy(init_constant  "eq_refl")
+let coq_and = lazy(init_constant "and")
+let coq_not = lazy(init_constant "not")
+let coq_or = lazy(init_constant "or")
+let coq_True = lazy(init_constant "True")
+let coq_False = lazy(init_constant "False")
+let coq_I = lazy(init_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(init_constant "S")
+let coq_O = lazy(init_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/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli
new file mode 100644
index 00000000..b8db71e4
--- /dev/null
+++ b/plugins/romega/const_omega.mli
@@ -0,0 +1,176 @@
+(*************************************************************************
+
+   PROJET RNRT Calife - 2001
+   Author: Pierre Crégut - France Télécom R&D
+   Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+
+(** Coq objects used in romega *)
+
+(* from Logic *)
+val coq_refl_equal : Term.constr lazy_t
+val coq_and : Term.constr lazy_t
+val coq_not : Term.constr lazy_t
+val coq_or : Term.constr lazy_t
+val coq_True : Term.constr lazy_t
+val coq_False : Term.constr lazy_t
+val coq_I : Term.constr lazy_t
+
+(* from ReflOmegaCore/ZOmega *)
+val coq_h_step : Term.constr lazy_t
+val coq_pair_step : Term.constr lazy_t
+val coq_p_left : Term.constr lazy_t
+val coq_p_right : Term.constr lazy_t
+val coq_p_invert : Term.constr lazy_t
+val coq_p_step : Term.constr lazy_t
+
+val coq_t_int : Term.constr lazy_t
+val coq_t_plus : Term.constr lazy_t
+val coq_t_mult : Term.constr lazy_t
+val coq_t_opp : Term.constr lazy_t
+val coq_t_minus : Term.constr lazy_t
+val coq_t_var : Term.constr lazy_t
+
+val coq_proposition : Term.constr lazy_t
+val coq_p_eq : Term.constr lazy_t
+val coq_p_leq : Term.constr lazy_t
+val coq_p_geq : Term.constr lazy_t
+val coq_p_lt : Term.constr lazy_t
+val coq_p_gt : Term.constr lazy_t
+val coq_p_neq : Term.constr lazy_t
+val coq_p_true : Term.constr lazy_t
+val coq_p_false : Term.constr lazy_t
+val coq_p_not : Term.constr lazy_t
+val coq_p_or : Term.constr lazy_t
+val coq_p_and : Term.constr lazy_t
+val coq_p_imp : Term.constr lazy_t
+val coq_p_prop : Term.constr lazy_t
+
+val coq_f_equal : Term.constr lazy_t
+val coq_f_cancel : Term.constr lazy_t
+val coq_f_left : Term.constr lazy_t
+val coq_f_right : Term.constr lazy_t
+
+val coq_c_do_both : Term.constr lazy_t
+val coq_c_do_left : Term.constr lazy_t
+val coq_c_do_right : Term.constr lazy_t
+val coq_c_do_seq : Term.constr lazy_t
+val coq_c_nop : Term.constr lazy_t
+val coq_c_opp_plus : Term.constr lazy_t
+val coq_c_opp_opp : Term.constr lazy_t
+val coq_c_opp_mult_r : Term.constr lazy_t
+val coq_c_opp_one : Term.constr lazy_t
+val coq_c_reduce : Term.constr lazy_t
+val coq_c_mult_plus_distr : Term.constr lazy_t
+val coq_c_opp_left : Term.constr lazy_t
+val coq_c_mult_assoc_r : Term.constr lazy_t
+val coq_c_plus_assoc_r : Term.constr lazy_t
+val coq_c_plus_assoc_l : Term.constr lazy_t
+val coq_c_plus_permute : Term.constr lazy_t
+val coq_c_plus_comm : Term.constr lazy_t
+val coq_c_red0 : Term.constr lazy_t
+val coq_c_red1 : Term.constr lazy_t
+val coq_c_red2 : Term.constr lazy_t
+val coq_c_red3 : Term.constr lazy_t
+val coq_c_red4 : Term.constr lazy_t
+val coq_c_red5 : Term.constr lazy_t
+val coq_c_red6 : Term.constr lazy_t
+val coq_c_mult_opp_left : Term.constr lazy_t
+val coq_c_mult_assoc_reduced : Term.constr lazy_t
+val coq_c_minus : Term.constr lazy_t
+val coq_c_mult_comm : Term.constr lazy_t
+
+val coq_s_constant_not_nul : Term.constr lazy_t
+val coq_s_constant_neg : Term.constr lazy_t
+val coq_s_div_approx : Term.constr lazy_t
+val coq_s_not_exact_divide : Term.constr lazy_t
+val coq_s_exact_divide : Term.constr lazy_t
+val coq_s_sum : Term.constr lazy_t
+val coq_s_state : Term.constr lazy_t
+val coq_s_contradiction : Term.constr lazy_t
+val coq_s_merge_eq : Term.constr lazy_t
+val coq_s_split_ineq : Term.constr lazy_t
+val coq_s_constant_nul : Term.constr lazy_t
+val coq_s_negate_contradict : Term.constr lazy_t
+val coq_s_negate_contradict_inv : Term.constr lazy_t
+
+val coq_direction : Term.constr lazy_t
+val coq_d_left : Term.constr lazy_t
+val coq_d_right : Term.constr lazy_t
+val coq_d_mono : Term.constr lazy_t
+
+val coq_e_split : Term.constr lazy_t
+val coq_e_extract : Term.constr lazy_t
+val coq_e_solve : Term.constr lazy_t
+
+val coq_interp_sequent : Term.constr lazy_t
+val coq_do_omega : Term.constr lazy_t
+
+(** Building expressions *)
+
+val do_left : Term.constr -> Term.constr
+val do_right : Term.constr -> Term.constr
+val do_both : Term.constr -> Term.constr -> Term.constr
+val do_seq : Term.constr -> Term.constr -> Term.constr
+val do_list : Term.constr list -> Term.constr
+
+val mk_nat : int -> Term.constr
+val mk_list : Term.constr -> Term.constr list -> Term.constr
+val mk_plist : Term.types list -> Term.types
+val mk_shuffle_list : Term.constr list -> Term.constr
+
+(** Analyzing a coq term *)
+
+(* The generic result shape of the analysis of a term.
+   One-level depth, except when a number is found *)
+type parse_term =
+    Tplus of Term.constr * Term.constr
+  | Tmult of Term.constr * Term.constr
+  | Tminus of Term.constr * Term.constr
+  | Topp of Term.constr
+  | Tsucc of Term.constr
+  | Tnum of Bigint.bigint
+  | Tother
+
+(* The generic result shape of the analysis of a relation.
+   One-level depth. *)
+type parse_rel =
+    Req of Term.constr * Term.constr
+  | Rne of Term.constr * Term.constr
+  | Rlt of Term.constr * Term.constr
+  | Rle of Term.constr * Term.constr
+  | Rgt of Term.constr * Term.constr
+  | Rge of Term.constr * Term.constr
+  | Rtrue
+  | Rfalse
+  | Rnot of Term.constr
+  | Ror of Term.constr * Term.constr
+  | Rand of Term.constr * Term.constr
+  | Rimp of Term.constr * Term.constr
+  | Riff of Term.constr * Term.constr
+  | Rother
+
+(* A module factorizing what we should now about the number representation *)
+module type Int =
+  sig
+    (* the coq type of the numbers *)
+    val typ : Term.constr Lazy.t
+    (* the operations on the numbers *)
+    val plus : Term.constr Lazy.t
+    val mult : Term.constr Lazy.t
+    val opp : Term.constr Lazy.t
+    val minus : Term.constr Lazy.t
+    (* building a coq number *)
+    val mk : Bigint.bigint -> Term.constr
+    (* parsing a term (one level, except if a number is found) *)
+    val parse_term : Term.constr -> parse_term
+    (* parsing a relation expression, including = < <= >= > *)
+    val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel
+    (* Is a particular term only made of numbers and + * - ? *)
+    val is_scalar : Term.constr -> bool
+  end
+
+(* Currently, we only use Z numbers *)
+module Z : Int
diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4
new file mode 100644
index 00000000..2db86e00
--- /dev/null
+++ b/plugins/romega/g_romega.ml4
@@ -0,0 +1,42 @@
+(*************************************************************************
+
+   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/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml
new file mode 100644
index 00000000..570bb187
--- /dev/null
+++ b/plugins/romega/refl_omega.ml
@@ -0,0 +1,1299 @@
+(*************************************************************************
+
+   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/plugins/romega/romega_plugin.mllib b/plugins/romega/romega_plugin.mllib
new file mode 100644
index 00000000..1625009d
--- /dev/null
+++ b/plugins/romega/romega_plugin.mllib
@@ -0,0 +1,4 @@
+Const_omega
+Refl_omega
+G_romega
+Romega_plugin_mod
diff --git a/plugins/romega/vo.itarget b/plugins/romega/vo.itarget
new file mode 100644
index 00000000..f7a3c41c
--- /dev/null
+++ b/plugins/romega/vo.itarget
@@ -0,0 +1,2 @@
+ReflOmegaCore.vo
+ROmega.vo
diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v
new file mode 100644
index 00000000..c06f6991
--- /dev/null
+++ b/plugins/rtauto/Bintree.v
@@ -0,0 +1,489 @@
+(************************************************************************)
+(*  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$ *)
+
+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 : forall (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/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v
new file mode 100644
index 00000000..0d1d09c7
--- /dev/null
+++ b/plugins/rtauto/Rtauto.v
@@ -0,0 +1,400 @@
+(************************************************************************)
+(*  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$ *)
+
+
+Require Export List.
+Require Export Bintree.
+Require Import Bool.
+Unset Boxed Definitions.
+
+Declare ML Module "rtauto_plugin".
+
+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/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4
new file mode 100644
index 00000000..4cbe8436
--- /dev/null
+++ b/plugins/rtauto/g_rtauto.ml4
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id$*)
+
+(*i camlp4deps: "parsing/grammar.cma"  i*)
+
+TACTIC EXTEND rtauto
+  [ "rtauto" ] -> [ Refl_tauto.rtauto_tac ]
+END
+
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
new file mode 100644
index 00000000..562e2e3b
--- /dev/null
+++ b/plugins/rtauto/proof_search.ml
@@ -0,0 +1,546 @@
+(************************************************************************)
+(*  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$ *)
+
+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=["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/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli
new file mode 100644
index 00000000..e52f6bbd
--- /dev/null
+++ b/plugins/rtauto/proof_search.mli
@@ -0,0 +1,49 @@
+(************************************************************************)
+(*  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$ *)
+
+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/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
new file mode 100644
index 00000000..23cb0705
--- /dev/null
+++ b/plugins/rtauto/refl_tauto.ml
@@ -0,0 +1,337 @@
+(************************************************************************)
+(*  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$ *)
+
+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=["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=["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/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli
new file mode 100644
index 00000000..a6d68a22
--- /dev/null
+++ b/plugins/rtauto/refl_tauto.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  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$ *)
+
+(* 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/plugins/rtauto/rtauto_plugin.mllib b/plugins/rtauto/rtauto_plugin.mllib
new file mode 100644
index 00000000..0e346044
--- /dev/null
+++ b/plugins/rtauto/rtauto_plugin.mllib
@@ -0,0 +1,4 @@
+Proof_search
+Refl_tauto
+G_rtauto
+Rtauto_plugin_mod
diff --git a/plugins/rtauto/vo.itarget b/plugins/rtauto/vo.itarget
new file mode 100644
index 00000000..4c9364ad
--- /dev/null
+++ b/plugins/rtauto/vo.itarget
@@ -0,0 +1,2 @@
+Bintree.vo
+Rtauto.vo
diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
new file mode 100644
index 00000000..e5a4c8d1
--- /dev/null
+++ b/plugins/setoid_ring/ArithRing.v
@@ -0,0 +1,60 @@
+(************************************************************************)
+(*  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/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v
new file mode 100644
index 00000000..d403c9ef
--- /dev/null
+++ b/plugins/setoid_ring/BinList.v
@@ -0,0 +1,93 @@
+(************************************************************************)
+(*  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/plugins/setoid_ring/Field.v b/plugins/setoid_ring/Field.v
new file mode 100644
index 00000000..a944ba5f
--- /dev/null
+++ b/plugins/setoid_ring/Field.v
@@ -0,0 +1,10 @@
+(************************************************************************)
+(*  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/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v
new file mode 100644
index 00000000..9d82d1fd
--- /dev/null
+++ b/plugins/setoid_ring/Field_tac.v
@@ -0,0 +1,571 @@
+(************************************************************************)
+(*  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 :=
+    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:(FEadd e1 e2)
+        | (rmul ?t1 ?t2) =>
+          fun _ =>
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEmul e1 e2)
+        | (rsub ?t1 ?t2) =>
+          fun _ =>
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEsub e1 e2)
+        | (ropp ?t1) =>
+          fun _ => let e1 := mkP t1 in constr:(FEopp e1)
+        | (rdiv ?t1 ?t2) =>
+          fun _ =>
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEdiv e1 e2)
+        | (rinv ?t1) =>
+          fun _ => let e1 := mkP t1 in constr:(FEinv e1)
+        | (rpow ?t1 ?n) =>
+          match CstPow n with
+          | InitialRing.NotConstant =>
+            fun _ =>
+            let p := Find_at t fv in
+            constr:(@FEX C p)
+          | ?c => fun _ => let e1 := mkP t1 in constr:(FEpow e1 c)
+          end
+        | _ =>
+          fun _ =>
+          let p := Find_at t fv in
+          constr:(@FEX C p)
+        end
+    | ?c => fun _ => constr:(FEc c)
+    end in
+    f ()
+ 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.
+
+(* packaging the field structure *)
+
+(* TODO: inline PackField into field_lookup *)
+Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post :=
+  let FLD :=
+    match type of L1 with
+    | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv
+                                      ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] =>
+        (fun proj =>
+           proj Cst_tac Pow_tac pre post
+             req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok)
+    | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
+    end in
+  F FLD.
+
+Ltac get_FldPre FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       pre).
+
+Ltac get_FldPost FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       post).
+
+Ltac get_L1 FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       L1).
+
+Ltac get_SimplifyEqLemma FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       L2).
+
+Ltac get_SimplifyLemma FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       L3).
+
+Ltac get_L4 FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       L4).
+
+Ltac get_CondLemma FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       cond_ok).
+
+Ltac get_FldEq FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       req).
+
+Ltac get_FldCarrier FLD :=
+  let req := get_FldEq FLD in
+  relation_carrier req.
+
+Ltac get_RingFV FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       FV Cst_tac Pow_tac radd rmul rsub ropp rpow).
+
+Ltac get_FFV FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).
+
+Ltac get_RingMeta FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow).
+
+Ltac get_Meta FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).
+
+Ltac get_Hyp_tac FLD :=
+  FLD ltac:
+      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+           L1 L2 L3 L4 cond_ok =>
+       let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
+       fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH).
+
+Ltac get_FEeval FLD :=
+  let L1 := get_L1 FLD in
+  match type of L1 with
+  | context
+    [(@FEeval
+      ?R ?r0 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] =>
+       constr:(@FEeval R r0 add mul sub opp div inv C phi Cpow powphi pow)
+  | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)"
+  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
+  let ft := fold_concl Get_goal in
+  change ft.
+
+Ltac simpl_PCond FLD :=
+  let req := get_FldEq FLD in
+  let lemma := get_CondLemma FLD in
+  try apply lemma;
+  protect_fv "field_cond";
+  fold_field_cond req;
+  try exact I.
+
+Ltac simpl_PCond_BEURK FLD :=
+  let req := get_FldEq FLD in
+  let lemma := get_CondLemma FLD in
+  apply lemma;
+  protect_fv "field_cond";
+  fold_field_cond req.
+
+(* Rewriting (field_simplify) *)
+Ltac Field_norm_gen f n FLD lH rl :=
+  let mkFV := get_RingFV FLD in
+  let mkFFV := get_FFV FLD in
+  let mkFE :=  get_Meta FLD in
+  let fv0 := FV_hypo_tac mkFV ltac:(get_FldEq FLD) lH in
+  let lemma_tac fv kont :=
+    let lemma := get_SimplifyLemma FLD in
+    (* reify equations of the context *)
+    let lpe := get_Hyp_tac FLD fv lH in
+    let vlpe := fresh "hyps" in
+    pose (vlpe := lpe);
+    let prh := proofHyp_tac lH in
+    (* compute the normal form of the reified hyps *)
+    let vlmp := fresh "hyps'" in
+    let vlmp_eq := fresh "hyps_eq" in
+    let mk_monpol := get_MonPol lemma in
+    compute_assertion vlmp_eq vlmp (mk_monpol vlpe);
+    (* partially instantiate the lemma *)
+    let lem := fresh "f_rw_lemma" in
+    (assert (lem := lemma n vlpe fv prh vlmp vlmp_eq)
+     || fail "type error when building the rewriting lemma");
+    (* continuation will call main_tac for all reified terms *)
+    kont lem;
+    (* at the end, cleanup *)
+    (clear lem vlmp_eq vlmp vlpe||idtac"Field_norm_gen:cleanup failed") in
+  (* each instance of the lemma is simplified then passed to f *)
+  let main_tac H := protect_fv "field" in H; f H in
+  (* generate and use equations for each expression *)
+  ReflexiveRewriteTactic mkFFV mkFE lemma_tac main_tac fv0 rl;
+  try simpl_PCond FLD.
+
+Ltac Field_simplify_gen f FLD lH rl :=
+  get_FldPre FLD ();
+  Field_norm_gen f ring_subst_niter FLD lH rl;
+  get_FldPost FLD ().
+
+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 (PackField Field_simplify) [] rl G.
+
+Tactic Notation (at level 0)
+  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
+  let G := Get_goal in
+  field_lookup (PackField 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);
+  revert H;
+  field_lookup (PackField 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);
+  revert H;
+  field_lookup (PackField 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 n lemma FLD lH :=
+  let req := get_FldEq FLD in
+  let mkFV := get_RingFV FLD in
+  let mkFFV := get_FFV FLD in
+  let mkFE := get_Meta FLD 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 := get_Hyp_tac FLD 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");
+    ProveLemmaHyps nlemma
+      ltac:(fun ilemma =>
+              apply ilemma
+               || fail "field anomaly: failed in applying lemma";
+              [ Simpl_tac | simpl_PCond FLD]);
+    clear nlemma;
+    subst vlpe in
+  OnEquation req Main_eq.
+
+(* solve completely a field equation, leaving non-zero conditions to be
+   proved (field) *)
+
+Ltac FIELD FLD lH rl :=
+  let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in
+  let lemma := get_L1 FLD in
+  get_FldPre FLD ();
+  Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH;
+  try exact I;
+  get_FldPost FLD().
+
+Tactic Notation (at level 0) "field" :=
+  let G := Get_goal in
+  field_lookup (PackField FIELD) [] G.
+
+Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" :=
+  let G := Get_goal in
+  field_lookup (PackField 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 FLD lH rl :=
+  let Simpl := (protect_fv "field") in
+  let lemma := get_SimplifyEqLemma FLD in
+  get_FldPre FLD ();
+  Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH;
+  get_FldPost FLD ().
+
+Tactic Notation (at level 0) "field_simplify_eq" :=
+  let G := Get_goal in
+  field_lookup (PackField FIELD_SIMPL) [] G.
+
+Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" :=
+  let G := Get_goal in
+  field_lookup (PackField FIELD_SIMPL) [lH] G.
+
+(* Same as FIELD_SIMPL but in hypothesis *)
+
+Ltac Field_simplify_eq n FLD lH :=
+  let req := get_FldEq FLD in
+  let mkFV := get_RingFV FLD in
+  let mkFFV := get_FFV FLD in
+  let mkFE := get_Meta FLD in
+  let lemma := get_L4 FLD in
+  let hyp := fresh "hyp" in
+  intro hyp;
+  OnEquationHyp req hyp ltac:(fun 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 := get_Hyp_tac FLD 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
+      ProveLemmaHyps (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 | simpl_PCond_BEURK FLD]
+               | protect_fv "field" in tmp; revert tmp ];
+               clear hyp
+             end)).
+
+Ltac FIELD_SIMPL_EQ FLD lH rl :=
+  get_FldPre FLD ();
+  Field_simplify_eq Ring_tac.ring_subst_niter FLD lH;
+  get_FldPost FLD ().
+
+Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) :=
+  let t := type of H in
+  generalize H;
+  field_lookup (PackField 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 (PackField FIELD_SIMPL_EQ) [lH] t;
+  [ try exact I
+  |clear H;intro H].
+
+(* More generic tactics to build variants of field *)
+
+(* This tactic reifies c and pass to F:
+   - the FLD structure gathering all info in the field DB
+   - the atom list
+   - the expression (FExpr)
+ *)
+Ltac gen_with_field F c :=
+  let MetaExpr FLD _ rl :=
+    let R := get_FldCarrier FLD in
+    let mkFFV := get_FFV FLD in
+    let mkFE  := get_Meta FLD in
+    let csr :=
+      match rl with
+      | List.cons ?r _ => r
+      | _ => fail 1 "anomaly: ill-formed list"
+      end in
+    let fv := mkFFV csr (@List.nil R) in
+    let expr := mkFE csr fv in
+    F FLD fv expr in
+  field_lookup (PackField MetaExpr) [] (c=c).
+
+
+(* pushes the equation expr = ope(expr) in the goal, and
+   discharge it with field *)
+Ltac prove_field_eqn ope FLD fv expr :=
+  let res := ope expr in
+  let expr' := fresh "input_expr" in
+  pose (expr' := expr);
+  let res' := fresh "result" in
+  pose (res' := res);
+  let lemma := get_L1 FLD in
+  let lemma :=
+    constr:(lemma O fv List.nil expr' res' I List.nil (refl_equal _)) in
+  let ty := type of lemma in
+  let lhs := match ty with
+    forall _, ?lhs=_ -> _ => lhs
+    end in
+  let rhs := match ty with
+    forall _, _=_ -> forall _, ?rhs=_ -> _ => rhs
+    end in
+  let lhs' := fresh "lhs" in let lhs_eq := fresh "lhs_eq" in
+  let rhs' := fresh "rhs" in let rhs_eq := fresh "rhs_eq" in
+  compute_assertion lhs_eq lhs' lhs;
+  compute_assertion rhs_eq rhs' rhs;
+  let H := fresh "fld_eqn" in
+  refine (_ (lemma lhs' lhs_eq rhs' rhs_eq _ _));
+    (* main goal *)
+    [intro H;protect_fv "field" in H; revert H
+    (* ring-nf(lhs') = ring-nf(rhs') *)
+    | vm_compute; reflexivity || fail "field cannot prove this equality"
+    (* denominator condition *)
+    | simpl_PCond FLD];
+  clear lhs_eq rhs_eq; subst lhs' rhs'.
+
+Ltac prove_with_field ope c :=
+  gen_with_field ltac:(prove_field_eqn ope) c.
+
+(* Prove an equation x=ope(x) and rewrite with it *)
+Ltac prove_rw ope x :=
+  prove_with_field ope x;
+  [ let H := fresh "Heq_maple" in
+    intro H; rewrite H; clear H
+  |..].
+
+(* Apply ope (FExpr->FExpr) on an expression *)
+Ltac reduce_field_expr ope kont FLD fv expr :=
+  let evfun := get_FEeval FLD in
+  let res := ope expr in
+  let c := (eval simpl_field_expr in (evfun fv res)) in
+  kont c.
+
+(* Hack to let a Ltac return a term in the context of a primitive tactic *)
+Ltac return_term x := generalize (refl_equal x).
+Ltac get_term :=
+  match goal with
+  | |- ?x = _ -> _ => x
+  end.
+
+(* Turn an operation on field expressions (FExpr) into a reduction
+   on terms (in the field carrier). Because of field_lookup,
+   the tactic cannot return a term directly, so it is returned
+   via the conclusion of the goal (return_term). *)
+Ltac reduce_field_ope ope c :=
+  gen_with_field ltac:(reduce_field_expr ope return_term) c.
+
+
+(* 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/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v
new file mode 100644
index 00000000..9617d409
--- /dev/null
+++ b/plugins/setoid_ring/Field_theory.v
@@ -0,0 +1,1946 @@
+(************************************************************************)
+(*  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) with signature req ==> eq ==> req as 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 ==> 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.
+
+(* split factorized denominators *)
+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/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v
new file mode 100644
index 00000000..b5384f80
--- /dev/null
+++ b/plugins/setoid_ring/InitialRing.v
@@ -0,0 +1,908 @@
+(************************************************************************)
+(*  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/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v
new file mode 100644
index 00000000..0ba519fd
--- /dev/null
+++ b/plugins/setoid_ring/NArithRing.v
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  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/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v
new file mode 100644
index 00000000..56473adb
--- /dev/null
+++ b/plugins/setoid_ring/RealField.v
@@ -0,0 +1,134 @@
+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/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v
new file mode 100644
index 00000000..d01b1625
--- /dev/null
+++ b/plugins/setoid_ring/Ring.v
@@ -0,0 +1,44 @@
+(************************************************************************)
+(*  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/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v
new file mode 100644
index 00000000..fd9dd8d0
--- /dev/null
+++ b/plugins/setoid_ring/Ring_base.v
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  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 Import Quote.
+Declare ML Module "newring_plugin".
+Require Export Ring_theory.
+Require Export Ring_tac.
+Require Import InitialRing.
diff --git a/plugins/setoid_ring/Ring_equiv.v b/plugins/setoid_ring/Ring_equiv.v
new file mode 100644
index 00000000..945f6c68
--- /dev/null
+++ b/plugins/setoid_ring/Ring_equiv.v
@@ -0,0 +1,74 @@
+Require Import Setoid_ring_theory.
+Require Import LegacyRing_theory.
+Require Import Ring_theory.
+
+Set Implicit Arguments.
+
+Section Old2New.
+
+Variable A : Type.
+
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aopp : A -> A.
+Variable Aeq : A -> A -> bool.
+Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
+
+Let Aminus := fun x y => Aplus x (Aopp y).
+
+Lemma ring_equiv1 :
+  ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)).
+Proof.
+destruct R.
+split;  eauto.
+Qed.
+
+End Old2New.
+
+Section New2OldRing.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)).
+
+ Variable reqb : R -> R -> bool.
+ Variable reqb_ok : forall x y, reqb x y = true -> x = y.
+
+ Lemma ring_equiv2 :
+   Ring_Theory radd  rmul rI rO ropp reqb.
+Proof.
+elim Rth; intros; constructor;  eauto.
+intros.
+apply reqb_ok.
+destruct (reqb x y); trivial; intros.
+elim H.
+Qed.
+
+ Definition default_eqb : R -> R -> bool := fun x y => false.
+ Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y.
+Proof.
+discriminate 1.
+Qed.
+
+End New2OldRing.
+
+Section New2OldSemiRing.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul: R->R->R).
+ Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)).
+
+ Variable reqb : R -> R -> bool.
+ Variable reqb_ok : forall x y, reqb x y = true -> x = y.
+
+ Lemma sring_equiv2 :
+   Semi_Ring_Theory radd rmul rI rO reqb.
+Proof.
+elim SRth; intros; constructor;  eauto.
+intros.
+apply reqb_ok.
+destruct (reqb x y); trivial; intros.
+elim H.
+Qed.
+
+End New2OldSemiRing.
diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v
new file mode 100644
index 00000000..faa83ded
--- /dev/null
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -0,0 +1,1781 @@
+(************************************************************************)
+(*  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/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v
new file mode 100644
index 00000000..d33e9a82
--- /dev/null
+++ b/plugins/setoid_ring/Ring_tac.v
@@ -0,0 +1,434 @@
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinPos.
+Require Import Ring_polynom.
+Require Import BinList.
+Require Import InitialRing.
+Require Import Quote.
+Declare ML Module "newring_plugin".
+
+
+(* adds a definition t' on the normal form of t and an hypothesis id
+   stating that t = t' (tries to produces a proof as small as possible) *)
+Ltac compute_assertion eqn t' t :=
+  let nft := eval vm_compute in t in
+  pose (t' := nft);
+  assert (eqn : t = t');
+  [vm_cast_no_check (refl_equal t')|idtac].
+
+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 Get_goal := match goal with [|- ?G] => G end.
+
+(********************************************************************)
+(* Tacticals to build reflexive tactics *)
+
+Ltac OnEquation req :=
+  match goal with
+  | |- req ?lhs ?rhs => (fun f => f lhs rhs)
+  | _ => (fun _ => fail "Goal is not an equation (of expected equality)")
+  end.
+
+Ltac OnEquationHyp req h :=
+  match type of h with
+  | req ?lhs ?rhs => fun f => f lhs rhs
+  | _ => (fun _ => fail "Hypothesis is not an equation (of expected equality)")
+  end.
+
+(* Note: auxiliary subgoals in reverse order *)
+Ltac OnMainSubgoal H ty :=
+  match ty with
+  | _ -> ?ty' =>
+     let subtac := OnMainSubgoal H ty' in
+     fun kont => lapply H; [clear H; intro H; subtac kont | idtac]
+  | _ => (fun kont => kont())
+  end.
+
+(* A generic pattern to have reflexive tactics do some computation:
+   lemmas of the form [forall x', x=x' -> P(x')] are understood as:
+   compute the normal form of x, instantiate x' with it, prove
+   hypothesis x=x' with vm_compute and reflexivity, and pass the
+   instantiated lemma to the continuation.
+ *)
+Ltac ProveLemmaHyp lemma :=
+  match type of lemma with
+    forall x', ?x = x' -> _ =>
+      (fun kont =>
+        let x' := fresh "res" in
+        let H := fresh "res_eq" in
+        compute_assertion H x' x;
+        let lemma' := constr:(lemma x' H) in
+        kont lemma';
+        (clear H||idtac"ProveLemmaHyp: cleanup failed");
+        subst x')
+  | _ => (fun _ => fail "ProveLemmaHyp: lemma not of the expected form")
+  end.
+
+Ltac ProveLemmaHyps lemma :=
+  match type of lemma with
+    forall x', ?x = x' -> _ =>
+      (fun kont =>
+        let x' := fresh "res" in
+        let H := fresh "res_eq" in
+        compute_assertion H x' x;
+        let lemma' := constr:(lemma x' H) in
+        ProveLemmaHyps lemma' kont;
+        (clear H||idtac"ProveLemmaHyps: cleanup failed");
+        subst x')
+  | _ => (fun kont => kont lemma)
+  end.
+
+(*
+Ltac ProveLemmaHyps lemma := (* expects a continuation *)
+  let try_step := ProveLemmaHyp lemma in
+  (fun kont =>
+    try_step ltac:(fun lemma' => ProveLemmaHyps lemma' kont) ||
+    kont lemma).
+*)
+Ltac ApplyLemmaThen lemma expr kont :=
+  let lem := constr:(lemma expr) in
+  ProveLemmaHyp lem ltac:(fun lem' =>
+    let Heq := fresh "thm" in
+    assert (Heq:=lem');
+    OnMainSubgoal Heq ltac:(type of Heq) ltac:(fun _ => kont Heq);
+    (clear Heq||idtac"ApplyLemmaThen: cleanup failed")).
+(*
+Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg :=
+  let pe :=
+    match type of (lemma expr) with
+      forall pe', ?pe = pe' -> _ => pe
+    | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression"
+    end in
+  let pe' := fresh "expr_nf" in
+  let nf_pe := fresh "pe_eq" in
+  compute_assertion nf_pe pe' pe;
+  let Heq := fresh "thm" in
+  (assert (Heq:=lemma pe pe' H) || fail "anomaly: failed to apply lemma");
+  clear nf_pe;
+  OnMainSubgoal Heq ltac:(type of Heq)
+    ltac:(try tac Heq; clear Heq pe';CONT_tac cont_arg)).
+*)
+Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac :=
+  ApplyLemmaThen lemma expr
+    ltac:(fun lemma' => try tac lemma'; CONT_tac()).
+
+(* General scheme of reflexive tactics using of correctness lemma
+   that involves normalisation of one expression
+   - [FV_tac term fv] is a tactic that adds the atomic expressions
+       of [term] into [fv]
+   - [SYN_tac term fv] reifies [term] given the list of atomic expressions
+   - [LEMMA_tac fv kont] computes the correctness lemma and passes it to
+       continuation kont
+   - [MAIN_tac H] process H which is the conclusion of the correctness lemma
+       instantiated with each reified term
+   - [fv] is the initial value of atomic expressions (to be completed by
+       the reification of the terms
+   - [terms] the list (a constr of type list) of terms to reify and process.
+ *)
+Ltac ReflexiveRewriteTactic
+     FV_tac SYN_tac LEMMA_tac MAIN_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 :=
+      let expr := SYN_tac term fv in
+      let main H :=
+        match type of H with
+        | (?req _ ?rhs) => change (req term rhs) in H
+        end;
+        MAIN_tac H in
+      (ApplyLemmaThenAndCont lemma expr main CONT_tac) in
+     (* rewrite steps *)
+     lazy_list_fold_right fcons ltac:(fun _=>idtac) terms in
+  LEMMA_tac fv RW_tac.
+
+(********************************************************)
+
+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 Reify lH :=
+  let mkHyp h res :=
+   match h with
+   | @mkhypo (req ?r1 ?r2) _ =>
+     let pe1 := Reify r1 in
+     let pe2 := Reify 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.
+
+Ltac get_MonPol lemma :=
+  match type of lemma with
+  | context [(mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _)] =>
+      constr:(mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb)
+  | _ => fail 1 "ring/field anomaly: bad correctness lemma (get_MonPol)"
+  end.
+
+(********************************************************)
+
+(* Building the atom list of a ring expression *)
+Ltac FV Cst CstPow add mul sub opp pow t fv :=
+ let rec TFV t fv :=
+  let f :=
+  match Cst t with
+  | NotConstant =>
+      match t with
+      | (add ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
+      | (mul ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
+      | (sub ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
+      | (opp ?t1) => fun _ => TFV t1 fv
+      | (pow ?t1 ?n) =>
+        match CstPow n with
+        | InitialRing.NotConstant => fun _ => AddFvTail t fv
+        | _ => fun _ => TFV t1 fv
+        end
+      | _ => fun _ => AddFvTail t fv
+      end
+  | _ => fun _ => fv
+  end in
+  f()
+ 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.
+
+(* packaging the ring structure *)
+
+Ltac PackRing F req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post :=
+  let RNG :=
+    match type of lemma1 with
+    | context
+       [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
+        (fun proj => proj
+             cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2)
+    | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
+    end in
+  F RNG.
+
+Ltac get_Carrier RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            R).
+
+Ltac get_Eq RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            req).
+
+Ltac get_Pre RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            pre).
+
+Ltac get_Post RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            post).
+
+Ltac get_NormLemma RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            lemma1).
+
+Ltac get_SimplifyLemma RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            lemma2).
+
+Ltac get_RingFV RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            FV cst_tac pow_tac add mul sub opp pow).
+
+Ltac get_RingMeta RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            mkPolexpr C cst_tac pow_tac add mul sub opp pow).
+
+Ltac get_RingHypTac RNG :=
+  RNG ltac:(fun cst_tac pow_tac pre post
+             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+       let mkPol := mkPolexpr C cst_tac pow_tac add mul sub opp pow in
+       fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH).
+
+(* ring tactics *)
+
+Definition ring_subst_niter := (10*10*10)%nat.
+
+Ltac Ring RNG lemma lH :=
+  let req := get_Eq RNG in
+  OnEquation req ltac:(fun lhs rhs =>
+    let mkFV := get_RingFV RNG in
+    let mkPol := get_RingMeta RNG in
+    let mkHyp := get_RingHypTac RNG in
+    let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) 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 fv lH in
+    let vlpe := fresh "hyp_list" in
+    let vfv := fresh "fv_list" in
+    pose (vlpe := lpe);
+    pose (vfv := fv);
+    (apply (lemma vfv vlpe pe1 pe2)
+      || fail "typing error while applying ring");
+    [ ((let prh := proofHyp_tac lH in exact prh)
+        || idtac "can not automatically proof hypothesis :";
+           idtac " maybe a left member of a hypothesis is not a monomial")
+    | vm_compute;
+      (exact (refl_equal true) || fail "not a valid ring equation")]).
+
+Ltac Ring_norm_gen f RNG lemma lH rl :=
+  let mkFV := get_RingFV RNG in
+  let mkPol := get_RingMeta RNG in
+  let mkHyp := get_RingHypTac RNG in
+  let mk_monpol := get_MonPol lemma in
+  let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in
+  let lemma_tac fv kont :=
+    let lpe := mkHyp 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);
+    compute_assertion vlmp_eq vlmp (mk_monpol vlpe);
+    let H := fresh "ring_lemma" in
+    (assert (H := lemma vlpe fv prh vlmp vlmp_eq)
+      || fail "type error when build the rewriting lemma");
+    clear vlmp_eq;
+    kont H;
+    (clear H||idtac"Ring_norm_gen: cleanup failed");
+    subst vlpe vlmp in
+  let simpl_ring H := (protect_fv "ring" in H; f H) in
+  ReflexiveRewriteTactic mkFV mkPol lemma_tac simpl_ring fv rl.
+
+Ltac Ring_gen RNG lH rl :=
+  let lemma := get_NormLemma RNG in
+  get_Pre RNG ();
+  Ring RNG (lemma ring_subst_niter) lH.
+
+Tactic Notation (at level 0) "ring" :=
+  let G := Get_goal in
+  ring_lookup (PackRing Ring_gen) [] G.
+
+Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" :=
+  let G := Get_goal in
+  ring_lookup (PackRing Ring_gen) [lH] G.
+
+(* Simplification *)
+
+Ltac Ring_simplify_gen f RNG lH rl :=
+  let lemma := get_SimplifyLemma RNG in
+  let l := fresh "to_rewrite" in
+  pose (l:= rl);
+  generalize (refl_equal l);
+  unfold l at 2;
+  get_Pre RNG ();
+  let rl :=
+    match goal with
+    | [|- l = ?RL -> _ ] => RL
+    | _ => fail 1 "ring_simplify anomaly: bad goal after pre"
+    end in
+  let Heq := fresh "Heq" in
+  intros Heq;clear Heq l;
+  Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl;
+  get_Post RNG ().
+
+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 (PackRing Ring_simplify) [] rl G.
+
+Tactic Notation (at level 0)
+  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
+  let G := Get_goal in
+  ring_lookup (PackRing 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 (PackRing 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 (PackRing Ring_simplify) [lH] rl t;
+  intro H;
+  unfold g;clear g.
+
diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v
new file mode 100644
index 00000000..b3250a51
--- /dev/null
+++ b/plugins/setoid_ring/Ring_theory.v
@@ -0,0 +1,608 @@
+(************************************************************************)
+(*  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/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v
new file mode 100644
index 00000000..4cb5a05a
--- /dev/null
+++ b/plugins/setoid_ring/ZArithRing.v
@@ -0,0 +1,60 @@
+(************************************************************************)
+(*  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/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4
new file mode 100644
index 00000000..535dbdbd
--- /dev/null
+++ b/plugins/setoid_ring/newring.ml4
@@ -0,0 +1,1164 @@
+(************************************************************************)
+(*  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$ 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 Stringmap.empty
+let add_map s m = protect_maps := Stringmap.add s m !protect_maps
+let lookup_map map =
+  try Stringmap.find 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(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))
+
+(* Calling a global tactic *)
+let ltac_call tac (args:glob_tactic_arg list) =
+  TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args))
+
+(* Calling a locally bound tactic *)
+let ltac_lcall tac args =
+  TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args))
+
+let ltac_letin (x, e1) e2 =
+  TacLetIn(false,[(dummy_loc,id_of_string x),e1],e2)
+
+let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) =
+  Tacinterp.eval_tactic
+    (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args))
+
+let ltac_record flds =
+  TacFun([Some(id_of_string"proj")], ltac_lcall "proj" flds)
+
+
+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 plugin_dir = "setoid_ring"
+
+let cdir = ["Coq";plugin_dir]
+let plugin_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" plugin_modules c)
+
+let new_ring_path =
+  make_dirpath (List.map id_of_string ["Ring_tac";plugin_dir;"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";plugin_dir;"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 [plugin_dir;"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 find_ring_structure env sigma l =
+  match l with
+    | 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"\""))
+    | [] -> 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) }
+
+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 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)}
+
+
+let setoid_of_relation env a r =
+  let evm = Evd.empty in
+  try
+    lapp coq_mk_Setoid
+      [|a ; r ;
+	Rewrite.get_reflexive_proof env evm a r ;
+	Rewrite.get_symmetric_proof env evm a r ;
+	Rewrite.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(r,req) in
+	let add_m, add_m_lem =
+	  try Rewrite.default_morphism signature add
+          with Not_found ->
+            error "ring addition should be declared as a morphism" in
+	let mul_m, mul_m_lem =
+          try Rewrite.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 Rewrite.default_morphism ([Some(r,req)],Some(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 Smartlocate.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 Smartlocate.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 ltac_ring_structure e =
+  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
+  [req;sth;ext;morph;th;cst_tac;pow_tac;
+   lemma1;lemma2;pretac;posttac]
+
+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 in
+  let rl = carg (make_term_list e.ring_carrier rl) in
+  let lH = carg (make_hyp_list env lH) in
+  let ring = ltac_ring_structure e in
+  ltac_apply f (ring@[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";plugin_dir;"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 _ = Redexpr.declare_reduction "simpl_field_expr"
+  (protect_red "field")
+
+
+
+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 find_field_structure env sigma l =
+  check_required_library (cdir@["Field_tac"]);
+  match l with
+    | 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"\""))
+    | [] -> 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) }
+
+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 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) }
+
+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(r,req) in
+	let inv_m, inv_m_lem =
+	  try Rewrite.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 ltac_field_structure e =
+  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
+  [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
+   field_simpl_eq_in_ok;cond_ok;pretac;posttac]
+
+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 in
+  let rl = carg (make_term_list e.field_carrier rl) in
+  let lH = carg (make_hyp_list env lH) in
+  let field = ltac_field_structure e in
+  ltac_apply f (field@[lH;rl]) gl
+
+
+TACTIC EXTEND field_lookup
+| [ "field_lookup" tactic(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/plugins/setoid_ring/newring_plugin.mllib b/plugins/setoid_ring/newring_plugin.mllib
new file mode 100644
index 00000000..a98392f1
--- /dev/null
+++ b/plugins/setoid_ring/newring_plugin.mllib
@@ -0,0 +1,2 @@
+Newring
+Newring_plugin_mod
diff --git a/plugins/setoid_ring/vo.itarget b/plugins/setoid_ring/vo.itarget
new file mode 100644
index 00000000..6934375b
--- /dev/null
+++ b/plugins/setoid_ring/vo.itarget
@@ -0,0 +1,15 @@
+ArithRing.vo
+BinList.vo
+Field_tac.vo
+Field_theory.vo
+Field.vo
+InitialRing.vo
+NArithRing.vo
+RealField.vo
+Ring_base.vo
+Ring_equiv.vo
+Ring_polynom.vo
+Ring_tac.vo
+Ring_theory.vo
+Ring.vo
+ZArithRing.vo
diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml
new file mode 100644
index 00000000..4b95df19
--- /dev/null
+++ b/plugins/subtac/eterm.ml
@@ -0,0 +1,233 @@
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+(**
+   - 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: tactic 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 idf 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 (idf 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.
+*)
+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 mkVar 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 -> 
+		let c', s'', trans'' = subst_evar_constr evs n mkVar 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 mkVar 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.stable_sort
+    (fun (id, ev, deps) (id', ev', deps') ->
+      if id = id' then 0
+      else if Intset.mem id deps' then -1
+      else if Intset.mem id' deps then 1
+      else Pervasives.compare id id')
+    evl
+      
+let map_evar_body f = function
+  | Evar_empty -> Evar_empty
+  | Evar_defined c -> Evar_defined (f c)
+
+open Environ
+      
+let map_evar_info f evi =
+  { evi with evar_hyps = val_of_named_context (map_named_context f (named_context_of_val evi.evar_hyps));
+    evar_concl = f evi.evar_concl;
+    evar_body = map_evar_body f evi.evar_body }
+    
+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.interp 
+			  (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 mkVar t 
+  in
+  let ty, _, _ = subst_evar_constr evts 0 mkVar ty in
+  let evars = 
+    List.map (fun (ev, 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
+  let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in
+  let evmap f c = pi1 (subst_evar_constr evts 0 f c) in
+    Array.of_list (List.rev evars), (evnames, evmap), t', ty
+
+let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n
diff --git a/plugins/subtac/eterm.mli b/plugins/subtac/eterm.mli
new file mode 100644
index 00000000..406f9433
--- /dev/null
+++ b/plugins/subtac/eterm.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  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$ 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_map -> evar_map -> int ->
+  ?status:obligation_definition_status -> constr -> types -> 
+  (identifier * types * loc * obligation_definition_status * Intset.t * 
+      tactic option) array
+    (* Existential key, obl. name, type as product, location of the original evar, associated tactic,
+       status and dependencies as indexes into the array *)
+  * ((existential_key * identifier) list * ((identifier -> constr) -> constr -> constr)) * constr * types
+    (* Translations from existential identifiers to obligation identifiers 
+       and for terms with existentials to closed terms, given a 
+       translation from obligation identifiers to constrs, new term, new type *)
diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4
new file mode 100644
index 00000000..113b1680
--- /dev/null
+++ b/plugins/subtac/g_subtac.ml4
@@ -0,0 +1,177 @@
+(************************************************************************)
+(*  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$ *)
+
+
+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_withtac : Tacexpr.raw_tactic_expr option Gram.Entry.e = gec "subtac_withtac"
+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_withtac;
+
+  subtac_gallina_loc:
+    [ [ g = Vernac.gallina -> loc, g
+    | g = Vernac.gallina_ext -> loc, g ] ]
+    ;
+
+  subtac_withtac:
+    [ [ "with"; t = Tactic.tactic -> Some t
+      | -> 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 withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type
+
+let (wit_subtac_withtac : Genarg.tlevel withtac_argtype),
+  (globwit_subtac_withtac : Genarg.glevel withtac_argtype),
+  (rawwit_subtac_withtac : Genarg.rlevel withtac_argtype) =
+  Genarg.create_arg "subtac_withtac"
+
+VERNAC COMMAND EXTEND Subtac
+[ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ]
+  END
+
+let try_catch_exn f e =
+  try f e
+  with exn -> errorlabstrm "Program" (Cerrors.explain_exn exn)
+
+let subtac_obligation e = try_catch_exn Subtac_obligations.subtac_obligation e
+let next_obligation e = try_catch_exn Subtac_obligations.next_obligation e
+let try_solve_obligation e = try_catch_exn Subtac_obligations.try_solve_obligation e
+let try_solve_obligations e = try_catch_exn Subtac_obligations.try_solve_obligations e
+let solve_all_obligations e = try_catch_exn Subtac_obligations.solve_all_obligations e
+let admit_obligations e = try_catch_exn Subtac_obligations.admit_obligations e
+
+VERNAC COMMAND EXTEND Subtac_Obligations
+| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) subtac_withtac(tac) ] -> 
+    [ subtac_obligation (num, Some name, Some t) tac ]
+| [ "Obligation" integer(num) "of" ident(name) subtac_withtac(tac) ] -> 
+    [ subtac_obligation (num, Some name, None) tac ]
+| [ "Obligation" integer(num) ":" lconstr(t) subtac_withtac(tac) ] -> 
+    [ subtac_obligation (num, None, Some t) tac ]
+| [ "Obligation" integer(num) subtac_withtac(tac) ] -> 
+    [ subtac_obligation (num, None, None) tac ]
+| [ "Next" "Obligation" "of" ident(name) subtac_withtac(tac) ] -> 
+    [ next_obligation (Some name) tac ]
+| [ "Next" "Obligation" subtac_withtac(tac) ] -> [ next_obligation None tac ]
+END
+
+VERNAC COMMAND EXTEND Subtac_Solve_Obligation
+| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] ->
+    [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] ->
+    [ try_solve_obligation num None (Some (Tacinterp.interp t)) ]
+      END
+
+VERNAC COMMAND EXTEND Subtac_Solve_Obligations
+| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] ->
+    [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligations" "using" tactic(t) ] ->
+    [ try_solve_obligations None (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligations" ] ->
+    [ try_solve_obligations None None ]
+      END
+
+VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations
+| [ "Solve" "All" "Obligations" "using" tactic(t) ] ->
+    [ solve_all_obligations (Some (Tacinterp.interp t)) ]
+| [ "Solve" "All" "Obligations" ] ->
+    [ solve_all_obligations None ]
+      END
+
+VERNAC COMMAND EXTEND Subtac_Admit_Obligations
+| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ]
+| [ "Admit" "Obligations" ] -> [ admit_obligations None ]
+    END
+
+VERNAC COMMAND EXTEND Subtac_Set_Solver
+| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [
+    Subtac_obligations.set_default_tactic 
+      (Vernacexpr.use_section_locality ())
+      (Tacinterp.glob_tactic t) ]
+END
+
+VERNAC COMMAND EXTEND Subtac_Show_Solver
+| [ "Show" "Obligation" "Tactic" ] -> [
+    Pp.msgnl (Pptactic.pr_glob_tactic (Global.env ()) (Subtac_obligations.default_tactic_expr ())) ]
+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/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml
new file mode 100644
index 00000000..0eba0f63
--- /dev/null
+++ b/plugins/subtac/subtac.ml
@@ -0,0 +1,250 @@
+(************************************************************************)
+(*  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$ *)
+
+open Global
+open Pp
+open Util
+open Names
+open Sign
+open Evd
+open Term
+open Termops
+open Namegen
+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 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 ~term: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 (id_of_string "Unnamed_thm")
+ 	  (Pfedit.get_all_proof_names ())
+  in
+  let evm, c, typ, imps =
+    Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr t bl) None
+  in
+  let c = solve_tccs_in_type env id isevars evm c typ in
+    Lemmas.start_proof id kind c (fun loc gr ->
+      Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true imps;
+      hook loc gr)
+
+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_assumptions 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 [] (Topconstr.prod_constr_expr c bl) None
+    in
+    let c = solve_tccs_in_type env id isevars evm c typ in
+      List.iter (Command.declare_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_assumptions 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,guard)], lettop, hook) ->
+      if guard <> None then 
+        error "Do not support building theorems as a fixpoint.";
+      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 (abst, glob, sup, is, props, pri) ->
+      dump_constraint "inst" is;
+      if abst then
+	error "Declare Instance not supported here.";
+      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'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e'');
+	  raise e)
+
+  | e ->
+      msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e);
+      raise e
diff --git a/plugins/subtac/subtac.mli b/plugins/subtac/subtac.mli
new file mode 100644
index 00000000..b51150aa
--- /dev/null
+++ b/plugins/subtac/subtac.mli
@@ -0,0 +1,2 @@
+val require_library : string -> unit
+val subtac : Util.loc * Vernacexpr.vernac_expr -> unit
diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml
new file mode 100644
index 00000000..e8f4f05f
--- /dev/null
+++ b/plugins/subtac/subtac_cases.ml
@@ -0,0 +1,2027 @@
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+(************************************************************************)
+(*  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$ *)
+
+open Cases
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Namegen
+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
+
+(* 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 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_map 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
+
+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
+
+(* 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 n when signlen > 1 (* The term is of a dependent type,
+				      maybe some variable in its type appears in the tycon. *) ->
+	      (match tmtype with
+	      | NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *)
+	      | IsInd (_, IndType(indf,realargs)) ->
+		  let subst =
+		    if dependent tm c && List.for_all isRel realargs
+		    then (n, 1) :: subst else subst
+		  in
+		    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
+
+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 ( !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 ( !isevars) j.uj_type in
+  let t =
+    try IsInd (typ,find_rectype env ( !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 ( !(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 =  !(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
+
+(**********************************************************************)
+(* 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 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 Names.eq_ind 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 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) ( 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
+  it_mkLambda 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 ( !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 ( 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 ( !isevars) indf current tms p
+      | None -> infer_predicate loc env isevars typs cstrs indf in
+  let typ = whd_beta ( !isevars) (applist (pred, realargs)) in
+  if dep then
+    (pred, whd_beta ( !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 ( !(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 ( !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 ( 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 ( !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 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 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 mk_JMeq typ x typ' y =
+  mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |])
+let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |])
+
+let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true))
+
+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, _) = 
+	  try find_rectype env ( !isevars) (lift (-(List.length realargs)) ty) 
+	  with Not_found -> error_case_not_inductive env 
+	    {uj_val = ty; uj_type = Typing.type_of env !isevars 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 ( !isevars) app in
+	let IndType (indf, realargs) = find_rectype env ( !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 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 tycon =
+  let prev, ctx, names, tycon =
+    List.fold_left
+      (fun (prev, ctx, names, tycon) (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, tycon
+	   | _ ->
+	       let tycon = Option.map
+		 (fun t -> subst_term_occ all_occurrences (lift 1 c) (lift 1 t)) tycon in
+	       let name = next_ident_away (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, tycon)
+      ([], [], [], tycon) tomatchs
+  in List.rev prev, ctx, tycon
+
+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 (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 sigma (env : env) : env =
+  let nf t = nf_evar sigma 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
+
+
+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_evar !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 !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 tycon = valcon_of_tycon tycon in
+      let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env tomatchs tycon 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 ( !isevars) avoid tomatchs arsign
+
+      in
+      let tycon, arity =
+	match tycon' with
+	| None -> let ev = mkExistential env isevars in ev, ev
+	| Some t ->
+	    Option.get tycon, prepare_predicate_from_arsign_tycon loc env ( !isevars)
+	      tomatchs sign 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_evar !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/plugins/subtac/subtac_cases.mli b/plugins/subtac/subtac_cases.mli
new file mode 100644
index 00000000..90989d2d
--- /dev/null
+++ b/plugins/subtac/subtac_cases.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id$ 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/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml
new file mode 100644
index 00000000..59c877c8
--- /dev/null
+++ b/plugins/subtac/subtac_classes.ml
@@ -0,0 +1,182 @@
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+(************************************************************************)
+(*  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$ 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_constr_evars_gen evdref env ?(impls=([],[])) kind c =
+  SPretyping.understand_tcc_evars evdref env kind
+    (intern_gen (kind=IsType) ~impls ( !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 interp_context_evars evdref env params =
+  Constrintern.interp_context_gen
+    (fun env t -> SPretyping.understand_tcc_evars evdref env IsType t)
+    (SPretyping.understand_judgment_tcc evdref) !evdref env params
+
+let type_ctx_instance evars env ctx inst subst =
+  let rec aux (subst, instctx) l = function
+    (na, b, t) :: ctx ->
+      let t' = substl subst t in
+      let c', l =
+	match b with
+	| None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l
+	| Some b -> substl subst b, l
+      in
+       evars := resolve_typeclasses ~onlyargs:true ~fail:true env !evars;
+       let d = na, Some c', t' in
+	aux (c' :: subst, d :: instctx) l ctx
+    | [] -> subst
+  in aux (subst, []) inst (List.rev ctx)
+
+let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) pri =
+  let env = Global.env() in
+  let evars = ref 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, Idset.empty
+  in
+  let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in
+  let k, cty, ctx', ctx, len, imps, subst =
+    let (env', ctx), imps = interp_context_evars evars env ctx in
+    let c', imps' = interp_type_evars_impls ~evdref:evars env' tclass in
+    let len = List.length ctx in
+    let imps = imps @ Impargs.lift_implicits len imps' in
+    let ctx', c = decompose_prod_assum c' in
+    let ctx'' = ctx' @ ctx in
+    let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in
+    let _, args = 
+      List.fold_right (fun (na, b, t) (args, args') ->
+	match b with
+	| None -> (List.tl args, List.hd args :: args')
+	| Some b -> (args, substl args' b :: args'))
+	(snd cl.cl_context) (args, [])
+    in
+      cl, c', ctx', ctx, len, imps, 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
+	  Namegen.next_global_ident_away i (Termops.ids_of_context env)
+  in
+  let env' = push_rel_context ctx env in
+  evars := Evarutil.nf_evar_map !evars;
+  evars := resolve_typeclasses ~onlyargs:false ~fail:true env !evars;
+  let sigma =  !evars in
+  let subst = List.map (Evarutil.nf_evar sigma) subst in
+  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;
+	Inl fs
+    | _ -> Inr props
+  in
+  let subst =
+    match props with
+    | Inr term ->
+	let c = interp_casted_constr_evars evars env' term cty in
+	  Inr (c, subst)
+    | Inl props ->
+	let get_id =
+	  function
+	    | Ident id' -> id'
+	    | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled")
+	in
+	let props, rest =
+	  List.fold_left
+	    (fun (props, rest) (id,b,_) ->
+	      if b = None then
+		try
+		  let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in
+		  let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in
+		  let (loc, mid) = get_id loc_mid 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
+	      else props, rest)
+	    ([], props) k.cl_props
+	in
+	  if rest <> [] then
+	    unbound_method env' k.cl_impl (get_id (fst (List.hd rest)))
+	  else
+	    Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst)
+  in	  
+  evars := Evarutil.nf_evar_map !evars;
+  let term, termtype =
+    match subst with
+    | Inl subst ->
+	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 app, ty_constr = instance_constructor k subst in
+	let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
+	let term = Termops.it_mkLambda_or_LetIn app (ctx' @ ctx) in
+	  term, termtype
+    | Inr (def, subst) ->
+	let termtype = it_mkProd_or_LetIn cty ctx in
+	let term = Termops.it_mkLambda_or_LetIn def ctx in
+	  term, termtype
+  in
+  let termtype = Evarutil.nf_evar !evars termtype in
+  let term = Evarutil.nf_evar !evars term in
+  evars := undefined_evars !evars;
+  Evarutil.check_evars env Evd.empty !evars termtype;
+  let hook vis gr =
+    let cst = match gr with ConstRef kn -> kn | _ -> assert false in
+    let inst = Typeclasses.new_instance k pri global (ConstRef cst) in
+      Impargs.declare_manual_implicits false gr ~enriching:false imps;
+      Typeclasses.add_instance inst
+  in
+  let evm = Subtac_utils.evars_of_term !evars Evd.empty term in
+  let obls, _, constr, typ = Eterm.eterm_obligations env id !evars evm 0 term termtype in
+    id, Subtac_obligations.add_definition id ~term:constr typ ~kind:(Global,false,Instance) ~hook obls
diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli
new file mode 100644
index 00000000..ee78ff68
--- /dev/null
+++ b/plugins/subtac/subtac_classes.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  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$ 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_map ref ->
+  Environ.env ->
+    ('a * Term.constr option * Term.constr) list ->
+    Topconstr.constr_expr list ->
+    Term.constr list ->
+    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/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml
new file mode 100644
index 00000000..5337baca
--- /dev/null
+++ b/plugins/subtac/subtac_coercion.ml
@@ -0,0 +1,503 @@
+(* -*- 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$ *)
+
+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 ( !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 ( !isevars) x and y = nf_evar ( !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.splay_prod_n env ( !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 (Namegen.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 -> None
+		| _, _ ->
+		    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 := 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 =  !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 =  !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 ( 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 ( isevars) j.uj_type in
+		 (isevars,apply_coercion env ( 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 ( isevars) j.uj_type in
+      let j1 = apply_coercion env ( isevars) p j t in
+	(isevars,type_judgment env (j_nf_evar ( isevars) j1))
+    with Not_found ->
+      error_not_a_type_loc loc env ( isevars) j
+
+  let inh_coerce_to_sort loc env isevars j =
+    let typ = whd_betadeltaiota env ( 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 ( 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 ( 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 ( evd) (t,c1) in
+	  match v with
+	      Some v ->
+		let j = apply_coercion env ( 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 ( evd) t),
+      kind_of_term (whd_betadeltaiota env ( 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) =
+    match n with
+	None ->
+	  let (evd', val') =
+	    try
+	      inh_conv_coerce_to_fail loc env evd rigidonly
+		(Some (nf_evar evd cj.uj_val))
+		(nf_evar evd cj.uj_type) (nf_evar evd t)
+	    with NoCoercion ->
+	      let sigma =  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.splay_prod_n env ( 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 =  isevars in
+		error_cannot_coerce env' sigma (t, t'))
+	else isevars
+      with _ -> isevars
+end
diff --git a/plugins/subtac/subtac_coercion.mli b/plugins/subtac/subtac_coercion.mli
new file mode 100644
index 00000000..5678c10e
--- /dev/null
+++ b/plugins/subtac/subtac_coercion.mli
@@ -0,0 +1,4 @@
+open Term
+val disc_subset : types -> (types * types) option
+
+module Coercion : Coercion.S
diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml
new file mode 100644
index 00000000..f2747225
--- /dev/null
+++ b/plugins/subtac/subtac_command.ml
@@ -0,0 +1,534 @@
+open Closure
+open RedFlags
+open Declarations
+open Entries
+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 =
+  Evarutil.nf_evar !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 ( !isevars) env c in
+  let c' = SPretyping.understand_tcc_evars 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 ( !isevars) env c in
+  let c' = SPretyping.understand_tcc_evars 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 ( !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 ( !sigma) env t in
+    SPretyping.understand_tcc_evars 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 ( !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, 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)
+
+open Coqlib
+
+let sigT = Lazy.lazy_from_fun build_sigma_type
+let sigT_info = lazy
+  { ci_ind       = destInd (Lazy.force sigT).typ;
+    ci_npar      = 2;
+    ci_cstr_nargs = [|2|];
+    ci_pp_info   =  { ind_nargs = 0; style = LetStyle }
+  }
+
+let telescope = function
+  | [] -> assert false
+  | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1
+  | (n, None, t) :: tl ->
+      let ty, tys, (k, constr) =
+	List.fold_left
+	  (fun (ty, tys, (k, constr)) (n, b, t) ->
+	    let pred = mkLambda (n, t, ty) in
+	    let sigty = mkApp ((Lazy.force sigT).typ, [|t; pred|]) in
+	    let intro = mkApp ((Lazy.force sigT).intro, [|lift k t; lift k pred; mkRel k; constr|]) in
+	      (sigty, pred :: tys, (succ k, intro)))
+	  (t, [], (2, mkRel 1)) tl
+      in
+      let (last, subst) = List.fold_right2
+	(fun pred (n, b, t) (prev, subst) ->
+	  let proj1 = applistc (Lazy.force sigT).proj1 [t; pred; prev] in
+	  let proj2 = applistc (Lazy.force sigT).proj2 [t; pred; prev] in
+	    (lift 1 proj2, (n, Some proj1, t) :: subst))
+	(List.rev tys) tl (mkRel 1, [])
+      in ty, ((n, Some last, t) :: subst), constr
+
+  | _ -> raise (Invalid_argument "telescope")
+
+let nf_evar_context isevars ctx =
+  List.map (fun (n, b, t) ->
+    (n, Option.map (Evarutil.nf_evar isevars) b, Evarutil.nf_evar isevars t)) ctx
+
+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 (env', binders_rel), impls = interp_context_evars isevars env bl in
+  let len = List.length binders_rel in
+  let top_env = push_rel_context binders_rel env in
+  let top_arity = interp_type_evars isevars top_env arityc in
+  let full_arity = it_mkProd_or_LetIn top_arity binders_rel in
+  let argtyp, letbinders, make = telescope binders_rel in
+  let argname = id_of_string "recarg" in
+  let arg = (Name argname, None, argtyp) in
+  let binders = letbinders @ [arg] in
+  let binders_env = push_rel_context binders_rel env in
+  let rel = interp_constr isevars env r in
+  let relty = type_of env !isevars rel in
+  let relargty =
+    let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in
+      match ctx, kind_of_term ar with
+      | [(_, None, t); (_, None, u)], Sort (Prop Null)
+	  when Reductionops.is_conv env !isevars t u -> t
+      | _, _ ->
+	  user_err_loc (constr_loc r,
+		       "Subtac_command.build_wellfounded",
+		       my_print_constr env rel ++ str " is not an homogeneous binary relation.")
+  in
+  let measure = interp_casted_constr isevars binders_env measure relargty in
+  let wf_rel, wf_rel_fun, measure_fn =
+    let measure_body, measure =
+      it_mkLambda_or_LetIn measure letbinders,
+      it_mkLambda_or_LetIn measure binders
+    in
+    let comb = constr_of_global (Lazy.force measure_on_R_ref) in
+    let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in
+    let wf_rel_fun x y =
+      mkApp (rel, [| subst1 x measure_body;
+ 		     subst1 y measure_body |])
+    in wf_rel, wf_rel_fun, measure
+  in
+  let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |]) in
+  let argid' = id_of_string (string_of_id argname ^ "'") in
+  let wfarg len = (Name argid', None,
+  		  mkSubset (Name argid') argtyp
+		    (wf_rel_fun (mkRel 1) (mkRel (len + 1))))
+  in
+  let intern_bl = wfarg 1 :: [arg] in
+  let _intern_env = push_rel_context intern_bl env in
+  let proj = (Lazy.force sig_).Coqlib.proj1 in
+  let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in
+  let projection = (* in wfarg :: arg :: before *)
+    mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |])
+  in
+  let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in
+  let intern_arity = substl [projection] top_arity_let in
+  (* substitute the projection of wfarg for something,
+     now intern_arity is in wfarg :: arg *)
+  let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
+  let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in
+  let curry_fun =
+    let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in
+    let arg = mkApp ((Lazy.force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in
+    let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in
+    let rcurry = mkApp (rel, [| measure; lift len measure |]) in
+    let lam = (Name (id_of_string "recproof"), None, rcurry) in
+    let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in
+    let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in
+      (Name recname, Some body, ty)
+  in
+  let fun_bl = intern_fun_binder :: [arg] in
+  let lift_lets = Termops.lift_rel_context 1 letbinders in
+  let intern_body =
+    let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in
+    let (r, l, impls, scopes) = 
+      Constrintern.compute_internalization_data env
+	Constrintern.Recursive full_arity impls 
+    in
+    let newimpls = [(recname, (r, l, impls @ 
+      [Some (id_of_string "recproof", Impargs.Manual, (true, false))], 
+			      scopes @ [None]))] in
+    let newimpls = Constrintern.set_internalization_env_params newimpls [] in
+    interp_casted_constr isevars ~impls:newimpls
+      (push_rel_context ctx env) body (lift 1 top_arity)
+  in
+  let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in
+  let prop = mkLambda (Name argname, argtyp, top_arity_let) in
+  let def =
+    mkApp (constr_of_global (Lazy.force fix_sub_ref),
+	  [| argtyp ; wf_rel ;
+	     make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ;
+	     prop ; intern_body_lam |])
+  in
+  let _ = isevars := Evarutil.nf_evar_map !isevars in
+  let binders_rel = nf_evar_context !isevars binders_rel in
+  let binders = nf_evar_context !isevars binders in
+  let top_arity = Evarutil.nf_evar !isevars top_arity in
+  let hook, recname, typ = 
+    if List.length binders_rel > 1 then
+      let name = add_suffix recname "_func" in
+      let hook l gr = 
+	let body = it_mkLambda_or_LetIn (mkApp (constr_of_global gr, [|make|])) binders_rel in
+	let ty = it_mkProd_or_LetIn top_arity binders_rel in
+	let ce =
+	  { const_entry_body = Evarutil.nf_evar !isevars body;
+	    const_entry_type = Some ty;
+	    const_entry_opaque = false;
+	    const_entry_boxed = false} 
+	in 
+	let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in
+	let gr = ConstRef c in
+	  if Impargs.is_implicit_args () || impls <> [] then
+	    Impargs.declare_manual_implicits false gr impls
+      in
+      let typ = it_mkProd_or_LetIn top_arity binders in
+	hook, name, typ
+    else 
+      let typ = it_mkProd_or_LetIn top_arity binders_rel in
+      let hook l gr = 
+	if Impargs.is_implicit_args () || impls <> [] then
+	  Impargs.declare_manual_implicits false gr impls
+      in hook, recname, typ
+  in
+  let fullcoqc = Evarutil.nf_evar !isevars def in
+  let fullctyp = Evarutil.nf_evar !isevars typ in
+  let evm = evars_of_term !isevars Evd.empty fullctyp in
+  let evm = evars_of_term !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 ~term:evars_def evars_typ evars ~hook
+
+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 = Option.map (fun c -> interp_casted_constr_evars evdref env ~impls c ccl) fix.Command.fix_body in
+  Option.map (fun c -> it_mkLambda_or_LetIn c ctx) body
+
+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 =  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 _
+	      | ImplicitArg (_, _, false) -> ()
+	      | _ ->
+		  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 out_def = function
+  | Some def -> def
+  | None -> error "Program Fixpoint needs defined bodies."
+
+let interp_recursive fixkind l boxed =
+  let env = Global.env() in
+  let fixl, ntnl = List.split l in
+  let kind = fixkind <> IsCoFixpoint in
+  let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in
+
+  (* Interp arities allowing for unresolved types *)
+  let evdref = ref 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 ->
+      let sort = Retyping.get_type_of env !evdref t in
+      let fixprot =
+	try mkApp (Lazy.force Subtac_utils.fix_proto, [|sort; t|])
+	with e -> t
+      in
+	(id,None,fixprot) :: env')
+      [] fixnames fixtypes
+  in
+  let env_rec = push_named_context rec_sign env in
+
+  (* Get interpretation metadatas *)
+  let impls = Constrintern.compute_full_internalization_env env 
+    Constrintern.Recursive [] fixnames fixtypes fiximps 
+  in
+  let notations = List.flatten ntnl in
+
+  (* Interp bodies with rollback because temp use of notations/implicit *)
+  let fixdefs =
+    States.with_state_protection (fun () ->
+      List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
+      list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls)
+      () in
+
+  let fixdefs = List.map out_def fixdefs in
+
+  (* Instantiate evars and check all are resolved *)
+  let evd,_ = Evarconv.consider_remaining_unif_problems env_rec !evdref in
+  let evd = Typeclasses.resolve_typeclasses
+    ~onlyargs:true ~split:true ~fail:false env_rec evd
+  in
+  let evd = Evarutil.nf_evar_map evd in
+  let fixdefs = List.map (nf_evar evd) fixdefs in
+  let fixtypes = List.map (nf_evar evd) fixtypes in
+  let rec_sign = nf_named_context_evar 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 =  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
+      | 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
+      | 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, n, bl, typ, out_def def) r
+		    (match n with Some n -> mkIdentC (snd n) | None ->
+		      errorlabstrm "Subtac_command.build_recursive"
+			(str "Recursive argument required for well-founded fixpoints"))
+		    ntn false)
+
+      | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] ->
+	  ignore(build_wellfounded (id, n, bl, typ, out_def def) (Option.default (CRef lt_ref) r)
+		    m 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 (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 IsCoFixpoint fixl b
diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli
new file mode 100644
index 00000000..304aa139
--- /dev/null
+++ b/plugins/subtac/subtac_command.mli
@@ -0,0 +1,60 @@
+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_map ref ->
+  env ->
+  ?impls:full_internalization_env ->
+  ?allow_patvar:bool ->
+  ?ltacvars:ltac_sign ->
+  constr_expr -> constr
+val interp_constr :
+  evar_map ref ->
+  env -> constr_expr -> constr
+val interp_type_evars :
+  evar_map ref ->
+  env ->
+  ?impls:full_internalization_env ->
+  constr_expr -> constr
+val interp_casted_constr_evars :
+  evar_map ref ->
+  env ->
+  ?impls:full_internalization_env ->
+  constr_expr -> types -> constr
+val interp_open_constr :
+  evar_map ref -> env -> constr_expr -> constr
+val interp_constr_judgment :
+  evar_map ref ->
+  env ->
+  constr_expr -> unsafe_judgment
+val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list
+
+val interp_binder :     Evd.evar_map ref ->
+    Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr
+
+
+val telescope :
+  (Names.name * 'a option * Term.types) list ->
+  Term.types * (Names.name * Term.types option * Term.types) list *
+    Term.constr
+
+val build_wellfounded :
+           Names.identifier * 'a * Topconstr.local_binder list *
+           Topconstr.constr_expr * Topconstr.constr_expr ->
+           Topconstr.constr_expr ->
+           Topconstr.constr_expr -> 'b -> 'c -> Subtac_obligations.progress
+
+val build_recursive :
+  (fixpoint_expr * decl_notation list) list -> bool -> unit
+
+val build_corecursive :
+  (cofixpoint_expr * decl_notation list) list -> bool -> unit
diff --git a/plugins/subtac/subtac_errors.ml b/plugins/subtac/subtac_errors.ml
new file mode 100644
index 00000000..067da150
--- /dev/null
+++ b/plugins/subtac/subtac_errors.ml
@@ -0,0 +1,24 @@
+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/plugins/subtac/subtac_errors.mli b/plugins/subtac/subtac_errors.mli
new file mode 100644
index 00000000..8d75b9c0
--- /dev/null
+++ b/plugins/subtac/subtac_errors.mli
@@ -0,0 +1,15 @@
+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/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml
new file mode 100644
index 00000000..2836bc73
--- /dev/null
+++ b/plugins/subtac/subtac_obligations.ml
@@ -0,0 +1,652 @@
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+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)
+
+let reduce =
+  Reductionops.clos_norm_flags Closure.betaiotazeta (Global.env ()) Evd.empty
+
+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
+			 * tactic 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 : tactic option;
+  }
+
+type obligations = (obligation array * int)
+
+type fixpoint_kind =
+  | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list
+  | IsCoFixpoint
+
+type notations = (Vernacexpr.lstring * 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 : fixpoint_kind option ;
+  prg_implicits : (Topconstr.explicitation * (bool * 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   = ["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 true 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_keys m = ProgMap.fold (fun k _ l -> k :: l) 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 (Tacexpr.TacId [])
+
+(** Beware: if this code is dynamically loaded via dynlink after the start
+    of Coq, then this [init] function will not be run by [Lib.init ()].
+    Luckily, here we can launch [init] at load-time. *)
+
+let _ = init ()
+
+let _ =
+  Summary.declare_summary "program-tcc-table"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init }
+
+let progmap_union = ProgMap.fold ProgMap.add
+
+let cache (_, (local, tac)) =
+  set_default_tactic tac
+
+let load (_, (local, tac)) =
+  if not local then set_default_tactic tac
+
+let subst (s, (local, tac)) =
+  (local, Tacinterp.subst_tactic s tac)
+
+let (input,output) =
+  declare_object
+    { (default_object "Program state") with
+      cache_function = cache;
+      load_function = (fun _ -> load);
+      open_function = (fun _ -> load);
+      classify_function = (fun (local, tac) ->
+	if not (ProgMap.is_empty !from_prg) then
+	  errorlabstrm "Program" (str "Unsolved obligations when closing module:" ++ spc () ++
+				     prlist_with_sep spc (fun x -> Nameops.pr_id x)
+				     (map_keys !from_prg));
+	if local then Dispose else Substitute (local, tac));
+      subst_function = subst}
+    
+let update_state local =
+  Lib.add_anonymous_leaf (input (local, !default_tactic_expr))
+
+let set_default_tactic local t =
+  set_default_tactic t; update_state local
+
+open Evd
+
+let progmap_remove prg =
+  from_prg := ProgMap.remove prg.prg_name !from_prg
+
+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 true 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");
+	  progmap_remove prg; 
+          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);
+	  progmap_remove prg; 
+	  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 (decompose_prod_n_assum m fixtype) in
+	list_map_i (fun i _ -> i) 0 ctx
+
+let declare_mutual_definition l =
+  let len = List.length l in
+  let first = List.hd l in
+  let fixdefs, fixtypes, fiximps =
+    list_split3
+      (List.map (fun x -> 
+	let subs, typ = (subst_body true x) in
+	let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in
+	let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in
+	  reduce term, reduce 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 Metasyntax.add_notation_interpretation first.prg_notations;
+    Declare.recursive_message (fixkind<>IsCoFixpoint) indexes fixnames;
+    let gr = List.hd kns in
+    let kn = match gr with ConstRef kn -> kn | _ -> assert false in
+      first.prg_hook local gr;
+      List.iter progmap_remove l; kn
+      
+let declare_obligation prg obl body =
+  let body = reduce body in
+  let ty = reduce obl.obl_type in
+  match obl.obl_status with
+  | Expand -> { obl with obl_body = Some body }
+  | Define opaque ->
+      let opaque = if get_proofs_transparency () then false else opaque in
+      let ce = 
+	{ const_entry_body = body;
+	  const_entry_type = Some ty;
+	  const_entry_opaque = opaque;
+	  const_entry_boxed = false} 
+      in
+      let constant = Declare.declare_constant obl.obl_name
+	(DefinitionEntry ce,IsProof Property)
+      in
+	if not opaque then
+	  Auto.add_hints false [string_of_id prg.prg_name]
+	    (Auto.HintsUnfoldEntry [EvalConstRef constant]);
+	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', b = 
+    match b with
+    | None ->
+	assert(obls = [||]);
+	let n = Nameops.add_suffix n "_obligation" in
+	  [| { obl_name = n; obl_body = None;
+	       obl_location = dummy_loc; obl_type = t;
+	       obl_status = Expand; obl_deps = Intset.empty; obl_tac = None } |],
+	mkVar n
+    | Some b ->
+	Array.mapi
+	  (fun i (n, t, l, o, d, tac) ->
+            { obl_name = n ; obl_body = None; 
+	      obl_location = l; obl_type = red t; obl_status = o;
+	      obl_deps = d; obl_tac = tac })
+	  obls, b
+  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 all_programs () =
+  ProgMap.fold (fun k p l -> p :: l) !from_prg []
+
+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;
+    if rem > 0 then Remain rem
+    else (
+      match prg'.prg_deps with
+      | [] ->
+	  let kn = declare_definition prg' in
+	    progmap_remove 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
+		Defined (ConstRef kn)
+	    else Dependent)
+
+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 tac =
+  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
+	    Lemmas.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
+		    if transparent then
+		      Auto.add_hints true [string_of_id prg.prg_name]
+			(Auto.HintsUnfoldEntry [EvalConstRef cst]);
+		    { obl with obl_body = Some body }
+		in
+		let obls = Array.copy obls in
+		let _ = obls.(num) <- obl in
+		let res = try update_obls prg obls (pred rem)
+		  with e -> pperror (Cerrors.explain_exn e)
+		in
+		  match res 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;
+	    Option.iter (fun tac -> Pfedit.set_end_tac (Tacinterp.interp tac)) tac;
+	    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) tac =
+  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 tac
+	  | 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 -> t
+		  | None -> !default_tactic
+	    in
+	    let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in
+	      obls.(i) <- declare_obligation prg 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", Lazy.force 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_of_prg ?(msg=true) prg =
+  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_obligations ?(msg=true) n =
+  let progs = match n with
+    | None -> all_programs ()
+    | Some n ->
+	try [ProgMap.find n !from_prg]
+	with Not_found -> raise (NoObligations (Some n))
+  in List.iter (show_obligations_of_prg ~msg) progs
+
+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 ?term 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 term 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
+      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 (Some 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 tac =
+  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 tac
+
+let default_tactic () = !default_tactic
+let default_tactic_expr () = !default_tactic_expr
diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli
new file mode 100644
index 00000000..1608c134
--- /dev/null
+++ b/plugins/subtac/subtac_obligations.mli
@@ -0,0 +1,69 @@
+open Names
+open Util
+open Libnames
+open Evd
+open Proof_type
+
+type obligation_info =
+  (identifier * Term.types * loc *
+      obligation_definition_status * Intset.t * tactic 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 : bool -> Tacexpr.glob_tactic_expr -> unit
+val default_tactic : unit -> Proof_type.tactic
+val default_tactic_expr : unit -> Tacexpr.glob_tactic_expr
+
+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:Term.constr -> Term.types -> 
+  ?implicits:(Topconstr.explicitation * (bool * bool * bool)) list ->
+  ?kind:Decl_kinds.definition_kind ->
+  ?tactic:Proof_type.tactic ->
+  ?hook:(Tacexpr.declaration_hook) -> obligation_info -> progress
+
+type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list
+
+type fixpoint_kind =
+  | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list
+  | IsCoFixpoint
+
+val add_mutual_definitions :
+  (Names.identifier * Term.constr * Term.types *
+      (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list ->
+  ?tactic:Proof_type.tactic ->
+  ?kind:Decl_kinds.definition_kind ->
+  ?hook:Tacexpr.declaration_hook ->
+  notations ->
+  fixpoint_kind -> unit
+
+val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option ->
+  Tacexpr.raw_tactic_expr option -> unit
+
+val next_obligation : Names.identifier option -> Tacexpr.raw_tactic_expr 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/plugins/subtac/subtac_plugin.mllib b/plugins/subtac/subtac_plugin.mllib
new file mode 100644
index 00000000..a4b9d67e
--- /dev/null
+++ b/plugins/subtac/subtac_plugin.mllib
@@ -0,0 +1,13 @@
+Subtac_utils
+Eterm
+Subtac_errors
+Subtac_coercion
+Subtac_obligations
+Subtac_cases
+Subtac_pretyping_F
+Subtac_pretyping
+Subtac_command
+Subtac_classes
+Subtac
+G_subtac
+Subtac_plugin_mod
diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml
new file mode 100644
index 00000000..f1541f25
--- /dev/null
+++ b/plugins/subtac/subtac_pretyping.ml
@@ -0,0 +1,137 @@
+(************************************************************************)
+(*  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$ *)
+
+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 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_map !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 unevd' = Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:false env unevd' in
+  let evm =  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 ( evd) env
+let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_type ( 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 = Topconstr.abstract_constr_expr c bl in
+  let tycon =
+    match tycon with
+	None -> empty_tycon
+      | Some t ->
+	  let t = Topconstr.prod_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 ( !isevars) in
+  let ty = nf_evar !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 ~term:def ty ~implicits:imps ~kind ~hook evars
diff --git a/plugins/subtac/subtac_pretyping.mli b/plugins/subtac/subtac_pretyping.mli
new file mode 100644
index 00000000..055c6df2
--- /dev/null
+++ b/plugins/subtac/subtac_pretyping.mli
@@ -0,0 +1,23 @@
+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_map ref ->
+    Rawterm.rawconstr ->
+    Evarutil.type_constraint -> Term.constr * Term.constr
+
+val subtac_process : env -> evar_map 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_map ref -> identifier -> local_binder list ->
+  constr_expr -> constr_expr option -> Subtac_obligations.progress
diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml
new file mode 100644
index 00000000..e574ef3b
--- /dev/null
+++ b/plugins/subtac/subtac_pretyping_F.ml
@@ -0,0 +1,645 @@
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+(************************************************************************)
+(*  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$ *)
+
+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 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 evdref =
+    let (evd',x) = f !evdref in
+      evdref := evd';
+      x
+
+  let evd_comb1 f evdref x =
+    let (evd',y) = f !evdref x in
+      evdref := evd';
+      y
+
+  let evd_comb2 f evdref x y =
+    let (evd',z) = f !evdref x y in
+      evdref := evd';
+      z
+
+  let evd_comb3 f evdref x y z =
+    let (evd',t) = f !evdref x y z in
+      evdref := 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 evdref 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 evdref (vdefj.(i)).uj_type
+		    (lift lt lar.(i))) then
+            error_ill_typed_rec_body_loc loc env ( !evdref)
+              i lna vdefj lar
+	done
+
+  let check_branches_message loc env evdref c (explft,lft) =
+    for i = 0 to Array.length explft - 1 do
+      if not (e_cumul env evdref lft.(i) explft.(i)) then
+	let sigma =  !evdref 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 evdref j = function
+    | None -> j_nf_evar !evdref j
+    | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) evdref j t
+
+  let push_rels vars env = List.fold_right push_rel vars env
+
+  (*
+    let evar_type_case evdref env ct pt lft p c =
+    let (mind,bty,rslty) = type_case_branches env ( evdref) ct pt p c
+    in check_branches_message evdref 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 invert_ltac_bound_name env id0 id =
+    try mkRel (pi1 (lookup_rel_id id (rel_context env)))
+    with Not_found ->
+      errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++
+	str " depends on pattern variable name " ++ pr_id id ++
+	str " which is not bound in current context")
+
+  let pretype_id loc env sigma (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
+	  let (ids,c) = List.assoc id lvar in
+	  let subst = List.map (invert_ltac_bound_name env id) ids in
+	  let c = substl subst c in
+	  { uj_val = c; uj_type = Retyping.get_type_of env sigma c }
+	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=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign}
+
+  (*************************************************************************)
+  (* Main pretyping function                                               *)
+
+  let pretype_ref evdref 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 evdref lvar lmeta cstr] attempts to type [cstr] *)
+  (* in environment [env], with existential variables [( evdref)] and *)
+  (* the type constraint tycon *)
+  let rec pretype (tycon : type_constraint) env evdref 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 evdref
+	  (pretype_ref evdref env ref)
+	  tycon
+
+    | RVar (loc, id) ->
+	inh_conv_coerce_to_tycon loc env evdref
+	  (pretype_id loc env !evdref 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 ( !evdref) 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 ( !evdref) c) in
+	  inh_conv_coerce_to_tycon loc env evdref 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 evdref env ~src:(loc,InternalHole) (new_Type ()) in
+	  { uj_val = e_new_evar evdref 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 evdref 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 evdref lvar ty in
+              let bd' = pretype (mk_tycon ty'.utj_val) env evdref 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) evdref 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 =
+	  let marked_ftys =
+	    Array.map (fun ty -> let sort = Retyping.get_type_of env !evdref ty in
+				   mkApp (Lazy.force Subtac_utils.fix_proto, [| sort; ty |]))
+	      ftys
+	  in
+	    push_rec_types (names,marked_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 ->
+		      evdref := Coercion.inh_conv_coerces_to loc env !evdref ftys.(i) tycon)
+		      tycon;
+		    nf_evar !evdref 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 evdref 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 evdref names ftys vdefj;
+	let ftys = Array.map (nf_evar ( !evdref)) ftys in
+	let fdefs = Array.map (fun x -> nf_evar ( !evdref) (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 evdref fixj tycon
+
+    | RSort (loc,s) ->
+	inh_conv_coerce_to_tycon loc env evdref (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 evdref 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) evdref resj in
+              let resty = whd_betadeltaiota env ( !evdref) resj.uj_type in
+      		match kind_of_term resty with
+		  | Prod (na,c1,c2) ->
+		      Option.iter (fun ty -> evdref :=
+			Coercion.inh_conv_coerces_to loc env !evdref resty ty) tycon;
+		      let evd, (_, _, tycon) = split_tycon loc env !evdref tycon in
+		      evdref := evd;
+		      let hj = pretype (mk_tycon (nf_evar !evdref c1)) env evdref lvar c in
+		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
+		      let typ' = nf_evar !evdref typ in
+			apply_rec env (n+1)
+			  { uj_val = nf_evar !evdref value;
+			    uj_type = nf_evar !evdref typ' }
+			  (Option.map (fun (abs, c) -> abs, nf_evar !evdref c) tycon) rest
+
+		  | _ ->
+		      let hj = pretype empty_tycon env evdref lvar c in
+			error_cant_apply_not_functional_loc
+			  (join_loc floc argloc) env ( !evdref)
+	      		  resj [hj]
+	in
+	let resj = j_nf_evar ( !evdref) (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 =  !evdref 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 evdref 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')
+	  evdref tycon
+	in
+	let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in
+	let dom_valcon = valcon_of_tycon dom in
+	let j = pretype_type dom_valcon env evdref lvar c1 in
+	let var = (name,None,j.utj_val) in
+	let j' = pretype rng (push_rel var env) evdref lvar c2 in
+	let resj = judge_of_abstraction env name j j' in
+	  inh_conv_coerce_to_tycon loc env evdref resj tycon
+
+    | RProd(loc,name,k,c1,c2)        ->
+	let j = pretype_type empty_valcon env evdref 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' evdref 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 evdref resj tycon
+
+    | RLetIn(loc,name,c1,c2)      ->
+	let j = pretype empty_tycon env evdref 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) evdref 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 evdref lvar c in
+	let (IndType (indf,realargs)) =
+	  try find_rectype env ( !evdref) cj.uj_type
+	  with Not_found ->
+	    let cloc = loc_of_rawconstr c in
+	      error_case_not_inductive_loc cloc env ( !evdref) 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 evdref lvar p in
+		     let ccl = nf_evar ( !evdref) 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 ( !evdref) lp inst in
+		     let fj = pretype (mk_tycon fty) env_f evdref 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 evdref lvar d in
+		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
+		     let ccl = nf_evar ( !evdref) 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 ( !evdref)
+			   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 evdref lvar c in
+	let (IndType (indf,realargs)) =
+	  try find_rectype env ( !evdref) cj.uj_type
+	  with Not_found ->
+	    let cloc = loc_of_rawconstr c in
+	      error_case_not_inductive_loc cloc env ( !evdref) 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 evdref lvar p in
+		let ccl = nf_evar ( !evdref) 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 evdref {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 evdref env ~src:(loc,InternalHole) (new_Type ())
+		in
+		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
+	  let pred = nf_evar ( !evdref) pred in
+	  let p = nf_evar ( !evdref) 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 evdref 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 evdref -> pretype vtyc env evdref lvar),evdref)
+	  tycon env (* loc *) (po,tml,eqns)
+
+    | RCast (loc,c,k) ->
+	let cj =
+	  match k with
+	      CastCoerce ->
+		let cj = pretype empty_tycon env evdref lvar c in
+		  evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj
+	    | CastConv (k,t) ->
+		let tj = pretype_type empty_valcon env evdref lvar t in
+		let cj = pretype (mk_tycon tj.utj_val) env evdref 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 evdref cj tycon
+
+    | RDynamic (loc,d) ->
+	if (Dyn.tag d) = "constr" then
+	  let c = constr_out d in
+	  let j = (Retyping.get_judgment_of env ( !evdref) c) in
+	    j
+	      (*inh_conv_coerce_to_tycon loc env evdref j tycon*)
+	else
+	  user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic."))
+
+  (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
+  and pretype_type valcon env evdref lvar = function
+    | RHole loc ->
+	(match valcon with
+	   | Some v ->
+               let s =
+		 let sigma =  !evdref 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 ev when is_Type (existential_type sigma ev) ->
+			 evd_comb1 (define_evar_as_sort) evdref ev
+                     | _ -> 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 evdref env ~src:loc (mkSort s);
+		   utj_type = s})
+    | c ->
+	let j = pretype empty_tycon env evdref lvar c in
+	let loc = loc_of_rawconstr c in
+	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
+	  match valcon with
+	    | None -> tj
+	    | Some v ->
+		if e_cumul env evdref v tj.utj_val then tj
+		else
+		  error_unexpected_type_loc
+                    (loc_of_rawconstr c) env ( !evdref) tj.utj_val v
+
+  let pretype_gen expand_evar fail_evar resolve_classes evdref 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 evdref lvar c).uj_val
+      | IsType ->
+	  (pretype_type empty_valcon env evdref lvar c).utj_val in
+    evdref := fst (consider_remaining_unif_problems env !evdref);
+    if resolve_classes then
+      evdref :=
+        Typeclasses.resolve_typeclasses ~onlyargs:false
+	  ~split:true ~fail:fail_evar env !evdref;
+    let c = if expand_evar then nf_evar !evdref c' else c' in
+    if fail_evar then check_evars env Evd.empty !evdref c;
+    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 evdref = ref (create_evar_defs sigma) in
+    let j = pretype empty_tycon env evdref ([],[]) c in
+    let evd,_ = consider_remaining_unif_problems env !evdref in
+    let j = j_nf_evar evd j in
+    check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
+    j
+
+  let understand_judgment_tcc evdref env c =
+    let j = pretype empty_tycon env evdref ([],[]) c in
+    j_nf_evar !evdref 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 expand_evar fail_evar resolve_classes sigma env lvar kind c =
+    let evdref = ref (Evd.create_evar_defs sigma) in
+    let c = pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c in
+    !evdref, c
+
+  (** Entry points of the high-level type synthesis algorithm *)
+
+  let understand_gen kind sigma env c =
+    snd (ise_pretype_gen true true true sigma env ([],[]) kind c)
+
+  let understand sigma env ?expected_type:exptyp c =
+    snd (ise_pretype_gen true true true sigma env ([],[]) (OfType exptyp) c)
+
+  let understand_type sigma env c =
+    snd (ise_pretype_gen true false true sigma env ([],[]) IsType c)
+
+  let understand_ltac expand_evar sigma env lvar kind c =
+    ise_pretype_gen expand_evar false true sigma env lvar kind c
+
+  let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
+    ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c
+
+  let understand_tcc_evars ?(fail_evar=false) ?(resolve_classes=true) evdref env kind c =
+    pretype_gen true fail_evar resolve_classes evdref env ([],[]) kind c
+end
+
+module Default : S = SubtacPretyping_F(Coercion.Default)
diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml
new file mode 100644
index 00000000..06a80f68
--- /dev/null
+++ b/plugins/subtac/subtac_utils.ml
@@ -0,0 +1,484 @@
+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 tactics_module = subtac_dir @ ["Tactics"]
+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 measure_on_R_ref = make_ref fixsub_module "MR"
+let fix_measure_sub_ref = make_ref fixsub_module "Fix_measure_sub"
+let refl_ref = make_ref ["Init";"Logic"] "refl_equal"
+
+let make_ref s = Qualid (dummy_loc, qualid_of_string s)
+let lt_ref = make_ref "Init.Peano.lt"
+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 fix_proto = lazy (init_constant tactics_module "fix_proto")
+let fix_proto_ref () = 
+  match Nametab.global (make_ref "Program.Tactics.fix_proto") with
+  | ConstRef c -> c
+  | _ -> assert false
+
+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 =
+  lazy (check_required_library ["Coq";"Logic";"JMeq"];
+	init_constant ["Logic";"JMeq"] "JMeq")
+let jmeq_rec =
+  lazy (check_required_library ["Coq";"Logic";"JMeq"];
+	init_constant ["Logic";"JMeq"] "JMeq_rec")
+let jmeq_refl =
+  lazy (check_required_library ["Coq";"Logic";"JMeq"];
+	init_constant ["Logic";"JMeq"] "JMeq_refl")
+
+let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex")
+let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro")
+
+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_map
+
+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"
+  | MatchingVar _ -> "MatchingVar"
+
+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
+	 | ImplicitArg (_,_,false) -> 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 [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 (Lazy.force jmeq_ind, [| typ; x ; typ'; y |])
+let mk_JMeq_refl typ x = mkApp (Lazy.force 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
+    Lemmas.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_comma (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 (); 
+      Inductiveops.control_only_guard (Global.env ())
+	const.Entries.const_entry_body;
+      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_map evd =
+  let pp_evm =
+    let evars =  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/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli
new file mode 100644
index 00000000..d0ad334d
--- /dev/null
+++ b/plugins/subtac/subtac_utils.mli
@@ -0,0 +1,136 @@
+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 measure_on_R_ref : global_reference lazy_t
+val fix_measure_sub_ref : global_reference lazy_t
+val refl_ref : global_reference lazy_t
+val lt_ref : reference
+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 fix_proto : constr lazy_t
+val fix_proto_ref : unit -> constant
+
+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 : constr lazy_t
+val jmeq_rec : constr lazy_t
+val jmeq_refl : constr lazy_t
+
+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_map -> 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_map 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_map 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_map : evar_map -> 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/plugins/subtac/test/ListDep.v b/plugins/subtac/test/ListDep.v
new file mode 100644
index 00000000..e3dbd127
--- /dev/null
+++ b/plugins/subtac/test/ListDep.v
@@ -0,0 +1,49 @@
+(* -*- 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/plugins/subtac/test/ListsTest.v b/plugins/subtac/test/ListsTest.v
new file mode 100644
index 00000000..2cea0841
--- /dev/null
+++ b/plugins/subtac/test/ListsTest.v
@@ -0,0 +1,99 @@
+(* -*- 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/plugins/subtac/test/Mutind.v b/plugins/subtac/test/Mutind.v
new file mode 100644
index 00000000..01e2d75f
--- /dev/null
+++ b/plugins/subtac/test/Mutind.v
@@ -0,0 +1,20 @@
+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/plugins/subtac/test/Test1.v b/plugins/subtac/test/Test1.v
new file mode 100644
index 00000000..7e0755d5
--- /dev/null
+++ b/plugins/subtac/test/Test1.v
@@ -0,0 +1,16 @@
+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/plugins/subtac/test/euclid.v b/plugins/subtac/test/euclid.v
new file mode 100644
index 00000000..97c3d941
--- /dev/null
+++ b/plugins/subtac/test/euclid.v
@@ -0,0 +1,24 @@
+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/plugins/subtac/test/id.v b/plugins/subtac/test/id.v
new file mode 100644
index 00000000..9ae11088
--- /dev/null
+++ b/plugins/subtac/test/id.v
@@ -0,0 +1,46 @@
+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/plugins/subtac/test/measure.v b/plugins/subtac/test/measure.v
new file mode 100644
index 00000000..4f938f4f
--- /dev/null
+++ b/plugins/subtac/test/measure.v
@@ -0,0 +1,20 @@
+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/plugins/subtac/test/rec.v b/plugins/subtac/test/rec.v
new file mode 100644
index 00000000..aaefd8cc
--- /dev/null
+++ b/plugins/subtac/test/rec.v
@@ -0,0 +1,65 @@
+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/plugins/subtac/test/take.v b/plugins/subtac/test/take.v
new file mode 100644
index 00000000..90ae8bae
--- /dev/null
+++ b/plugins/subtac/test/take.v
@@ -0,0 +1,34 @@
+(* -*- 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/plugins/subtac/test/wf.v b/plugins/subtac/test/wf.v
new file mode 100644
index 00000000..5ccc154a
--- /dev/null
+++ b/plugins/subtac/test/wf.v
@@ -0,0 +1,48 @@
+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/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml
new file mode 100644
index 00000000..19473dfa
--- /dev/null
+++ b/plugins/syntax/ascii_syntax.ml
@@ -0,0 +1,83 @@
+(***********************************************************************)
+(*  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$ i*)
+
+open Pp
+open Util
+open Names
+open Pcoq
+open Rawterm
+open Topconstr
+open Libnames
+open Coqlib
+open Bigint
+
+exception Non_closed_ascii
+
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let make_kn dir id = Libnames.encode_mind (make_dir dir) (id_of_string id)
+let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
+
+let ascii_module = ["Coq";"Strings";"Ascii"]
+
+let ascii_path = make_path ascii_module "ascii"
+
+let ascii_kn = make_kn ascii_module "ascii"
+let path_of_Ascii = ((ascii_kn,0),1)
+let static_glob_Ascii  = ConstructRef path_of_Ascii
+
+let make_reference id = find_reference "Ascii interpretation" ascii_module id
+let glob_Ascii = lazy (make_reference "Ascii")
+
+open Lazy
+
+let interp_ascii dloc p =
+  let rec aux n p =
+     if n = 0 then [] else
+     let mp = p mod 2 in
+     RRef (dloc,if mp = 0 then glob_false else glob_true)
+     :: (aux (n-1) (p/2)) in
+  RApp (dloc,RRef(dloc,force glob_Ascii), aux 8 p)
+
+let interp_ascii_string dloc s =
+  let p =
+    if String.length s = 1 then int_of_char s.[0]
+    else
+      if String.length s = 3 & is_digit s.[0] & is_digit s.[1] & is_digit s.[2]
+      then int_of_string s
+      else
+	user_err_loc (dloc,"interp_ascii_string",
+	  str "Expects a single character or a three-digits ascii code.") in
+  interp_ascii dloc p
+
+let uninterp_ascii r =
+  let rec uninterp_bool_list n = function
+    | [] when n = 0 -> 0
+    | RRef (_,k)::l when k = glob_true  -> 1+2*(uninterp_bool_list (n-1)  l)
+    | RRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l)
+    | _ -> raise Non_closed_ascii in
+  try
+    let rec aux = function
+    | RApp (_,RRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l
+    | _ -> raise Non_closed_ascii in
+    Some (aux r)
+  with
+   Non_closed_ascii -> None
+
+let make_ascii_string n =
+  if n>=32 && n<=126 then String.make 1 (char_of_int n)
+  else Printf.sprintf "%03d" n
+
+let uninterp_ascii_string r = Option.map make_ascii_string (uninterp_ascii r)
+
+let _ =
+  Notation.declare_string_interpreter "char_scope"
+    (ascii_path,ascii_module)
+    interp_ascii_string
+    ([RRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true)
diff --git a/plugins/syntax/ascii_syntax_plugin.mllib b/plugins/syntax/ascii_syntax_plugin.mllib
new file mode 100644
index 00000000..b00f9250
--- /dev/null
+++ b/plugins/syntax/ascii_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Ascii_syntax
+Ascii_syntax_plugin_mod
diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml
new file mode 100644
index 00000000..5d20c2a3
--- /dev/null
+++ b/plugins/syntax/nat_syntax.ml
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  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$ *)
+
+(* This file defines the printer for natural numbers in [nat] *)
+
+(*i*)
+open Pcoq
+open Pp
+open Util
+open Names
+open Coqlib
+open Rawterm
+open Libnames
+open Bigint
+open Coqlib
+open Notation
+open Pp
+open Util
+open Names
+(*i*)
+
+(**********************************************************************)
+(* Parsing via scopes *)
+(* For example, (nat_of_string "3") is <<(S (S (S O)))>> *)
+
+let nat_of_int dloc n =
+  if is_pos_or_zero n then begin
+      if less_than (of_string "5000") n then
+	Flags.if_warn msg_warning
+	  (strbrk "Stack overflow or segmentation fault happens when " ++
+	   strbrk "working with large numbers in nat (observed threshold " ++
+	   strbrk "may vary from 5000 to 70000 depending on your system " ++
+	   strbrk "limits and on the command executed).");
+      let ref_O = RRef (dloc, glob_O) in
+      let ref_S = RRef (dloc, glob_S) in
+      let rec mk_nat acc n =
+	if n <> zero then
+	  mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n)
+	else
+	  acc
+      in
+      mk_nat ref_O n
+    end
+  else
+      user_err_loc (dloc, "nat_of_int",
+        str "Cannot interpret a negative number as a number of type nat")
+
+(************************************************************************)
+(* Printing via scopes *)
+
+exception Non_closed_number
+
+let rec int_of_nat = function
+  | RApp (_,RRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a)
+  | RRef (_,z) when z = glob_O -> zero
+  | _ -> raise Non_closed_number
+
+let uninterp_nat p =
+  try
+    Some (int_of_nat p)
+  with
+    Non_closed_number -> None
+
+(************************************************************************)
+(* Declare the primitive parsers and printers *)
+
+let _ =
+  Notation.declare_numeral_interpreter "nat_scope"
+    (nat_path,["Coq";"Init";"Datatypes"])
+    nat_of_int
+    ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, true)
diff --git a/plugins/syntax/nat_syntax_plugin.mllib b/plugins/syntax/nat_syntax_plugin.mllib
new file mode 100644
index 00000000..69b0cb20
--- /dev/null
+++ b/plugins/syntax/nat_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Nat_syntax
+Nat_syntax_plugin_mod
diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml
new file mode 100644
index 00000000..4375d5e0
--- /dev/null
+++ b/plugins/syntax/numbers_syntax.ml
@@ -0,0 +1,330 @@
+(************************************************************************)
+(*  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$ i*)
+
+(* digit-based syntax for int31, bigN bigZ and bigQ *)
+
+open Bigint
+open Libnames
+open Rawterm
+
+(*** Constants for locating int31 / bigN / bigZ / bigQ constructors ***)
+
+let make_dir l = Names.make_dirpath (List.map Names.id_of_string (List.rev l))
+let make_path dir id = Libnames.make_path (make_dir dir) (Names.id_of_string id)
+
+let make_mind mp id = Names.make_mind mp Names.empty_dirpath (Names.mk_label id)
+let make_mind_mpfile dir id = make_mind (Names.MPfile (make_dir dir)) id
+let make_mind_mpdot dir modname id =
+  let mp = Names.MPdot (Names.MPfile (make_dir dir), Names.mk_label modname)
+  in make_mind mp id
+
+
+(* int31 stuff *)
+let int31_module = ["Coq"; "Numbers"; "Cyclic"; "Int31"; "Int31"]
+let int31_path = make_path int31_module "int31"
+let int31_id = make_mind_mpfile int31_module
+let int31_scope = "int31_scope"
+
+let int31_construct = ConstructRef ((int31_id "int31",0),1)
+
+let int31_0 = ConstructRef ((int31_id "digits",0),1)
+let int31_1 = ConstructRef ((int31_id "digits",0),2)
+
+
+(* bigN stuff*)
+let zn2z_module = ["Coq"; "Numbers"; "Cyclic"; "DoubleCyclic"; "DoubleType"]
+let zn2z_path = make_path zn2z_module "zn2z"
+let zn2z_id = make_mind_mpfile zn2z_module
+
+let zn2z_W0 = ConstructRef ((zn2z_id "zn2z",0),1)
+let zn2z_WW = ConstructRef ((zn2z_id "zn2z",0),2)
+
+let bigN_module = ["Coq"; "Numbers"; "Natural"; "BigN"; "BigN" ]
+let bigN_path = make_path (bigN_module@["BigN"]) "t"
+let bigN_t = make_mind_mpdot bigN_module "BigN" "t_"
+let bigN_scope = "bigN_scope"
+
+(* number of inlined level of bigN (actually the level 0 to n_inlined-1 are inlined) *)
+let n_inlined = of_string "7"
+let bigN_constructor =
+ (* converts a bigint into an int the ugly way *)
+  let rec to_int i =
+    if equal i zero then
+      0
+    else
+      let (quo,rem) = div2_with_rest i in
+      if rem then
+	2*(to_int quo)+1
+      else
+	2*(to_int quo)
+  in
+  fun i ->
+  ConstructRef ((bigN_t,0),
+		if less_than i n_inlined then
+		  (to_int i)+1
+		else
+		  (to_int n_inlined)+1
+	       )
+
+(*bigZ stuff*)
+let bigZ_module = ["Coq"; "Numbers"; "Integer"; "BigZ"; "BigZ" ]
+let bigZ_path = make_path (bigZ_module@["BigZ"]) "t"
+let bigZ_t = make_mind_mpdot bigZ_module "BigZ" "t_"
+let bigZ_scope = "bigZ_scope"
+
+let bigZ_pos = ConstructRef ((bigZ_t,0),1)
+let bigZ_neg = ConstructRef ((bigZ_t,0),2)
+
+
+(*bigQ stuff*)
+let bigQ_module = ["Coq"; "Numbers"; "Rational"; "BigQ"; "BigQ"]
+let bigQ_path = make_path (bigQ_module@["BigQ"]) "t"
+let bigQ_t = make_mind_mpdot bigQ_module "BigQ" "t_"
+let bigQ_scope = "bigQ_scope"
+
+let bigQ_z =  ConstructRef ((bigQ_t,0),1)
+
+
+(*** Definition of the Non_closed exception, used in the pretty printing ***)
+exception Non_closed
+
+(*** Parsing for int31 in digital notation ***)
+
+(* parses a *non-negative* integer (from bigint.ml) into an int31
+   wraps modulo 2^31 *)
+let int31_of_pos_bigint dloc n =
+  let ref_construct = RRef (dloc, int31_construct) in
+  let ref_0 = RRef (dloc, int31_0) in
+  let ref_1 = RRef (dloc, int31_1) in
+  let rec args counter n =
+    if counter <= 0 then
+      []
+    else
+      let (q,r) = div2_with_rest n in
+	(if r then ref_1 else ref_0)::(args (counter-1) q)
+  in
+  RApp (dloc, ref_construct, List.rev (args 31 n))
+
+let error_negative dloc =
+  Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
+
+let interp_int31 dloc n =
+  if is_pos_or_zero n then
+    int31_of_pos_bigint dloc n
+  else
+    error_negative dloc
+
+(* Pretty prints an int31 *)
+
+let bigint_of_int31 =
+  let rec args_parsing args cur =
+    match args with
+      | [] -> cur
+      | (RRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur)
+      | (RRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur))
+      | _ -> raise Non_closed
+  in
+  function
+  | RApp (_, RRef (_, c), args) when c=int31_construct -> args_parsing args zero
+  | _ -> raise Non_closed
+
+let uninterp_int31 i =
+  try
+    Some (bigint_of_int31 i)
+  with Non_closed ->
+    None
+
+(* Actually declares the interpreter for int31 *)
+let _ = Notation.declare_numeral_interpreter int31_scope
+  (int31_path, int31_module)
+  interp_int31
+  ([RRef (Util.dummy_loc, int31_construct)],
+   uninterp_int31,
+   true)
+
+
+(*** Parsing for bigN in digital notation ***)
+(* the base for bigN (in Coq) that is 2^31 in our case *)
+let base = pow two (of_string "31")
+
+(* base of the bigN of height N : *)
+let rank n = pow base (pow two n)
+
+(* splits a number bi at height n, that is the rest needs 2^n int31 to be stored
+   it is expected to be used only when the quotient would also need 2^n int31 to be
+   stored *)
+let split_at n bi =
+  euclid bi (rank (sub_1 n))
+
+(* search the height of the Coq bigint needed to represent the integer bi *)
+let height bi =
+  let rec height_aux n =
+    if less_than bi (rank n) then
+      n
+    else
+      height_aux (add_1 n)
+  in
+  height_aux zero
+
+
+(* n must be a non-negative integer (from bigint.ml) *)
+let word_of_pos_bigint dloc hght n =
+  let ref_W0 = RRef (dloc, zn2z_W0) in
+  let ref_WW = RRef (dloc, zn2z_WW) in
+  let rec decomp hgt n =
+    if is_neg_or_zero hgt then
+      int31_of_pos_bigint dloc n
+    else if equal n zero then
+      RApp (dloc, ref_W0, [RHole (dloc, Evd.InternalHole)])
+    else
+      let (h,l) = split_at hgt n in
+      RApp (dloc, ref_WW, [RHole (dloc, Evd.InternalHole);
+			   decomp (sub_1 hgt) h;
+			   decomp (sub_1 hgt) l])
+  in
+  decomp hght n
+
+let bigN_of_pos_bigint dloc n =
+  let ref_constructor i = RRef (dloc, bigN_constructor i) in
+  let result h word = RApp (dloc, ref_constructor h, if less_than h n_inlined then
+				                       [word]
+			                             else
+				                      [Nat_syntax.nat_of_int dloc (sub h n_inlined);
+						       word])
+  in
+  let hght = height n in
+  result hght (word_of_pos_bigint dloc hght n)
+
+let bigN_error_negative dloc =
+  Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
+
+let interp_bigN dloc n =
+  if is_pos_or_zero n then
+    bigN_of_pos_bigint dloc n
+  else
+    bigN_error_negative dloc
+
+
+(* Pretty prints a bigN *)
+
+let bigint_of_word =
+  let rec get_height rc =
+    match rc with
+    | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW ->
+	                                  let hleft = get_height lft in
+					  let hright = get_height rght in
+					  add_1
+					    (if less_than hleft hright then
+						 hright
+					     else
+						 hleft)
+    | _ -> zero
+  in
+  let rec transform hght rc =
+    match rc with
+    | RApp (_,RRef(_,c),_) when c = zn2z_W0-> zero
+    | RApp (_,RRef(_,c), [_;lft;rght]) when c=zn2z_WW-> let new_hght = sub_1 hght in
+	                                                add (mult (rank new_hght)
+                                                          (transform (new_hght) lft))
+	                                            (transform (new_hght) rght)
+    | _ -> bigint_of_int31 rc
+  in
+  fun rc ->
+    let hght = get_height rc in
+    transform hght rc
+
+let bigint_of_bigN rc =
+  match rc with
+  | RApp (_,_,[one_arg]) -> bigint_of_word one_arg
+  | RApp (_,_,[_;second_arg]) -> bigint_of_word second_arg
+  | _ -> raise Non_closed
+
+let uninterp_bigN rc =
+  try
+    Some (bigint_of_bigN rc)
+  with Non_closed ->
+    None
+
+
+(* declare the list of constructors of bigN used in the declaration of the
+   numeral interpreter *)
+
+let bigN_list_of_constructors =
+  let rec build i =
+    if less_than i (add_1 n_inlined) then
+      RRef (Util.dummy_loc, bigN_constructor i)::(build (add_1 i))
+    else
+      []
+  in
+  build zero
+
+(* Actually declares the interpreter for bigN *)
+let _ = Notation.declare_numeral_interpreter bigN_scope
+  (bigN_path, bigN_module)
+  interp_bigN
+  (bigN_list_of_constructors,
+   uninterp_bigN,
+   true)
+
+
+(*** Parsing for bigZ in digital notation ***)
+let interp_bigZ dloc n =
+  let ref_pos = RRef (dloc, bigZ_pos) in
+  let ref_neg = RRef (dloc, bigZ_neg) in
+  if is_pos_or_zero n then
+    RApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n])
+  else
+    RApp (dloc, ref_neg, [bigN_of_pos_bigint dloc (neg n)])
+
+(* pretty printing functions for bigZ *)
+let bigint_of_bigZ = function
+  | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg
+  | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_neg ->
+      let opp_val = bigint_of_bigN one_arg in
+      if equal opp_val zero then
+	raise Non_closed
+      else
+	neg opp_val
+  | _ -> raise Non_closed
+
+
+let uninterp_bigZ rc =
+  try
+    Some (bigint_of_bigZ rc)
+  with Non_closed ->
+    None
+
+(* Actually declares the interpreter for bigZ *)
+let _ = Notation.declare_numeral_interpreter bigZ_scope
+  (bigZ_path, bigZ_module)
+  interp_bigZ
+  ([RRef (Util.dummy_loc, bigZ_pos);
+    RRef (Util.dummy_loc, bigZ_neg)],
+   uninterp_bigZ,
+   true)
+
+(*** Parsing for bigQ in digital notation ***)
+let interp_bigQ dloc n =
+  let ref_z = RRef (dloc, bigQ_z) in
+  RApp (dloc, ref_z, [interp_bigZ dloc n])
+
+let uninterp_bigQ rc =
+  try match rc with
+    | RApp (_, RRef(_,c), [one_arg]) when c = bigQ_z ->
+	Some (bigint_of_bigZ one_arg)
+    | _ -> None (* we don't pretty-print yet fractions *)
+  with Non_closed -> None
+
+(* Actually declares the interpreter for bigQ *)
+let _ = Notation.declare_numeral_interpreter bigQ_scope
+  (bigQ_path, bigQ_module)
+  interp_bigQ
+  ([RRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ,
+   true)
diff --git a/plugins/syntax/numbers_syntax_plugin.mllib b/plugins/syntax/numbers_syntax_plugin.mllib
new file mode 100644
index 00000000..ebc0bb20
--- /dev/null
+++ b/plugins/syntax/numbers_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Numbers_syntax
+Numbers_syntax_plugin_mod
diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml
new file mode 100644
index 00000000..f85309e6
--- /dev/null
+++ b/plugins/syntax/r_syntax.ml
@@ -0,0 +1,125 @@
+(************************************************************************)
+(*  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$ i*)
+
+open Pp
+open Util
+open Names
+open Pcoq
+open Topconstr
+open Libnames
+
+exception Non_closed_number
+
+(**********************************************************************)
+(* Parsing R via scopes                                               *)
+(**********************************************************************)
+
+open Libnames
+open Rawterm
+open Bigint
+
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"]
+let make_path dir id = Libnames.make_path dir (id_of_string id)
+
+let r_path = make_path rdefinitions "R"
+
+(* TODO: temporary hack *)
+let make_path dir id = Libnames.encode_con dir (id_of_string id)
+
+let r_kn = make_path rdefinitions "R"
+let glob_R = ConstRef r_kn
+let glob_R1 = ConstRef (make_path rdefinitions "R1")
+let glob_R0 = ConstRef (make_path rdefinitions "R0")
+let glob_Ropp = ConstRef (make_path rdefinitions "Ropp")
+let glob_Rplus = ConstRef (make_path rdefinitions "Rplus")
+let glob_Rmult = ConstRef (make_path rdefinitions "Rmult")
+
+let two = mult_2 one
+let three = add_1 two
+let four = mult_2 two
+
+(* Unary representation of strictly positive numbers *)
+let rec small_r dloc n =
+  if equal one n then RRef (dloc, glob_R1)
+  else RApp(dloc,RRef (dloc,glob_Rplus),
+            [RRef (dloc, glob_R1);small_r dloc (sub_1 n)])
+
+let r_of_posint dloc n =
+  let r1 = RRef (dloc, glob_R1) in
+  let r2 = small_r dloc two in
+  let rec r_of_pos n =
+    if less_than n four then small_r dloc n
+    else
+      let (q,r) = div2_with_rest n in
+      let b = RApp(dloc,RRef(dloc,glob_Rmult),[r2;r_of_pos q]) in
+      if r then RApp(dloc,RRef(dloc,glob_Rplus),[r1;b]) else b in
+  if n <> zero then r_of_pos n else RRef(dloc,glob_R0)
+
+let r_of_int dloc z =
+  if is_strictly_neg z then
+    RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)])
+  else
+    r_of_posint dloc z
+
+(**********************************************************************)
+(* Printing R via scopes                                              *)
+(**********************************************************************)
+
+let bignat_of_r =
+(* for numbers > 1 *)
+let rec bignat_of_pos = function
+  (* 1+1 *)
+  | RApp (_,RRef (_,p), [RRef (_,o1); RRef (_,o2)])
+      when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two
+  (* 1+(1+1) *)
+  | RApp (_,RRef (_,p1), [RRef (_,o1);
+      RApp(_,RRef (_,p2),[RRef(_,o2);RRef(_,o3)])])
+      when p1 = glob_Rplus & p2 = glob_Rplus &
+           o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three
+  (* (1+1)*b *)
+  | RApp (_,RRef (_,p), [a; b]) when p = glob_Rmult ->
+      if bignat_of_pos a <> two then raise Non_closed_number;
+      mult_2 (bignat_of_pos b)
+  (* 1+(1+1)*b *)
+  | RApp (_,RRef (_,p1), [RRef (_,o); RApp (_,RRef (_,p2),[a;b])])
+      when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1  ->
+      if bignat_of_pos a <> two then raise Non_closed_number;
+        add_1 (mult_2 (bignat_of_pos b))
+  | _ -> raise Non_closed_number
+in
+let bignat_of_r = function
+  | RRef (_,a) when a = glob_R0 -> zero
+  | RRef (_,a) when a = glob_R1 -> one
+  | r -> bignat_of_pos r
+in
+bignat_of_r
+
+let bigint_of_r = function
+  | RApp (_,RRef (_,o), [a]) when o = glob_Ropp ->
+      let n = bignat_of_r a in
+      if n = zero then raise Non_closed_number;
+      neg n
+  | a -> bignat_of_r a
+
+let uninterp_r p =
+  try
+    Some (bigint_of_r p)
+  with Non_closed_number ->
+    None
+
+let _ = Notation.declare_numeral_interpreter "R_scope"
+  (r_path,["Coq";"Reals";"Rdefinitions"])
+  r_of_int
+  ([RRef(dummy_loc,glob_Ropp);RRef(dummy_loc,glob_R0);
+    RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult);
+    RRef(dummy_loc,glob_R1)],
+    uninterp_r,
+    false)
diff --git a/plugins/syntax/r_syntax_plugin.mllib b/plugins/syntax/r_syntax_plugin.mllib
new file mode 100644
index 00000000..5c173a14
--- /dev/null
+++ b/plugins/syntax/r_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+R_syntax
+R_syntax_plugin_mod
diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml
new file mode 100644
index 00000000..bc02357a
--- /dev/null
+++ b/plugins/syntax/string_syntax.ml
@@ -0,0 +1,69 @@
+(***********************************************************************)
+(*  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$ i*)
+
+open Pp
+open Util
+open Names
+open Pcoq
+open Libnames
+open Topconstr
+open Ascii_syntax
+open Rawterm
+open Coqlib
+
+exception Non_closed_string
+
+(* make a string term from the string s *)
+
+let string_module = ["Coq";"Strings";"String"]
+
+let string_path = make_path string_module "string"
+
+let string_kn = make_kn string_module "string"
+let static_glob_EmptyString  = ConstructRef ((string_kn,0),1)
+let static_glob_String  = ConstructRef ((string_kn,0),2)
+
+let make_reference id = find_reference "String interpretation" string_module id
+let glob_String = lazy (make_reference "String")
+let glob_EmptyString = lazy (make_reference "EmptyString")
+
+open Lazy
+
+let interp_string dloc s =
+  let le = String.length s in
+  let rec aux n =
+     if n = le then RRef (dloc, force glob_EmptyString) else
+     RApp (dloc,RRef (dloc, force glob_String),
+       [interp_ascii dloc (int_of_char s.[n]); aux (n+1)])
+  in aux 0
+
+let uninterp_string r =
+  try
+    let b = Buffer.create 16 in
+    let rec aux = function
+    | RApp (_,RRef (_,k),[a;s]) when k = force glob_String ->
+	(match uninterp_ascii a with
+	  | Some c -> Buffer.add_char b (Char.chr c); aux s
+	  | _ -> raise Non_closed_string)
+    | RRef (_,z) when z = force glob_EmptyString ->
+	Some (Buffer.contents b)
+    | _ ->
+	raise Non_closed_string
+    in aux r
+  with
+   Non_closed_string -> None
+
+let _ =
+  Notation.declare_string_interpreter "string_scope"
+    (string_path,["Coq";"Strings";"String"])
+    interp_string
+    ([RRef (dummy_loc,static_glob_String);
+      RRef (dummy_loc,static_glob_EmptyString)],
+     uninterp_string, true)
diff --git a/plugins/syntax/string_syntax_plugin.mllib b/plugins/syntax/string_syntax_plugin.mllib
new file mode 100644
index 00000000..b108c9e0
--- /dev/null
+++ b/plugins/syntax/string_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+String_syntax
+String_syntax_plugin_mod
diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml
new file mode 100644
index 00000000..f6afd080
--- /dev/null
+++ b/plugins/syntax/z_syntax.ml
@@ -0,0 +1,194 @@
+(************************************************************************)
+(*  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$ *)
+
+open Pcoq
+open Pp
+open Util
+open Names
+open Topconstr
+open Libnames
+open Bigint
+
+exception Non_closed_number
+
+(**********************************************************************)
+(* Parsing positive via scopes                                        *)
+(**********************************************************************)
+
+open Libnames
+open Rawterm
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let positive_module = ["Coq";"NArith";"BinPos"]
+let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
+
+let positive_path = make_path positive_module "positive"
+
+(* TODO: temporary hack *)
+let make_kn dir id = Libnames.encode_mind dir id
+
+let positive_kn =
+  make_kn (make_dir positive_module) (id_of_string "positive")
+let glob_positive = IndRef (positive_kn,0)
+let path_of_xI = ((positive_kn,0),1)
+let path_of_xO = ((positive_kn,0),2)
+let path_of_xH = ((positive_kn,0),3)
+let glob_xI = ConstructRef path_of_xI
+let glob_xO = ConstructRef path_of_xO
+let glob_xH = ConstructRef path_of_xH
+
+let pos_of_bignat dloc x =
+  let ref_xI = RRef (dloc, glob_xI) in
+  let ref_xH = RRef (dloc, glob_xH) in
+  let ref_xO = RRef (dloc, glob_xO) in
+  let rec pos_of x =
+    match div2_with_rest x with
+      | (q,false) -> RApp (dloc, ref_xO,[pos_of q])
+      | (q,true) when q <> zero -> RApp (dloc,ref_xI,[pos_of q])
+      | (q,true) -> ref_xH
+  in
+  pos_of x
+
+let error_non_positive dloc =
+  user_err_loc (dloc, "interp_positive",
+    str "Only strictly positive numbers in type \"positive\".")
+
+let interp_positive dloc n =
+  if is_strictly_pos n then pos_of_bignat dloc n
+  else error_non_positive dloc
+
+(**********************************************************************)
+(* Printing positive via scopes                                       *)
+(**********************************************************************)
+
+let rec bignat_of_pos = function
+  | RApp (_, RRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a)
+  | RApp (_, RRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a))
+  | RRef (_, a) when a = glob_xH -> Bigint.one
+  | _ -> raise Non_closed_number
+
+let uninterp_positive p =
+  try
+    Some (bignat_of_pos p)
+  with Non_closed_number ->
+    None
+
+(************************************************************************)
+(* Declaring interpreters and uninterpreters for positive *)
+(************************************************************************)
+
+let _ = Notation.declare_numeral_interpreter "positive_scope"
+  (positive_path,positive_module)
+  interp_positive
+  ([RRef (dummy_loc, glob_xI);
+    RRef (dummy_loc, glob_xO);
+    RRef (dummy_loc, glob_xH)],
+   uninterp_positive,
+   true)
+
+(**********************************************************************)
+(* Parsing N via scopes                                               *)
+(**********************************************************************)
+
+let binnat_module = ["Coq";"NArith";"BinNat"]
+let n_kn = make_kn (make_dir binnat_module) (id_of_string "N")
+let glob_n = IndRef (n_kn,0)
+let path_of_N0 = ((n_kn,0),1)
+let path_of_Npos = ((n_kn,0),2)
+let glob_N0 = ConstructRef path_of_N0
+let glob_Npos = ConstructRef path_of_Npos
+
+let n_path = make_path binnat_module "N"
+
+let n_of_binnat dloc pos_or_neg n =
+  if n <> zero then
+    RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n])
+  else
+    RRef (dloc, glob_N0)
+
+let error_negative dloc =
+  user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".")
+
+let n_of_int dloc n =
+  if is_pos_or_zero n then n_of_binnat dloc true n
+  else error_negative dloc
+
+(**********************************************************************)
+(* Printing N via scopes                                              *)
+(**********************************************************************)
+
+let bignat_of_n = function
+  | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a
+  | RRef (_, a) when a = glob_N0 -> Bigint.zero
+  | _ -> raise Non_closed_number
+
+let uninterp_n p =
+  try Some (bignat_of_n p)
+  with Non_closed_number -> None
+
+(************************************************************************)
+(* Declaring interpreters and uninterpreters for N *)
+
+let _ = Notation.declare_numeral_interpreter "N_scope"
+  (n_path,binnat_module)
+  n_of_int
+  ([RRef (dummy_loc, glob_N0);
+    RRef (dummy_loc, glob_Npos)],
+  uninterp_n,
+  true)
+
+(**********************************************************************)
+(* Parsing Z via scopes                                               *)
+(**********************************************************************)
+
+let binint_module = ["Coq";"ZArith";"BinInt"]
+let z_path = make_path binint_module "Z"
+let z_kn = make_kn (make_dir binint_module) (id_of_string "Z")
+let glob_z = IndRef (z_kn,0)
+let path_of_ZERO = ((z_kn,0),1)
+let path_of_POS = ((z_kn,0),2)
+let path_of_NEG = ((z_kn,0),3)
+let glob_ZERO = ConstructRef path_of_ZERO
+let glob_POS = ConstructRef path_of_POS
+let glob_NEG = ConstructRef path_of_NEG
+
+let z_of_int dloc n =
+  if n <> zero then
+    let sgn, n =
+      if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in
+    RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n])
+  else
+    RRef (dloc, glob_ZERO)
+
+(**********************************************************************)
+(* Printing Z via scopes                                              *)
+(**********************************************************************)
+
+let bigint_of_z = function
+  | RApp (_, RRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a
+  | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a)
+  | RRef (_, a) when a = glob_ZERO -> Bigint.zero
+  | _ -> raise Non_closed_number
+
+let uninterp_z p =
+  try
+    Some (bigint_of_z p)
+  with Non_closed_number -> None
+
+(************************************************************************)
+(* Declaring interpreters and uninterpreters for Z *)
+
+let _ = Notation.declare_numeral_interpreter "Z_scope"
+  (z_path,binint_module)
+  z_of_int
+  ([RRef (dummy_loc, glob_ZERO);
+    RRef (dummy_loc, glob_POS);
+    RRef (dummy_loc, glob_NEG)],
+  uninterp_z,
+  true)
diff --git a/plugins/syntax/z_syntax_plugin.mllib b/plugins/syntax/z_syntax_plugin.mllib
new file mode 100644
index 00000000..36d41acc
--- /dev/null
+++ b/plugins/syntax/z_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Z_syntax
+Z_syntax_plugin_mod
diff --git a/plugins/xml/COPYRIGHT b/plugins/xml/COPYRIGHT
new file mode 100644
index 00000000..c8d231fd
--- /dev/null
+++ b/plugins/xml/COPYRIGHT
@@ -0,0 +1,25 @@
+(******************************************************************************)
+(* 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/plugins/xml/README b/plugins/xml/README
new file mode 100644
index 00000000..a45dd31a
--- /dev/null
+++ b/plugins/xml/README
@@ -0,0 +1,254 @@
+(******************************************************************************)
+(* 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/plugins/xml/acic.ml b/plugins/xml/acic.ml
new file mode 100644
index 00000000..40bc61bb
--- /dev/null
+++ b/plugins/xml/acic.ml
@@ -0,0 +1,108 @@
+(************************************************************************)
+(*  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/plugins/xml/acic2Xml.ml4 b/plugins/xml/acic2Xml.ml4
new file mode 100644
index 00000000..fb40ed86
--- /dev/null
+++ b/plugins/xml/acic2Xml.ml4
@@ -0,0 +1,363 @@
+(************************************************************************)
+(*  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/plugins/xml/cic.dtd b/plugins/xml/cic.dtd
new file mode 100644
index 00000000..c8035cab
--- /dev/null
+++ b/plugins/xml/cic.dtd
@@ -0,0 +1,259 @@
+<?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/plugins/xml/cic2Xml.ml b/plugins/xml/cic2Xml.ml
new file mode 100644
index 00000000..981503a6
--- /dev/null
+++ b/plugins/xml/cic2Xml.ml
@@ -0,0 +1,17 @@
+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/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml
new file mode 100644
index 00000000..a80ceb0f
--- /dev/null
+++ b/plugins/xml/cic2acic.ml
@@ -0,0 +1,942 @@
+(************************************************************************)
+(*  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_full_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.mutual_inductive
+ | 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'))
+;;
+
+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.mind_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.pop_dirpath_n (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.path_of_global (Libnames.IndRef (induri,0))
+                 | Libnames.VarRef id ->
+                    (* Invariant: variables are never cooked in Coq *)
+                    raise Not_found
+                 | _ -> Nametab.path_of_global g
+               in
+               Dischargedhypsmap.get_discharged_hyps sp,
+               get_module_path_of_full_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
+                    (Namegen.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 (Namegen.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 (Namegen.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 (Namegen.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 (Namegen.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/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml
new file mode 100644
index 00000000..f8921aec
--- /dev/null
+++ b/plugins/xml/doubleTypeInference.ml
@@ -0,0 +1,272 @@
+(************************************************************************)
+(*  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/plugins/xml/doubleTypeInference.mli b/plugins/xml/doubleTypeInference.mli
new file mode 100644
index 00000000..b604ec4c
--- /dev/null
+++ b/plugins/xml/doubleTypeInference.mli
@@ -0,0 +1,24 @@
+(************************************************************************)
+(*  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/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4
new file mode 100644
index 00000000..9419ba59
--- /dev/null
+++ b/plugins/xml/dumptree.ml4
@@ -0,0 +1,152 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This module provides the "Dump Tree" command that allows dumping the
+    current state of the proof stree in XML format *)
+
+(** Contributed by Cezary Kaliszyk, Radboud University Nijmegen *)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+open Tacexpr;;
+open Decl_mode;;
+open Printer;;
+open Pp;;
+open Environ;;
+open Format;;
+open Proof_type;;
+open Evd;;
+open Termops;;
+open Ppconstr;;
+open Names;;
+
+exception Different
+
+let xmlstream s =
+  (* In XML we want to print the whole stream so we can force the evaluation *)
+  Stream.of_list (List.map xmlescape (Stream.npeek max_int s))
+;;
+
+let thin_sign osign sign =
+  Sign.fold_named_context
+    (fun (id,c,ty as d) sign ->
+       try
+        if Sign.lookup_named id osign = (id,c,ty) then sign
+         else raise Different
+       with Not_found | Different -> Environ.push_named_context_val d sign)
+    sign ~init:Environ.empty_named_context_val
+;;
+
+let pr_tactic_xml = function
+  | TacArg (Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>"
+  | t -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_tactic (Global.env()) t) ++ str "\"/>"
+;;
+
+let pr_proof_instr_xml instr =
+  Ppdecl_proof.pr_proof_instr (Global.env()) instr
+;;
+
+let pr_rule_xml pr = function
+  | Prim r -> str "<rule text=\"" ++ xmlstream (pr_prim_rule r) ++ str "\"/>"
+  | Nested(cmpd, subtree) ->
+      hov 2 (str "<cmpdrule>" ++ fnl () ++
+        begin match cmpd with
+          Tactic (texp, _) -> pr_tactic_xml texp
+        | Proof_instr (_,instr) -> pr_proof_instr_xml instr
+        end ++ fnl ()
+        ++ pr subtree
+      ) ++ fnl () ++ str "</cmpdrule>"
+  | Daimon -> str "<daimon/>"
+  | Decl_proof _ -> str "<proof/>"
+(*  | Change_evars -> str "<chgevars/>"*)
+;;
+
+let pr_var_decl_xml env (id,c,typ) =
+  let ptyp = print_constr_env env typ in
+  match c with
+  | None ->
+      (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\"/>")
+  | Some c ->
+      (* Force evaluation *)
+      let pb = print_constr_env env c in
+      (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\" body=\"" ++
+         xmlstream pb ++ str "\"/>")
+;;
+
+let pr_rel_decl_xml env (na,c,typ) =
+  let pbody = match c with
+    | None -> mt ()
+    | Some c ->
+	(* Force evaluation *)
+	let pb = print_constr_env env c in
+	  (str" body=\"" ++ xmlstream pb ++ str "\"") in
+  let ptyp = print_constr_env env typ in
+  let pid =
+    match na with
+    | Anonymous -> mt ()
+    | Name id -> str " id=\"" ++ pr_id id ++ str "\""
+  in
+  (str "<hyp" ++ pid ++ str " type=\"" ++ xmlstream ptyp ++ str "\"" ++ pbody ++ str "/>")
+;;
+
+let pr_context_xml env =
+  let sign_env =
+    fold_named_context
+      (fun env d pp -> pp ++ pr_var_decl_xml env d)
+      env ~init:(mt ())
+  in
+  let db_env =
+    fold_rel_context
+      (fun env d pp -> pp ++ pr_rel_decl_xml env d)
+      env ~init:(mt ())
+  in
+  (sign_env ++ db_env)
+;;
+
+let pr_subgoal_metas_xml metas env=
+  let pr_one (meta, typ) =
+    fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++
+      str "\"/>"
+  in
+  List.fold_left (++) (mt ()) (List.map pr_one metas)
+;;
+
+let pr_goal_xml g =
+  let env = try evar_unfiltered_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/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml
new file mode 100644
index 00000000..1beabf26
--- /dev/null
+++ b/plugins/xml/proof2aproof.ml
@@ -0,0 +1,176 @@
+(************************************************************************)
+(*  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)
+        ~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) [] 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, 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/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4
new file mode 100644
index 00000000..3f1e0a63
--- /dev/null
+++ b/plugins/xml/proofTree2Xml.ml4
@@ -0,0 +1,210 @@
+(************************************************************************)
+(*  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/plugins/xml/theoryobject.dtd b/plugins/xml/theoryobject.dtd
new file mode 100644
index 00000000..953fe009
--- /dev/null
+++ b/plugins/xml/theoryobject.dtd
@@ -0,0 +1,62 @@
+<?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/plugins/xml/unshare.ml b/plugins/xml/unshare.ml
new file mode 100644
index 00000000..f30f8230
--- /dev/null
+++ b/plugins/xml/unshare.ml
@@ -0,0 +1,52 @@
+(************************************************************************)
+(*  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/plugins/xml/unshare.mli b/plugins/xml/unshare.mli
new file mode 100644
index 00000000..31ba9037
--- /dev/null
+++ b/plugins/xml/unshare.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  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/plugins/xml/xml.ml4 b/plugins/xml/xml.ml4
new file mode 100644
index 00000000..5b217119
--- /dev/null
+++ b/plugins/xml/xml.ml4
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  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/plugins/xml/xml.mli b/plugins/xml/xml.mli
new file mode 100644
index 00000000..3775287a
--- /dev/null
+++ b/plugins/xml/xml.mli
@@ -0,0 +1,40 @@
+(************************************************************************)
+(*  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$ 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/plugins/xml/xml_plugin.mllib b/plugins/xml/xml_plugin.mllib
new file mode 100644
index 00000000..90797e8d
--- /dev/null
+++ b/plugins/xml/xml_plugin.mllib
@@ -0,0 +1,13 @@
+Unshare
+Xml
+Acic
+DoubleTypeInference
+Cic2acic
+Acic2Xml
+Proof2aproof
+Xmlcommand
+ProofTree2Xml
+Xmlentries
+Cic2Xml
+Dumptree
+Xml_plugin_mod
diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml
new file mode 100644
index 00000000..2299e6c8
--- /dev/null
+++ b/plugins/xml/xmlcommand.ml
@@ -0,0 +1,719 @@
+(************************************************************************)
+(*  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_full_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_full_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 begin 
+   match isrecord with 
+   | Declare.KernelSilent -> "Record"
+   | _ -> "Inductive"
+ end
+ 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 Declare.KernelSilent
+        with Not_found -> Declare.KernelVerbose 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
+  (match internal with
+    | Declare.KernelSilent -> ()
+    | _ -> 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 Declare.UserVerbose 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
+      (match internal with
+       | Declare.KernelSilent -> ()
+       | _ -> print_object_kind uri kind_of_var
+       ); uri
+   | Decl_kinds.Global, _ ->
+      let uri = Cic2acic.uri_of_declaration id Cic2acic.TConstant in
+      (match internal with
+       | Declare.KernelSilent -> ()
+       | _ -> 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 Declare.KernelVerbose 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 Declare.UserVerbose (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 Declare.UserVerbose (Libnames.IndRef (Names.mind_of_kn kn,0))
+        (kind_of_inductive isrecord (Names.mind_of_kn 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/plugins/xml/xmlcommand.mli b/plugins/xml/xmlcommand.mli
new file mode 100644
index 00000000..66ff9f0b
--- /dev/null
+++ b/plugins/xml/xmlcommand.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  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$ 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/plugins/xml/xmlentries.ml4 b/plugins/xml/xmlentries.ml4
new file mode 100644
index 00000000..41c107ad
--- /dev/null
+++ b/plugins/xml/xmlentries.ml4
@@ -0,0 +1,40 @@
+(************************************************************************)
+(*  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$ *)
+
+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