Imported Upstream snapshot 8.3~beta0+13298

30 files changed, 14668 insertions, 0 deletions

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