[build] Consolidate stdlib's .v files under a single directory.

Currently, `.v` under the `Coq.` prefix are found in both `theories`
and `plugins`. Usually these two directories are merged by special
loadpath code that allows double-binding of the prefix.

This adds some complexity to the build and loadpath system; and in
particular, it prevents from handling the `Coq.*` prefix in the
simple, `-R theories Coq` standard way.

We thus move all `.v` files to theories, leaving `plugins` as an
OCaml-only directory, and modify accordingly the loadpath / build
infrastructure.

Note that in general `plugins/foo/Foo.v` was not self-contained, in
the sense that it depended on files in `theories` and files in
`theories` depended on it; moreover, Coq saw all these files as
belonging to the same namespace so it didn't really care where they
lived.

This could also imply a performance gain as we now effectively
traverse less directories when locating a library.

See also discussion in #10003

25 files changed, 8794 insertions, 0 deletions

diff --git a/theories/micromega/DeclConstant.v b/theories/micromega/DeclConstant.v
new file mode 100644
index 0000000000..7ad5e313e3
--- /dev/null
+++ b/theories/micromega/DeclConstant.v
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2019                                  *)
+(*                                                                      *)
+(************************************************************************)
+
+(** Declaring 'allowed' terms using type classes.
+
+    Motivation: reification needs to know which terms are allowed.
+    For 'lia', the constant are only the integers built from Z0, Zpos, Zneg, xH, xO, xI.
+    However, if the term is ground it may be convertible to an integer.
+    Thus we could allow i.e. sqrt z for some integer z.
+
+    Proposal: for each type, the user declares using type-classes the set of allowed ground terms.
+ *)
+
+Require Import List.
+
+(**  Declarative definition of constants.
+     These are ground terms (without variables) of interest.
+     e.g. nat is built from O and S
+     NB: this does not need to be restricted to constructors.
+ *)
+
+(** Ground terms (see [GT] below) are built inductively from declared constants. *)
+
+Class DeclaredConstant {T : Type} (F : T).
+
+Class GT {T : Type} (F : T).
+
+Instance GT_O {T : Type} (F : T) {DC : DeclaredConstant F} : GT F.
+Defined.
+
+Instance GT_APP1 {T1 T2 : Type} (F : T1 -> T2) (A : T1) :
+  DeclaredConstant F ->
+  GT A -> GT (F A).
+Defined.
+
+Instance GT_APP2 {T1 T2 T3: Type} (F : T1 -> T2 -> T3)
+         {A1 : T1} {A2 : T2} {DC:DeclaredConstant F} :
+         GT A1 -> GT A2 -> GT (F A1 A2).
+Defined.
+
+Require Import QArith_base.
+
+Instance DO : DeclaredConstant O := {}.
+Instance DS : DeclaredConstant S := {}.
+Instance DxH: DeclaredConstant xH := {}.
+Instance DxI: DeclaredConstant xI := {}.
+Instance DxO: DeclaredConstant xO := {}.
+Instance DZO: DeclaredConstant Z0 := {}.
+Instance DZpos: DeclaredConstant Zpos := {}.
+Instance DZneg: DeclaredConstant Zneg := {}.
+Instance DZpow_pos : DeclaredConstant Z.pow_pos := {}.
+Instance DZpow     : DeclaredConstant Z.pow     := {}.
+
+Instance DQ : DeclaredConstant Qmake := {}.
diff --git a/theories/micromega/Env.v b/theories/micromega/Env.v
new file mode 100644
index 0000000000..8f4d4726b6
--- /dev/null
+++ b/theories/micromega/Env.v
@@ -0,0 +1,101 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import BinInt List.
+Set Implicit Arguments.
+Local Open Scope positive_scope.
+
+Section S.
+
+  Variable D :Type.
+
+  Definition Env := positive -> D.
+
+  Definition jump (j:positive) (e:Env) := fun x => e (x+j).
+
+  Definition nth (n:positive) (e:Env) := e n.
+
+  Definition hd (e:Env) := nth 1 e.
+
+  Definition tail (e:Env) := jump 1 e.
+
+  Lemma jump_add i j l x : jump (i + j) l x = jump i (jump j l) x.
+  Proof.
+    unfold jump. f_equal. apply Pos.add_assoc.
+  Qed.
+
+  Lemma jump_simpl p l 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; rewrite <- ?jump_add; f_equal;
+    now rewrite Pos.add_diag.
+  Qed.
+
+  Lemma jump_tl j l x : tail (jump j l) x = jump j (tail l) x.
+  Proof.
+    unfold tail. rewrite <- !jump_add. f_equal. apply Pos.add_comm.
+  Qed.
+
+  Lemma jump_succ j l x : jump (Pos.succ j) l x = jump 1 (jump j l) x.
+  Proof.
+    rewrite <- jump_add. f_equal. symmetry. apply Pos.add_1_l.
+  Qed.
+
+  Lemma jump_pred_double i l x :
+    jump (Pos.pred_double i) (tail l) x = jump i (jump i l) x.
+  Proof.
+    unfold tail. rewrite <- !jump_add. f_equal.
+    now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag.
+  Qed.
+
+  Lemma nth_spec 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 hd, nth, tail, jump.
+    destruct p; f_equal; now rewrite Pos.add_diag.
+  Qed.
+
+  Lemma nth_jump p l : nth p (tail l) = hd (jump p l).
+  Proof.
+    unfold hd, nth, tail, jump. f_equal. apply Pos.add_comm.
+  Qed.
+
+  Lemma nth_pred_double p l :
+    nth (Pos.pred_double p) (tail l) = nth p (jump p l).
+  Proof.
+    unfold nth, tail, jump. f_equal.
+    now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag.
+  Qed.
+
+End S.
+
+Ltac jump_simpl :=
+  repeat
+    match goal with
+      | |- context [jump xH] => rewrite (jump_simpl xH)
+      | |- context [jump (xO ?p)] => rewrite (jump_simpl (xO p))
+      | |- context [jump (xI ?p)] => rewrite (jump_simpl (xI p))
+    end.
diff --git a/theories/micromega/EnvRing.v b/theories/micromega/EnvRing.v
new file mode 100644
index 0000000000..2762bb6b32
--- /dev/null
+++ b/theories/micromega/EnvRing.v
@@ -0,0 +1,1101 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(* 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 Morphisms Env BinPos BinNat BinInt.
+Require Export Ring_theory.
+
+Local Open Scope positive_scope.
+Import RingSyntax.
+
+(** Definition of polynomial expressions *)
+#[universes(template)]
+Inductive PExpr {C} : 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.
+Arguments PExpr : clear implicits.
+
+ (* 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)
+ *)
+
+#[universes(template)]
+Inductive Pol {C} : Type :=
+| Pc : C -> Pol
+| Pinj : positive -> Pol -> Pol
+| PX : Pol -> positive -> Pol -> Pol.
+Arguments Pol : clear implicits.
+
+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 : Equivalence 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 : Type.
+ 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.
+ Infix "+" := radd. Infix "*" := rmul.
+ Infix "-" := rsub. Notation "- x" := (ropp x).
+ Infix "==" := req.
+ Infix "^" := (pow_pos rmul).
+
+ (* C notations *)
+ Infix "+!" := cadd. Infix "*!" := cmul.
+ Infix "-! " := csub. Notation "-! x" := (copp x).
+ Infix "?=!" := ceqb. Notation "[ x ]" := (phi x).
+
+ (* Useful tactics *)
+ Add Morphism radd with signature (req ==> req ==> req) as radd_ext.
+ Proof. exact (Radd_ext Reqe). Qed.
+
+ Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext.
+ Proof. exact (Rmul_ext Reqe). Qed.
+
+ Add Morphism ropp with signature (req ==> req) as ropp_ext.
+ Proof. exact (Ropp_ext Reqe). Qed.
+
+ Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext.
+ Proof. 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.
+
+ Ltac add_permut_rec t :=
+   match t with
+   | ?x + ?y => add_permut_rec y || add_permut_rec x
+   | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity]
+   end.
+
+ Ltac add_permut :=
+  repeat (reflexivity ||
+    match goal with |- ?t == _ => add_permut_rec t end).
+
+ Ltac mul_permut_rec t :=
+   match t with
+   | ?x * ?y => mul_permut_rec y || mul_permut_rec x
+   | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity]
+   end.
+
+ Ltac mul_permut :=
+  repeat (reflexivity ||
+    match goal with |- ?t == _ => mul_permut_rec t end).
+
+
+ Notation PExpr := (PExpr C).
+ Notation Pol := (Pol C).
+
+ Implicit Types pe : PExpr.
+ Implicit Types P : 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 j ?= j' with
+    | Eq => Peq Q Q'
+    | _ => false
+    end
+  | PX P i Q, PX P' i' Q' =>
+    match i ?= i' with
+    | Eq => if Peq P P' then Peq Q Q' else false
+    | _ => false
+    end
+  | _, _ => false
+  end.
+
+ Infix "?==" := Peq.
+
+ Definition mkPinj j P :=
+  match P with
+  | Pc _ => P
+  | Pinj j' Q => Pinj (j + j') Q
+  | _ => Pinj j P
+  end.
+
+ Definition mkPinj_pred j P :=
+  match j with
+  | xH => P
+  | xO j => Pinj (Pos.pred_double 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) : 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) : 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) : Pol :=
+   match P with
+   | Pc c => mkPinj j (PaddC Q c)
+   | Pinj j' Q' =>
+     match Z.pos_sub 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 (Pos.pred_double j) Q')
+     | xI j => PX P i (PaddI (xO j) Q')
+     end
+   end.
+
+  Fixpoint PsubI (j:positive) (P:Pol) : Pol :=
+   match P with
+   | Pc c => mkPinj j (PaddC (--Q) c)
+   | Pinj j' Q' =>
+     match Z.pos_sub 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 (Pos.pred_double j) Q')
+     | xI j => PX P i (PsubI (xO j) Q')
+     end
+   end.
+
+ Variable P' : Pol.
+
+ Fixpoint PaddX (i':positive) (P:Pol) : 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 (Pos.pred_double j) Q')
+    | xI j => PX P' i' (Pinj (xO j) Q')
+    end
+  | PX P i Q' =>
+    match Z.pos_sub 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) : 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 (Pos.pred_double j) Q')
+    | xI j => PX (--P') i' (Pinj (xO j) Q')
+    end
+  | PX P i Q' =>
+    match Z.pos_sub 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 (Pos.pred_double j) Q) Q')
+      | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
+      end
+    | PX P i Q =>
+      match Z.pos_sub 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.
+ Infix "++" := Padd.
+
+ 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 (Pos.pred_double j) Q) Q')
+      | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
+      end
+    | PX P i Q =>
+      match Z.pos_sub 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.
+ Infix "--" := Psub.
+
+ (** Multiplication *)
+
+ Fixpoint PmulC_aux (P:Pol) (c:C) : 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) : Pol :=
+   match P with
+   | Pc c => mkPinj j (PmulC Q c)
+   | Pinj j' Q' =>
+     match Z.pos_sub 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 (Pos.pred_double j') Q')
+     | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
+     end
+   end.
+
+ End PmulI.
+
+ 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 (Pos.pred_double 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.
+
+ Infix "**" := Pmul.
+
+ 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 **)
+
+ (** A monomial is X1^k1...Xi^ki. Its representation
+     is a simplified version of the polynomial representation:
+
+     - [mon0] correspond to the polynom [P1].
+     - [(zmon j M)] corresponds to [(Pinj j ...)],
+       i.e. skip j variable indices.
+     - [(vmon i M)] is X^i*M with X the current variable,
+       its corresponds to (PX P1 i ...)]
+ *)
+
+  Inductive Mon: Set :=
+  | mon0: Mon
+  | zmon: positive -> Mon -> Mon
+  | vmon: positive -> Mon -> Mon.
+
+ Definition mkZmon j M :=
+   match M with mon0 => mon0 | _ => zmon j M end.
+
+ Definition zmon_pred j M :=
+   match j with xH => M | _ => mkZmon (Pos.pred 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) : Pol * Pol :=
+   match P, M with
+        _, mon0 => (Pc cO, P)
+   | Pc _, _    => (P, Pc cO)
+   | Pinj j1 P1, zmon j2 M1 =>
+      match (j1 ?= j2) 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) 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) : 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) : 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) : 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) : 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) : R :=
+  match P with
+  | Pc c => [c]
+  | Pinj j Q => Pphi (jump j l) Q
+  | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q
+  end.
+
+ Reserved Notation "P @ l " (at level 10, no associativity).
+ Notation "P @ l " := (Pphi l P).
+
+ (** Evaluation of a monomial towards R *)
+
+ Fixpoint Mphi(l:Env R) (M: Mon) : R :=
+  match M with
+  | mon0 => rI
+  | zmon j M1 => Mphi (jump j l) M1
+  | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i
+  end.
+
+ Notation "M @@ l" := (Mphi l M) (at level 10, no associativity).
+
+ (** Proofs *)
+
+ Ltac destr_pos_sub :=
+  match goal with |- context [Z.pos_sub ?x ?y] =>
+   generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y)
+  end.
+
+ Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l.
+ Proof.
+  revert P';induction P;destruct P';simpl; intros H l; try easy.
+  - now apply (morph_eq CRmorph).
+  - destruct (Pos.compare_spec p p0); [ subst | easy | easy ].
+    now rewrite IHP.
+  - specialize (IHP1 P'1); specialize (IHP2 P'2).
+    destruct (Pos.compare_spec p p0); [ subst | easy | easy ].
+    destruct (P2 ?== P'1); [|easy].
+    rewrite H in *.
+    now rewrite IHP1, IHP2.
+ Qed.
+
+ Lemma Peq_spec P P' :
+   BoolSpec (forall l, P@l == P'@l) True (P ?== P').
+ Proof.
+  generalize (Peq_ok P P'). destruct (P ?== P'); auto.
+ Qed.
+
+ Lemma Pphi0 l : P0@l == 0.
+ Proof.
+  simpl;apply (morph0 CRmorph).
+ Qed.
+
+ Lemma Pphi1 l : P1@l == 1.
+ Proof.
+  simpl;apply (morph1 CRmorph).
+ Qed.
+
+Lemma env_morph p e1 e2 :
+  (forall x, e1 x = e2 x) -> p @ e1 = p @ e2.
+Proof.
+  revert e1 e2. induction p ; simpl.
+  - reflexivity.
+  - intros e1 e2 EQ. apply IHp. intros. apply EQ.
+  - intros e1 e2 EQ. f_equal; [f_equal|].
+    + now apply IHp1.
+    + f_equal. apply EQ.
+    + apply IHp2. intros; apply EQ.
+Qed.
+
+Lemma Pjump_add P i j l :
+  P @ (jump (i + j) l) = P @ (jump j (jump i l)).
+Proof.
+  apply env_morph. intros. rewrite <- jump_add. f_equal.
+  apply Pos.add_comm.
+Qed.
+
+Lemma Pjump_xO_tail P p l :
+  P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l).
+Proof.
+  apply env_morph. intros. now jump_simpl.
+Qed.
+
+Lemma Pjump_pred_double P p l :
+  P @ (jump (Pos.pred_double p) (tail l)) = P @ (jump (xO p) l).
+Proof.
+  apply env_morph. intros.
+  rewrite jump_pred_double. now jump_simpl.
+Qed.
+
+ Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l).
+ Proof.
+  destruct P;simpl;rsimpl.
+  now rewrite Pjump_add.
+ Qed.
+
+ Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j.
+ Proof.
+  rewrite Pos.add_comm.
+  apply (pow_pos_add Rsth (Rmul_ext Reqe) (ARmul_assoc ARth)).
+ Qed.
+
+ Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c').
+ Proof.
+  generalize (morph_eq CRmorph c c').
+  destruct (c ?=! c'); auto.
+ Qed.
+
+ Lemma mkPX_ok l P i Q :
+  (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l).
+ Proof.
+  unfold mkPX. destruct P.
+  - case ceqb_spec; intros H; simpl; try reflexivity.
+    rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl.
+  - reflexivity.
+  - case Peq_spec; intros H; simpl; try reflexivity.
+    rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl.
+ Qed.
+
+ Hint Rewrite
+  Pphi0
+  Pphi1
+  mkPinj_ok
+  mkPX_ok
+  (morph0 CRmorph)
+  (morph1 CRmorph)
+  (morph0 CRmorph)
+  (morph_add CRmorph)
+  (morph_mul CRmorph)
+  (morph_sub CRmorph)
+  (morph_opp CRmorph)
+  : Esimpl.
+
+ (* Quicker than autorewrite with Esimpl :-) *)
+ Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl.
+
+ Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c].
+ Proof.
+  revert l;induction P;simpl;intros;Esimpl;trivial.
+  rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c].
+ Proof.
+  revert l;induction P;simpl;intros.
+  - Esimpl.
+  - rewrite IHP;rsimpl.
+  - rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c].
+ Proof.
+  revert l;induction P;simpl;intros;Esimpl;trivial.
+  rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut.
+ Qed.
+
+ Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c].
+ Proof.
+  unfold PmulC.
+  case ceqb_spec; intros H.
+  - rewrite H; Esimpl.
+  - case ceqb_spec; intros H'.
+    + rewrite H'; Esimpl.
+    + apply PmulC_aux_ok.
+ Qed.
+
+ Lemma Popp_ok P l : (--P)@l == - P@l.
+ Proof.
+  revert l;induction P;simpl;intros.
+  - Esimpl.
+  - apply IHP.
+  - rewrite IHP1, IHP2;rsimpl.
+ Qed.
+
+ Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl.
+
+ Lemma PaddX_ok P' P k l :
+  (forall P l, (P++P')@l == P@l + P'@l) ->
+  (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k.
+ Proof.
+  intros IHP'.
+  revert k l. induction P;simpl;intros.
+  - add_permut.
+  - destruct p; simpl;
+    rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut.
+  - destr_pos_sub; intros ->;Esimpl.
+    + rewrite IHP';rsimpl. add_permut.
+    + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
+    + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
+ Qed.
+
+ Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l.
+ Proof.
+  revert P l; induction P';simpl;intros;Esimpl.
+  - revert p l; induction P;simpl;intros.
+    + Esimpl; add_permut.
+    + destr_pos_sub; intros ->;Esimpl.
+      * now rewrite IHP'.
+      * rewrite IHP';Esimpl. now rewrite Pjump_add.
+      * rewrite IHP. now rewrite Pjump_add.
+    + destruct p0;simpl.
+      * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl.
+      * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl.
+      * rewrite IHP'. rsimpl.
+  - destruct P;simpl.
+    + Esimpl. add_permut.
+    + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl.
+      * rewrite Pjump_xO_tail. rsimpl. add_permut.
+      * rewrite Pjump_pred_double. rsimpl. add_permut.
+      * rsimpl. unfold tail. add_permut.
+    + destr_pos_sub; intros ->; Esimpl.
+      * rewrite IHP'1, IHP'2;rsimpl. add_permut.
+      * rewrite IHP'1, IHP'2;simpl;Esimpl.
+        rewrite pow_pos_add;rsimpl. add_permut.
+      * rewrite PaddX_ok by trivial; rsimpl.
+        rewrite IHP'2, pow_pos_add; rsimpl. add_permut.
+ Qed.
+
+ Lemma PsubX_ok P' P k l :
+  (forall P l, (P--P')@l == P@l - P'@l) ->
+  (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k.
+ Proof.
+  intros IHP'.
+  revert k l. induction P;simpl;intros.
+  - rewrite Popp_ok;rsimpl; add_permut.
+  - destruct p; simpl;
+    rewrite Popp_ok;rsimpl;
+    rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut.
+  - destr_pos_sub; intros ->; Esimpl.
+    + rewrite IHP';rsimpl. add_permut.
+    + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
+    + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
+ Qed.
+
+ Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l.
+ Proof.
+  revert P l; induction P';simpl;intros;Esimpl.
+  - revert p l; induction P;simpl;intros.
+    + Esimpl; add_permut.
+    + destr_pos_sub; intros ->;Esimpl.
+      * rewrite IHP';rsimpl.
+      * rewrite IHP';Esimpl. now rewrite Pjump_add.
+      * rewrite IHP. now rewrite Pjump_add.
+    + destruct p0;simpl.
+      * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl.
+      * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl.
+      * rewrite IHP'. rsimpl.
+  - destruct P;simpl.
+    + Esimpl; add_permut.
+    + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl.
+      * rewrite Pjump_xO_tail. rsimpl. add_permut.
+      * rewrite Pjump_pred_double. rsimpl. add_permut.
+      * rsimpl. unfold tail. add_permut.
+    + destr_pos_sub; intros ->; Esimpl.
+      * rewrite IHP'1, IHP'2;rsimpl. add_permut.
+      * rewrite IHP'1, IHP'2;simpl;Esimpl.
+        rewrite pow_pos_add;rsimpl. add_permut.
+      * rewrite PsubX_ok by trivial;rsimpl.
+        rewrite IHP'2, pow_pos_add;rsimpl. add_permut.
+ Qed.
+
+ Lemma PmulI_ok P' :
+   (forall P l, (Pmul P P') @ l == P @ l * P' @ l) ->
+   forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+  intros IHP'.
+  induction P;simpl;intros.
+  - Esimpl; mul_permut.
+  - destr_pos_sub; intros ->;Esimpl.
+    + now rewrite IHP'.
+    + now rewrite IHP', Pjump_add.
+    + now rewrite IHP, Pjump_add.
+  - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl.
+    + rewrite Pjump_xO_tail. f_equiv. mul_permut.
+    + rewrite Pjump_pred_double. f_equiv. mul_permut.
+    + rewrite IHP'. f_equiv. mul_permut.
+ Qed.
+
+ Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l.
+ Proof.
+  revert P l;induction P';simpl;intros.
+  - apply PmulC_ok.
+  - apply PmulI_ok;trivial.
+  - destruct P.
+    + rewrite (ARmul_comm ARth). Esimpl.
+    + Esimpl. rewrite IHP'1;Esimpl. f_equiv.
+      destruct p0;rewrite IHP'2;Esimpl.
+      * now rewrite Pjump_xO_tail.
+      * rewrite Pjump_pred_double; Esimpl.
+    + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok,
+       !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl.
+      unfold tail.
+      add_permut; f_equiv; mul_permut.
+ Qed.
+
+ Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l.
+ Proof.
+  revert l;induction P;simpl;intros;Esimpl.
+  - apply IHP.
+  - rewrite Padd_ok, Pmul_ok;Esimpl.
+    rewrite IHP1, IHP2.
+    mul_push ((hd l)^p). now mul_push (P2@l).
+ Qed.
+
+ Lemma Mphi_morph M e1 e2 :
+  (forall x, e1 x = e2 x) -> M @@ e1 = M @@ e2.
+ Proof.
+   revert e1 e2; induction M; simpl; intros e1 e2 EQ; trivial.
+   - apply IHM. intros; apply EQ.
+   - f_equal.
+     * apply IHM. intros; apply EQ.
+     * f_equal. apply EQ.
+ Qed.
+
+Lemma Mjump_xO_tail M p l :
+  M @@ (jump (xO p) (tail l)) = M @@ (jump (xI p) l).
+Proof.
+  apply Mphi_morph. intros. now jump_simpl.
+Qed.
+
+Lemma Mjump_pred_double M p l :
+  M @@ (jump (Pos.pred_double p) (tail l)) = M @@ (jump (xO p) l).
+Proof.
+  apply Mphi_morph. intros.
+  rewrite jump_pred_double. now jump_simpl.
+Qed.
+
+Lemma Mjump_add M i j l :
+  M @@ (jump (i + j) l) = M @@ (jump j (jump i l)).
+Proof.
+  apply Mphi_morph. intros. now rewrite <- jump_add, Pos.add_comm.
+Qed.
+
+ Lemma mkZmon_ok M j l :
+   (mkZmon j M) @@ l == (zmon j M) @@ l.
+ Proof.
+ destruct M; simpl; rsimpl.
+ Qed.
+
+ Lemma zmon_pred_ok M j l :
+   (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l.
+ Proof.
+   destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl.
+   - now rewrite Mjump_xO_tail.
+   - rewrite Mjump_pred_double; rsimpl.
+ Qed.
+
+ Lemma mkVmon_ok M i l :
+   (mkVmon i M)@@l == M@@l * (hd l)^i.
+ Proof.
+  destruct M;simpl;intros;rsimpl.
+  - rewrite zmon_pred_ok;simpl;rsimpl.
+  - rewrite pow_pos_add;rsimpl.
+ Qed.
+
+ Ltac destr_mfactor R S := match goal with
+  | H : context [MFactor ?P _] |- context [MFactor ?P ?M] =>
+    specialize (H M); destruct MFactor as (R,S)
+ end.
+
+ Lemma Mphi_ok P M l :
+   let (Q,R) := MFactor P M in
+     P@l == Q@l + M@@l * R@l.
+ Proof.
+ revert M l; induction P; destruct M; intros l; simpl; auto; Esimpl.
+ - case Pos.compare_spec; intros He; simpl.
+   * destr_mfactor R1 S1. now rewrite IHP, He, !mkPinj_ok.
+   * destr_mfactor R1 S1. rewrite IHP; simpl.
+     now rewrite !mkPinj_ok, <- Mjump_add, Pos.add_comm, Pos.sub_add.
+   * Esimpl.
+ - destr_mfactor R1 S1. destr_mfactor R2 S2.
+   rewrite IHP1, IHP2, !mkPX_ok, zmon_pred_ok; simpl; rsimpl.
+   add_permut.
+ - case Pos.compare_spec; intros He; simpl; destr_mfactor R1 S1;
+   rewrite ?He, IHP1, mkPX_ok, ?mkZmon_ok; simpl; rsimpl;
+   unfold tail; add_permut; mul_permut.
+   * rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl.
+   * rewrite mkPX_ok. simpl. Esimpl. mul_permut.
+     rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl.
+ Qed.
+
+ Lemma POneSubst_ok P1 M1 P2 P3 l :
+   POneSubst P1 M1 P2 = Some P3 -> M1@@l == P2@l ->
+   P1@l == P3@l.
+ Proof.
+ unfold POneSubst.
+ assert (H := Mphi_ok P1). destr_mfactor R1 S1. rewrite H; clear H.
+ intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1).
+ - rewrite EQ', Padd_ok, Pmul_ok; rsimpl.
+ - revert EQ. destruct S1; try now injection 1.
+   case ceqb_spec; now inversion 2.
+ Qed.
+
+ Lemma PNSubst1_ok n P1 M1 P2 l :
+    M1@@l == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
+ Proof.
+ revert P1. induction n; simpl; intros P1;
+ generalize (POneSubst_ok P1 M1 P2); destruct POneSubst;
+   intros; rewrite <- ?IHn; auto; reflexivity.
+ Qed.
+
+ Lemma PNSubst_ok n P1 M1 P2 l P3 :
+    PNSubst P1 M1 P2 n = Some P3 -> M1@@l == P2@l -> P1@l == P3@l.
+ Proof.
+ unfold PNSubst.
+ assert (H := POneSubst_ok P1 M1 P2); destruct POneSubst; try discriminate.
+ destruct n; inversion_clear 1.
+ intros. rewrite <- PNSubst1_ok; auto.
+ Qed.
+
+ Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) : Prop :=
+   match LM1 with
+   | cons (M1,P2) LM2 => (M1@@l == P2@l) /\ MPcond LM2 l
+   | _ => True
+   end.
+
+ Lemma PSubstL1_ok n LM1 P1 l :
+   MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l.
+ Proof.
+ revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros.
+ - reflexivity.
+ - rewrite <- IH by intuition. now apply PNSubst1_ok.
+ Qed.
+
+ Lemma PSubstL_ok n LM1 P1 P2 l :
+   PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l.
+ Proof.
+ revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros.
+ - discriminate.
+ - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst.
+   * injection H as [= <-]. rewrite <- PSubstL1_ok; intuition.
+   * now apply IH.
+ Qed.
+
+ Lemma PNSubstL_ok m n LM1 P1 l :
+    MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l.
+ Proof.
+ revert LM1 P1. induction m; simpl; intros;
+ assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL;
+ auto; try reflexivity.
+ rewrite <- IHm; auto.
+ Qed.
+
+ (** 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) : 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 p l : nth p l == (mk_X p) @ l.
+ Proof.
+  destruct p;simpl;intros;Esimpl;trivial.
+  rewrite nth_spec ; auto.
+  unfold hd.
+  now rewrite <- nth_pred_double, nth_jump.
+ Qed.
+
+ Hint Rewrite Padd_ok Psub_ok : Esimpl.
+
+Section POWER.
+  Variable subst_l : Pol -> Pol.
+  Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol :=
+   match p with
+   | xH => subst_l (res ** P)
+   | xO p => Ppow_pos (Ppow_pos res P p) P p
+   | xI p => subst_l ((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 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 subst_l_ok res P p. revert res.
+   induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp;
+    mul_permut.
+  Qed.
+
+  Lemma Ppow_N_ok 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.
+  - reflexivity.
+  - rewrite Ppow_pos_ok by trivial. Esimpl.
+  Qed.
+
+ End POWER.
+
+ (** Normalization and rewriting *)
+
+ Section NORM_SUBST_REC.
+  Variable n : nat.
+  Variable lmp:list (Mon*Pol).
+  Let subst_l P := PNSubstL P lmp n n.
+  Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
+  Let Ppow_subst := Ppow_N subst_l.
+
+  Fixpoint norm_aux (pe:PExpr) : Pol :=
+   match pe with
+   | PEc c => Pc c
+   | PEX j => mk_X j
+   | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1)
+   | PEadd pe1 (PEopp pe2) =>
+     Psub (norm_aux pe1) (norm_aux pe2)
+   | PEadd pe1 pe2 => Padd (norm_aux  pe1) (norm_aux pe2)
+   | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2)
+   | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2)
+   | PEopp pe1 => Popp (norm_aux pe1)
+   | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
+   end.
+
+  Definition norm_subst pe := subst_l (norm_aux pe).
+
+  (** Internally, [norm_aux] is expanded in a large number of cases.
+      To speed-up proofs, we use an alternative definition. *)
+
+  Definition get_PEopp pe :=
+   match pe with
+   | PEopp pe' => Some pe'
+   | _ => None
+   end.
+
+  Lemma norm_aux_PEadd pe1 pe2 :
+    norm_aux (PEadd pe1 pe2) =
+    match get_PEopp pe1, get_PEopp pe2 with
+    | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1')
+    | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2')
+    | None, None => (norm_aux pe1) ++ (norm_aux pe2)
+    end.
+  Proof.
+  simpl (norm_aux (PEadd _ _)).
+  destruct pe1; [ | | | | | reflexivity | ];
+   destruct pe2; simpl get_PEopp; reflexivity.
+  Qed.
+
+  Lemma norm_aux_PEopp pe :
+    match get_PEopp pe with
+    | Some pe' => norm_aux pe = -- (norm_aux pe')
+    | None => True
+    end.
+  Proof.
+  now destruct pe.
+  Qed.
+
+  Lemma norm_aux_spec l pe :
+    PEeval l pe == (norm_aux pe)@l.
+  Proof.
+   intros.
+   induction pe.
+   - reflexivity.
+   - apply mkX_ok.
+   - simpl PEeval. rewrite IHpe1, IHpe2.
+     assert (H1 := norm_aux_PEopp pe1).
+     assert (H2 := norm_aux_PEopp pe2).
+     rewrite norm_aux_PEadd.
+     do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut.
+   - simpl. rewrite IHpe1, IHpe2. Esimpl.
+   - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok.
+   - simpl. rewrite IHpe. Esimpl.
+   - simpl. rewrite Ppow_N_ok by reflexivity.
+     rewrite (rpow_pow_N pow_th). destruct n0; simpl; Esimpl.
+     induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok.
+  Qed.
+
+ End NORM_SUBST_REC.
+
+End MakeRingPol.
diff --git a/theories/micromega/Fourier.v b/theories/micromega/Fourier.v
new file mode 100644
index 0000000000..0153de1dab
--- /dev/null
+++ b/theories/micromega/Fourier.v
@@ -0,0 +1,5 @@
+Require Import Lra.
+Require Export Fourier_util.
+
+#[deprecated(since = "8.9.0", note = "Use lra instead.")]
+Ltac fourier := lra.
diff --git a/theories/micromega/Fourier_util.v b/theories/micromega/Fourier_util.v
new file mode 100644
index 0000000000..95fa5b88df
--- /dev/null
+++ b/theories/micromega/Fourier_util.v
@@ -0,0 +1,31 @@
+Require Export Rbase.
+Require Import Lra.
+
+Local Open Scope R_scope.
+
+Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y.
+intros x y H H0; try assumption.
+replace 0 with (x * 0).
+apply Rmult_lt_compat_l; auto with real.
+ring.
+Qed.
+
+Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x.
+intros x H; try assumption.
+rewrite Rplus_comm.
+apply Rle_lt_0_plus_1.
+red; auto with real.
+Qed.
+
+Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x.
+  intros; lra.
+Qed.
+
+Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y.
+intros x y H H0; try assumption.
+case H; intros.
+red; left.
+apply Rlt_mult_inv_pos; auto with real.
+rewrite <- H1.
+red; right; ring.
+Qed.
diff --git a/theories/micromega/Lia.v b/theories/micromega/Lia.v
new file mode 100644
index 0000000000..e53800d07d
--- /dev/null
+++ b/theories/micromega/Lia.v
@@ -0,0 +1,39 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria)      2013-2016                        *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import ZMicromega.
+Require Import ZArith_base.
+Require Import RingMicromega.
+Require Import VarMap.
+Require Import DeclConstant.
+Require Coq.micromega.Tauto.
+Declare ML Module "micromega_plugin".
+
+
+Ltac zchecker :=
+  intros __wit __varmap __ff ;
+  exact (ZTautoChecker_sound __ff __wit
+                                (@eq_refl bool true <: @eq bool (ZTautoChecker __ff __wit) true)
+                                (@find Z Z0 __varmap)).
+
+Ltac lia := PreOmega.zify; xlia zchecker.
+               
+Ltac nia := PreOmega.zify; xnlia zchecker.
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/theories/micromega/Lqa.v b/theories/micromega/Lqa.v
new file mode 100644
index 0000000000..25fb62cfad
--- /dev/null
+++ b/theories/micromega/Lqa.v
@@ -0,0 +1,54 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria)      2016                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import QMicromega.
+Require Import QArith.
+Require Import RingMicromega.
+Require Import VarMap.
+Require Import DeclConstant.
+Require Coq.micromega.Tauto.
+Declare ML Module "micromega_plugin".
+
+Ltac rchange := 
+  intros __wit __varmap __ff ;
+  change (Tauto.eval_bf (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
+  apply (QTautoChecker_sound __ff __wit).
+
+Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity.
+Ltac rchecker_abstract   := rchange ; vm_cast_no_check (eq_refl true).
+
+Ltac rchecker := rchecker_no_abstract.
+
+(** Here, lra stands for linear rational arithmetic *)
+Ltac lra := lra_Q  rchecker.
+
+(** Here, nra stands for non-linear rational arithmetic *)
+Ltac nra := xnqa  rchecker.
+
+Ltac xpsatz dom d :=
+  let tac := lazymatch dom with
+  | Q =>
+    ((sos_Q rchecker) || (psatz_Q d rchecker))
+  | _ => 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).
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/theories/micromega/Lra.v b/theories/micromega/Lra.v
new file mode 100644
index 0000000000..2403696696
--- /dev/null
+++ b/theories/micromega/Lra.v
@@ -0,0 +1,54 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria)      2016                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import RMicromega.
+Require Import QMicromega.
+Require Import Rdefinitions.
+Require Import RingMicromega.
+Require Import VarMap.
+Require Coq.micromega.Tauto.
+Declare ML Module "micromega_plugin".
+
+Ltac rchange := 
+  intros __wit __varmap __ff ;
+  change (Tauto.eval_bf (Reval_formula (@find R 0%R __varmap)) __ff) ;
+  apply (RTautoChecker_sound __ff __wit).
+
+Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity.
+Ltac rchecker_abstract   := rchange ; vm_cast_no_check (eq_refl true).
+
+Ltac rchecker := rchecker_no_abstract.
+
+(** Here, lra stands for linear real arithmetic *)
+Ltac lra := unfold Rdiv in * ;   lra_R  rchecker.
+
+(** Here, nra stands for non-linear real arithmetic *)
+Ltac nra := unfold Rdiv in * ; xnra  rchecker.
+
+Ltac xpsatz dom d :=
+  let tac := lazymatch dom with
+  | R =>
+    (sos_R rchecker) || (psatz_R d rchecker)
+  | _ => 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).
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/theories/micromega/MExtraction.v b/theories/micromega/MExtraction.v
new file mode 100644
index 0000000000..0e8c09ef1b
--- /dev/null
+++ b/theories/micromega/MExtraction.v
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+(* Used to generate micromega.ml *)
+
+Require Extraction.
+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 [ "[]" "(::)" ].
+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 expanded.
+    Let's rather use the ocaml && *)
+Extract Inlined Constant andb => "(&&)".
+
+Import Reals.Rdefinitions.
+
+Extract Constant R => "int".
+Extract Constant R0 => "0".
+Extract Constant R1 => "1".
+Extract Constant Rplus => "( + )".
+Extract Constant Rmult => "( * )".
+Extract Constant Ropp  => "fun x -> - x".
+Extract Constant Rinv   => "fun x -> 1 / x".
+
+(** In order to avoid annoying build dependencies the actual
+    extraction is only performed as a test in the test suite. *)
+(*Extraction "micromega.ml"
+           Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula
+           Tauto.abst_form
+           ZMicromega.cnfZ  ZMicromega.Zeval_const QMicromega.cnfQ
+           List.map simpl_cone (*map_cone  indexes*)
+           denorm Qpower vm_add
+   normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
+*)
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/theories/micromega/OrderedRing.v b/theories/micromega/OrderedRing.v
new file mode 100644
index 0000000000..d5884d9c1c
--- /dev/null
+++ b/theories/micromega/OrderedRing.v
@@ -0,0 +1,460 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                      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 (@Equivalence_Reflexive _ _ (SORsetoid sor))
+  symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor))
+  transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor))
+as sor_setoid.
+
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact (SORplus_wd sor).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact (SORtimes_wd sor).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact (SORopp_wd sor).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+exact (SORle_wd sor).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+exact (SORlt_wd sor).
+Qed.
+
+Add Ring SOR : (SORrt sor).
+
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+intros x1 x2 H1 y1 y2 H2.
+rewrite ((Rsub_def (SORrt sor)) x1 y1).
+rewrite ((Rsub_def (SORrt sor)) 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.
+
+(* Properties 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 (SORle_refl sor).
+
+Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m.
+Proof (SORle_antisymm sor).
+
+Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p.
+Proof (SORle_trans sor).
+
+Theorem Rlt_trichotomy : forall n m : R,  n < m \/ n == m \/ m < n.
+Proof (SORlt_trichotomy sor).
+
+Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m.
+Proof (SORlt_le_neq sor).
+
+Theorem Rneq_0_1 : 0 ~= 1.
+Proof (SORneq_0_1 sor).
+
+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 (SORplus_le_mono_l sor).
+intro H. apply ((SORplus_le_mono_l sor) (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 (SORtimes_pos_pos sor).
+
+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/theories/micromega/Psatz.v b/theories/micromega/Psatz.v
new file mode 100644
index 0000000000..16ae24ba81
--- /dev/null
+++ b/theories/micromega/Psatz.v
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2016                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import ZMicromega.
+Require Import QMicromega.
+Require Import RMicromega.
+Require Import QArith.
+Require Import ZArith.
+Require Import Rdefinitions.
+Require Import RingMicromega.
+Require Import VarMap.
+Require Coq.micromega.Tauto.
+Require Lia.
+Require Lra.
+Require Lqa.
+
+Declare ML Module "micromega_plugin".
+
+Ltac lia := Lia.lia.
+
+Ltac nia := Lia.nia.
+
+
+Ltac xpsatz dom d :=
+  let tac := lazymatch dom with
+  | Z =>
+    (sos_Z Lia.zchecker) || (psatz_Z d  Lia.zchecker)
+  | R =>
+    (sos_R Lra.rchecker) || (psatz_R d Lra.rchecker)
+  | Q => (sos_Q Lqa.rchecker) || (psatz_Q d Lqa.rchecker) 
+  | _ => 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 => Lia.lia
+  | Q => Lqa.lra
+  | R => Lra.lra
+  | _ => fail "Unsupported domain"
+  end in tac.
+
+
+Ltac lra := 
+  first [ psatzl R | psatzl Q ].
+
+Ltac nra := 
+  first [ Lra.nra | Lqa.nra ].  
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/theories/micromega/QMicromega.v b/theories/micromega/QMicromega.v
new file mode 100644
index 0000000000..4a02d1d01e
--- /dev/null
+++ b/theories/micromega/QMicromega.v
@@ -0,0 +1,220 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* 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 Z.add Z.mul Z.sub Z.opp  (fun x => x) (fun x => Z.of_N x) (Z.pow).*)
+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 Coq.micromega.Tauto.
+
+Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool.
+
+Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool.
+
+Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool.
+
+Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool.
+
+Definition normQ  := norm 0 1 Qplus Qmult Qminus Qopp Qeq_bool.
+Declare Equivalent Keys normQ RingMicromega.norm.
+
+Definition cnfQ (Annot TX AF: Type) (f: TFormula (Formula Q) Annot TX AF) :=
+  rxcnf qunsat qdeduce (Qnormalise Annot) (Qnegate Annot) true f.
+
+Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness)  : bool :=
+  @tauto_checker (Formula Q) (NFormula Q) unit
+  qunsat qdeduce
+  (Qnormalise unit)
+  (Qnegate unit) QWitness (fun cl => QWeakChecker (List.map fst cl)) f w.
+
+
+
+Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_bf  (Qeval_formula env)  f.
+Proof.
+  intros f w.
+  unfold QTautoChecker.
+  apply tauto_checker_sound  with (eval:= Qeval_formula) (eval':= Qeval_nformula).
+  - apply Qeval_nformula_dec.
+  - intros until env.
+    unfold eval_nformula. unfold RingMicromega.eval_nformula.
+    destruct t.
+    apply (check_inconsistent_sound Qsor QSORaddon) ; auto.
+  - unfold qdeduce. intros. revert H. apply (nformula_plus_nformula_correct Qsor QSORaddon);auto.
+  - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now  eapply (cnf_normalise_correct Qsor QSORaddon);eauto.
+  - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_negate_correct Qsor QSORaddon);eauto.
+  - intros t w0.
+    unfold eval_tt.
+    intros.
+    rewrite make_impl_map with (eval := Qeval_nformula env).
+    eapply QWeakChecker_sound; eauto.
+    tauto.
+Qed.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/theories/micromega/RMicromega.v b/theories/micromega/RMicromega.v
new file mode 100644
index 0000000000..0f7a02c2c9
--- /dev/null
+++ b/theories/micromega/RMicromega.v
@@ -0,0 +1,489 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* 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 Rfunctions RIneq Rpow_def.
+Require Import QArith.
+Require Import Qfield.
+Require Import Qreals.
+Require Import DeclConstant.
+Require Import Ztac.
+
+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.
+
+Local Open Scope R_scope.
+
+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.
+  now apply Rmult_lt_0_compat.
+Qed.
+
+Lemma Rinv_1 : forall x, x * / 1 = x.
+Proof.
+  intro.
+  rewrite Rinv_1.
+  apply Rmult_1_r.
+Qed.
+
+Lemma Qeq_true : forall x y, Qeq_bool x y = true -> Q2R x = Q2R y.
+Proof.
+  intros.
+  now apply Qeq_eqR, Qeq_bool_eq.
+Qed.
+
+Lemma Qeq_false : forall x y, Qeq_bool x y = false -> Q2R x <> Q2R y.
+Proof.
+  intros.
+  apply Qeq_bool_neq in H.
+  contradict H.
+  now apply eqR_Qeq.
+Qed.
+
+Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> Q2R x <= Q2R y.
+Proof.
+  intros.
+  now apply Qle_Rle, Qle_bool_imp_le.
+Qed.
+
+Lemma Q2R_0 : Q2R 0 = 0.
+Proof.
+  apply Rmult_0_l.
+Qed.
+
+Lemma Q2R_1 : Q2R 1 = 1.
+Proof.
+  compute. apply Rinv_1.
+Qed.
+
+Lemma Q2R_inv_ext : forall x,
+  Q2R (/ x) = (if Qeq_bool x 0 then 0 else / Q2R x).
+Proof.
+  intros.
+  case_eq (Qeq_bool x 0).
+  intros.
+  apply Qeq_bool_eq in H.
+  destruct x ; simpl.
+  unfold Qeq in H.
+  simpl in H.
+  rewrite Zmult_1_r in H.
+  rewrite H.
+  apply Rmult_0_l.
+  intros.
+  now apply Q2R_inv, Qeq_bool_neq.
+Qed.
+
+Notation to_nat := N.to_nat.
+
+Lemma QSORaddon :
+  @SORaddon R
+  R0 R1 Rplus Rmult Rminus Ropp  (@eq R)  Rle (* ring elements *)
+  Q 0%Q 1%Q Qplus Qmult Qminus Qopp (* coefficients *)
+  Qeq_bool Qle_bool
+  Q2R nat to_nat pow.
+Proof.
+  constructor.
+  constructor ; intros ; try reflexivity.
+  apply Q2R_0.
+  apply Q2R_1.
+  apply Q2R_plus.
+  apply Q2R_minus.
+  apply Q2R_mult.
+  apply Q2R_opp.
+  apply Qeq_true ; auto.
+  apply R_power_theory.
+  apply Qeq_false.
+  apply Qle_true.
+Qed.
+
+(* Syntactic ring coefficients. *)
+
+Inductive Rcst :=
+  | C0
+  | C1
+  | CQ (r : Q)
+  | CZ (r : Z)
+  | CPlus (r1 r2 : Rcst)
+  | CMinus (r1  r2 : Rcst)
+  | CMult (r1 r2 : Rcst)
+  | CPow  (r1 : Rcst) (z:Z+nat)
+  | CInv  (r : Rcst)
+  | COpp  (r : Rcst).
+
+
+
+Definition z_of_exp (z : Z + nat) :=
+  match z with
+  | inl z => z
+  | inr n => Z.of_nat n
+  end.
+
+Fixpoint Q_of_Rcst (r : Rcst) : Q :=
+  match r with
+    | C0 => 0 # 1
+    | C1 => 1 # 1
+    | CZ z => z # 1
+    | CQ q => q
+    | CPlus r1 r2 => Qplus (Q_of_Rcst r1) (Q_of_Rcst r2)
+    | CMinus r1 r2 => Qminus (Q_of_Rcst r1) (Q_of_Rcst r2)
+    | CMult r1 r2  => Qmult (Q_of_Rcst r1) (Q_of_Rcst r2)
+    | CPow  r1 z   => Qpower (Q_of_Rcst r1) (z_of_exp z)
+    | CInv r       => Qinv (Q_of_Rcst r)
+    | COpp r       => Qopp (Q_of_Rcst r)
+  end.
+
+
+Definition is_neg (z: Z+nat) :=
+  match z with
+  | inl (Zneg _) => true
+  |  _           => false
+  end.
+
+Lemma is_neg_true : forall z, is_neg z = true -> (z_of_exp z < 0)%Z.
+Proof.
+  destruct z ; simpl ; try congruence.
+  destruct z ; try congruence.
+  intros.
+  reflexivity.
+Qed.
+
+Lemma is_neg_false : forall z, is_neg z = false -> (z_of_exp z >= 0)%Z.
+Proof.
+  destruct z ; simpl ; try congruence.
+  destruct z ; try congruence.
+  compute. congruence.
+  compute. congruence.
+  generalize (Zle_0_nat n). auto using Z.le_ge.
+Qed.
+
+Definition CInvR0 (r : Rcst) := Qeq_bool (Q_of_Rcst r) (0 # 1).
+
+Definition CPowR0 (z : Z) (r : Rcst) :=
+  Z.ltb z Z0 && Qeq_bool (Q_of_Rcst r) (0 # 1).
+
+Fixpoint R_of_Rcst (r : Rcst) : R :=
+  match r with
+    | C0 => R0
+    | C1 => R1
+    | CZ z => IZR z
+    | CQ q => Q2R q
+    | CPlus r1 r2  => (R_of_Rcst r1) + (R_of_Rcst r2)
+    | CMinus r1 r2 => (R_of_Rcst r1) - (R_of_Rcst r2)
+    | CMult r1 r2  => (R_of_Rcst r1) * (R_of_Rcst r2)
+    | CPow r1 z    =>
+      match z with
+      | inl z =>
+        if CPowR0 z r1
+        then R0
+        else  powerRZ (R_of_Rcst r1) z
+      | inr n => pow (R_of_Rcst r1) n
+      end
+    | CInv r       => 
+      if CInvR0 r then R0
+      else Rinv (R_of_Rcst r)
+    | COpp r       => - (R_of_Rcst r)
+  end.
+
+Add Morphism Q2R with signature Qeq ==> @eq R as Q2R_m.
+  exact Qeq_eqR.
+Qed.
+
+Lemma Q2R_pow_pos : forall q p,
+    Q2R (pow_pos Qmult q p) = pow_pos Rmult (Q2R q) p.
+Proof.
+  induction p ; simpl;auto;
+    rewrite <- IHp;
+    repeat rewrite Q2R_mult;
+    reflexivity.
+Qed.
+
+Lemma Q2R_pow_N : forall q n,
+  Q2R (pow_N 1%Q Qmult q n) = pow_N 1 Rmult (Q2R q) n.
+Proof.
+  destruct n ; simpl.
+  - apply Q2R_1.
+  - apply Q2R_pow_pos.
+Qed.
+
+Lemma Qmult_integral : forall q r, q * r ==  0 -> q == 0 \/ r == 0.
+Proof.
+  intros.
+  destruct (Qeq_dec q 0)%Q.
+  - left ; apply q0.
+  - apply Qmult_integral_l in H ; tauto.
+Qed.
+
+Lemma Qpower_positive_eq_zero : forall q p,
+    Qpower_positive q p == 0 -> q == 0.
+Proof.
+  unfold Qpower_positive.
+  induction p ; simpl; intros;
+    repeat match goal with
+    | H : _ * _ == 0 |- _ =>
+      apply Qmult_integral in H; destruct H
+    end; tauto.
+Qed.
+
+Lemma Qpower_positive_zero : forall p,
+    Qpower_positive 0 p == 0%Q.
+Proof.
+  induction p ; simpl;
+    try rewrite IHp ; reflexivity.
+Qed.
+
+
+Lemma Q2RpowerRZ :
+  forall q z
+         (DEF : not (q == 0)%Q \/ (z >= Z0)%Z),
+    Q2R (q ^ z) = powerRZ (Q2R q) z.
+Proof.
+  intros.
+  destruct Qpower_theory.
+  destruct R_power_theory.
+  unfold Qpower, powerRZ.
+  destruct z.
+  - apply Q2R_1.
+  -
+    change (Qpower_positive q p)
+          with (Qpower q (Zpos p)).
+    rewrite <- N2Z.inj_pos.
+    rewrite <- positive_N_nat.
+    rewrite rpow_pow_N.
+    rewrite rpow_pow_N0.
+    apply Q2R_pow_N.
+  -
+    rewrite  Q2R_inv.
+    unfold Qpower_positive.
+    rewrite <- positive_N_nat.
+    rewrite rpow_pow_N0.
+    unfold pow_N.
+    rewrite Q2R_pow_pos.
+    auto.
+    intro.
+    apply Qpower_positive_eq_zero in H.
+    destruct DEF ; auto with arith.
+Qed.
+
+Lemma Qpower0 : forall z, (z <> 0)%Z -> (0 ^ z == 0)%Q.
+Proof.
+  unfold Qpower.
+  destruct z;intros.
+  - congruence.
+  - apply Qpower_positive_zero.
+  - rewrite Qpower_positive_zero.
+    reflexivity.
+Qed.
+
+
+Lemma Q_of_RcstR : forall c, Q2R (Q_of_Rcst c) = R_of_Rcst c.
+Proof.
+  induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2).
+  - apply Q2R_0.
+  - apply Q2R_1.
+  - reflexivity.
+  - unfold Q2R. simpl. rewrite Rinv_1. reflexivity.
+  - apply Q2R_plus.
+  - apply Q2R_minus.
+  - apply Q2R_mult.
+  - destruct z.
+    destruct (CPowR0 z c) eqn:C; unfold CPowR0 in C.
+    +
+      rewrite andb_true_iff in C.
+      destruct C as (C1 & C2).
+      rewrite Z.ltb_lt in C1.
+      apply Qeq_bool_eq in C2.
+      rewrite C2.
+      simpl.
+      rewrite Qpower0.
+      apply Q2R_0.
+      intro ; subst ; slia C1 C1.
+    + rewrite Q2RpowerRZ.
+      rewrite IHc.
+      reflexivity.
+      rewrite andb_false_iff in C.
+      destruct C.
+      simpl. apply Z.ltb_ge in H.
+      right ; normZ. slia H H0.
+      left ; apply Qeq_bool_neq; auto.
+    + simpl.
+      rewrite <- IHc.
+      destruct Qpower_theory.
+      rewrite <- nat_N_Z.
+      rewrite rpow_pow_N.
+      destruct R_power_theory.
+      rewrite <- (Nnat.Nat2N.id n) at 2.
+      rewrite rpow_pow_N0.
+      apply Q2R_pow_N.
+  - rewrite <- IHc.
+    unfold CInvR0.
+    apply Q2R_inv_ext.
+  - rewrite <- IHc.
+    apply Q2R_opp.
+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 R_of_Rcst N.to_nat 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 Rcst) :=
+  let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs).
+
+
+Definition Reval_formula' :=
+  eval_sformula  Rplus Rmult Rminus Ropp (@eq R) Rle Rlt N.to_nat pow R_of_Rcst.
+
+Definition QReval_formula := 
+  eval_formula  Rplus Rmult Rminus Ropp (@eq R) Rle Rlt Q2R N.to_nat 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 Qeval_nformula :=
+  eval_nformula 0 Rplus Rmult  (@eq R) Rle Rlt Q2R.
+
+
+Lemma Reval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d).
+Proof.
+  exact (fun env d =>eval_nformula_dec Rsor Q2R env d).
+Qed.
+
+Definition RWitness := Psatz Q.
+
+Definition RWeakChecker := check_normalised_formulas 0%Q 1%Q Qplus Qmult  Qeq_bool Qle_bool.
+
+Require Import List.
+
+Lemma RWeakChecker_sound :   forall (l : list (NFormula Q)) (cm : RWitness),
+  RWeakChecker 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 Rsor QSORaddon l cm).
+  unfold RWeakChecker in H.
+  exact H.
+Qed.
+
+Require Import Coq.micromega.Tauto.
+
+Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool Qle_bool.
+Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool Qle_bool.
+
+Definition runsat := check_inconsistent 0%Q Qeq_bool Qle_bool.
+
+Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool.
+
+Definition RTautoChecker (f : BFormula (Formula Rcst)) (w: list RWitness)  : bool :=
+  @tauto_checker (Formula Q) (NFormula Q)
+  unit runsat rdeduce
+  (Rnormalise unit) (Rnegate unit)
+  RWitness (fun cl => RWeakChecker (List.map fst cl)) (map_bformula (map_Formula Q_of_Rcst)  f) w.
+
+Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_bf  (Reval_formula env)  f.
+Proof.
+  intros f w.
+  unfold RTautoChecker.
+  intros TC env.
+  apply tauto_checker_sound with (eval:=QReval_formula) (eval':=    Qeval_nformula) (env := env) in TC.
+  - change (eval_f (fun x : Prop => x) (QReval_formula env))
+      with
+        (eval_bf  (QReval_formula env)) in TC.
+    rewrite eval_bf_map in TC.
+    unfold eval_bf in TC.
+    rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto.
+  intro.
+  unfold QReval_formula.
+  rewrite <- eval_formulaSC  with (phiS := R_of_Rcst).
+  rewrite Reval_formula_compat.
+  tauto.
+  intro. rewrite Q_of_RcstR. reflexivity.
+  -
+  apply Reval_nformula_dec.
+  - destruct t.
+  apply (check_inconsistent_sound Rsor QSORaddon) ; auto.
+  - unfold rdeduce.
+    intros. revert H.
+    eapply (nformula_plus_nformula_correct Rsor QSORaddon); eauto.
+  - now apply (cnf_normalise_correct Rsor QSORaddon).
+  - intros. now eapply (cnf_negate_correct Rsor QSORaddon); eauto.
+  - intros t w0.
+    unfold eval_tt.
+    intros.
+    rewrite make_impl_map with (eval := Qeval_nformula env0).
+    eapply RWeakChecker_sound; eauto.
+    tauto.
+Qed.
+
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/theories/micromega/Refl.v b/theories/micromega/Refl.v
new file mode 100644
index 0000000000..cd759029fa
--- /dev/null
+++ b/theories/micromega/Refl.v
@@ -0,0 +1,152 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* 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.
+
+
+Theorem make_impl_map :
+  forall (A B: Type) (eval : A -> Prop) (eval' : A*B -> Prop) (l : list (A*B)) r
+         (EVAL : forall x, eval' x <-> eval (fst x)),
+    make_impl eval' l r <-> make_impl eval (List.map fst l) r.
+Proof.
+induction l as [| a l IH]; simpl.
+- tauto.
+- intros.
+  rewrite EVAL.
+  rewrite IH.
+  tauto.
+  auto.
+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.
+
+Infix "+++" := rev_append (right associativity, at level 60) : list_scope.
+
+Lemma make_conj_rapp : forall  A eval l1 l2, @make_conj A eval (l1 +++ l2) <-> @make_conj A eval (l1++l2).
+Proof.
+  induction l1.
+  - simpl. tauto.
+  - intros.
+    simpl rev_append at 1.
+    rewrite IHl1.
+    rewrite make_conj_app.
+    rewrite make_conj_cons.
+    simpl app.
+    rewrite make_conj_cons.
+    rewrite make_conj_app.
+    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.
+  rewrite make_conj_cons.
+  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).
+    rewrite !not_make_conj_cons by auto.
+    rewrite IHt by auto.
+    tauto.
+Qed.
diff --git a/theories/micromega/RingMicromega.v b/theories/micromega/RingMicromega.v
new file mode 100644
index 0000000000..aa8876357a
--- /dev/null
+++ b/theories/micromega/RingMicromega.v
@@ -0,0 +1,1134 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                      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.
+Require Coq.micromega.Tauto.
+
+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 : Type. (* 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 (@Equivalence_Reflexive _ _ (SORsetoid sor))
+  symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor))
+  transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor))
+as micomega_sor_setoid.
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact (SORplus_wd sor).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact (SORtimes_wd sor).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact (SORopp_wd sor).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+  exact (SORle_wd sor).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+  exact (SORlt_wd sor).
+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 (SORcleb_morph addon).
+Qed.
+
+Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y].
+Proof.
+intros x y H1. apply (SORcneqb_morph addon). 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 : PolEnv -> PolC -> R :=
+   Pphi rplus rtimes phi.
+
+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.
+
+Arguments map_option [A B] f o.
+
+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.
+
+Arguments map_option2 [A B C] f o o'.
+
+Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*)
+                       (SORplus_wd sor)
+                       (SORtimes_wd sor)
+                       (SORopp_wd sor).
+
+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 (SORsetoid sor) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor))  (SORrm addon)).
+  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 (SORsetoid sor) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor))  (SORrm addon));
+  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 (SORsetoid sor) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor))  (SORrm addon));
+  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)) as [Hin|Heq].
+  (* index is in bounds *)
+  apply H. congruence.
+  (* index is out-of-bounds *)
+  inversion H0.
+  rewrite Heq. simpl.
+  now apply  (morph0 (SORrm addon)).
+  (* PsatzSquare *)
+  simpl. intros. inversion H0.
+  simpl. unfold eval_pol.
+  rewrite (Psquare_ok (SORsetoid sor) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor))  (SORrm addon));
+  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 <- (morph0 (SORrm addon)). now apply cltb_sound.
+  discriminate.
+  (* PsatzZ *)
+  simpl. intros. inversion H0.
+  simpl.   apply  (morph0 (SORrm addon)).
+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; destruct m ; simpl; auto with arith.
+  specialize (IHn m). destruct (ge_bool); auto with arith.
+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.
+
+Fixpoint nhyps_of_psatz (prf : Psatz) : list nat :=
+  match prf with
+    | PsatzC _ | PsatzZ | PsatzSquare _ => nil
+    | PsatzMulC _ prf => nhyps_of_psatz prf
+    | PsatzAdd e1 e2 | PsatzMulE e1 e2 => nhyps_of_psatz e1 ++ nhyps_of_psatz e2
+    | PsatzIn n => n :: nil
+  end.
+
+
+Fixpoint extract_hyps (l: list NFormula) (ln : list nat) : list NFormula  :=
+  match ln with
+    | nil => nil
+    | n::ln => nth n l (Pc cO, Equal) :: extract_hyps l ln
+  end.
+      
+Lemma extract_hyps_app : forall l ln1 ln2,
+  extract_hyps l (ln1 ++ ln2) = (extract_hyps l ln1) ++ (extract_hyps l ln2).
+Proof.
+  induction ln1.
+  reflexivity.
+  simpl.
+  intros.
+  rewrite IHln1. reflexivity.
+Qed.
+  
+Ltac inv H := inversion H ; try subst ; clear H.
+
+Lemma nhyps_of_psatz_correct :  forall (env : PolEnv) (e:Psatz)  (l : list NFormula)  (f: NFormula),
+  eval_Psatz l e = Some f -> 
+  ((forall f', In f' (extract_hyps l (nhyps_of_psatz e)) -> eval_nformula env f') ->  eval_nformula env f).
+Proof.
+  induction e ; intros.
+  (*PsatzIn*)
+  simpl in *. 
+  apply H0. intuition congruence.
+  (* PsatzSquare *)
+  simpl in *.
+  inv H.
+  simpl.
+  unfold eval_pol.
+  rewrite (Psquare_ok (SORsetoid sor) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor))  (SORrm addon));
+  now apply (Rtimes_square_nonneg sor).
+  (* PsatzMulC *)
+  simpl in *.
+  case_eq (eval_Psatz l e).
+  intros. rewrite H1 in H. simpl in H.
+  apply pexpr_times_nformula_correct with (2:= H).
+  apply IHe with (1:= H1); auto.
+  intros. rewrite H1 in H. simpl in H ; discriminate.
+  (* PsatzMulE *)
+  simpl in *.
+  revert H.
+  case_eq (eval_Psatz l e1).
+  case_eq (eval_Psatz l e2) ; simpl ; intros.
+  apply nformula_times_nformula_correct with (3:= H2).
+  apply IHe1 with (1:= H1) ; auto.
+  intros. apply H0. rewrite extract_hyps_app.
+  apply in_or_app. tauto.
+  apply IHe2 with (1:= H) ; auto.
+  intros. apply H0. rewrite extract_hyps_app.
+  apply in_or_app. tauto.
+  discriminate. simpl. discriminate.
+  (* PsatzAdd *)
+  simpl in *.
+  revert H.
+  case_eq (eval_Psatz l e1).
+  case_eq (eval_Psatz l e2) ; simpl ; intros.
+  apply nformula_plus_nformula_correct with (3:= H2).
+  apply IHe1 with (1:= H1) ; auto.
+  intros. apply H0. rewrite extract_hyps_app.
+  apply in_or_app. tauto.
+  apply IHe2 with (1:= H) ; auto.
+  intros. apply H0. rewrite extract_hyps_app.
+  apply in_or_app. tauto.
+  discriminate. simpl. discriminate.
+  (* PsatzC *)
+  simpl in H.
+  case_eq (cO [<] c).
+  intros.  rewrite H1 in H. inv H.
+  unfold eval_nformula. simpl.
+  rewrite <- (morph0 (SORrm addon)). now apply cltb_sound.
+  intros. rewrite H1 in H. discriminate.
+  (* PsatzZ *)
+  simpl in *. inv H. 
+  unfold eval_nformula. simpl.
+  apply  (morph0 (SORrm addon)).
+Qed.
+  
+
+
+
+
+
+(* 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*)
+                       (SORplus_wd sor)
+                       (SORtimes_wd sor)
+                       (SORopp_wd sor) in
+                       PsubC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor))
+                (SORrm addon).
+
+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*)
+                       (SORplus_wd sor)
+                       (SORtimes_wd sor)
+                       (SORopp_wd sor) in
+                       PaddC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor))
+                (SORrm addon).
+
+
+(* 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 <- (morph0 (SORrm addon)); trivial.
+now apply cneqb_sound.
+apply (morph_eq (SORrm addon)) 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 : PolEnv -> PExpr C -> R :=
+ PEeval rplus rtimes rminus ropp phi pow_phi rpow.
+
+#[universes(template)]
+Record Formula (T:Type) : Type := {
+  Flhs : PExpr T;
+  Fop : Op2;
+  Frhs : PExpr T
+}.
+
+Definition eval_formula (env : PolEnv) (f : Formula C) : 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 pmul := Pmul cO cI cplus ctimes ceqb.
+
+Definition popp := Popp copp.
+
+Definition normalise (f : Formula C) : 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 C) : 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  (SORsetoid sor) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)).
+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  (SORsetoid sor) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)).
+Qed.
+
+Lemma eval_pol_mul : forall env lhs rhs, eval_pol env (pmul  lhs rhs) == eval_pol env lhs * eval_pol env rhs.
+Proof.
+  intros.
+  apply (Pmul_ok  sor.(SORsetoid) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)).
+Qed.
+
+Lemma eval_pol_opp : forall env e, eval_pol env (popp e) ==  - eval_pol env e.
+Proof.
+  intros.
+  apply (Popp_ok  (SORsetoid sor) Rops_wd
+    (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)).
+Qed.
+
+
+Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env  (norm lhs).
+Proof.
+  intros.
+  apply  (norm_aux_spec (SORsetoid sor) Rops_wd   (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon) (SORpower addon) ).
+Qed.
+
+
+Theorem normalise_sound :
+  forall (env : PolEnv) (f : Formula C),
+    eval_formula env f <-> eval_nformula env (normalise f).
+Proof.
+intros env f; destruct f as [lhs op rhs]; simpl in *.
+destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm.
+- symmetry.
+  now apply (Rminus_eq_0 sor).
+- rewrite (Rminus_eq_0 sor).
+  tauto.
+- 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 C),
+    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 normalisation - this is used for cnf conversion **)
+
+Definition xnormalise (f:NFormula) : list (NFormula)  :=
+  let (e,o) := f in
+  match o with
+  | Equal     => (e , Strict) :: (popp e, Strict) :: nil
+  | NonEqual  => (e , Equal) :: nil
+  | Strict    => (popp e, NonStrict) :: nil
+  | NonStrict => (popp e, Strict) :: nil
+  end.
+
+Definition xnegate (t:NFormula) : list (NFormula)  :=
+  let (e,o) := t in
+    match o with
+      | Equal  => (e,Equal) :: nil
+      | NonEqual => (e,Strict)::(popp e,Strict)::nil
+      | Strict  => (e,Strict) :: nil
+      | NonStrict  => (e,NonStrict) :: nil
+    end.
+
+
+Import Coq.micromega.Tauto.
+
+Definition cnf_of_list {T : Type} (l:list NFormula) (tg : T) : cnf NFormula T :=
+  List.fold_right (fun x acc =>
+                     if check_inconsistent x then acc else ((x,tg)::nil)::acc)
+                  (cnf_tt _ _)  l.
+
+Add Ring SORRing : (SORrt sor).
+
+Lemma cnf_of_list_correct :
+  forall (T : Type) env l tg,
+    eval_cnf (Annot:=T) eval_nformula env (cnf_of_list l tg) <->
+    make_conj (fun x : NFormula => eval_nformula env x -> False) l.
+Proof.
+  unfold cnf_of_list.
+  intros T env l tg.
+  set (F := (fun (x : NFormula) (acc : list (list (NFormula * T))) =>
+        if check_inconsistent x then acc else ((x, tg) :: nil) :: acc)).
+  set (G := ((fun x : NFormula => eval_nformula env x -> False))).
+  induction l.
+  - compute.
+    tauto.
+  - rewrite make_conj_cons.
+    simpl.
+    unfold F at 1.
+    destruct (check_inconsistent a) eqn:EQ.
+    + rewrite IHl.
+      unfold G.
+      destruct a.
+      specialize (check_inconsistent_sound _ _ EQ env).
+      simpl.
+      tauto.
+    +
+      rewrite <- eval_cnf_cons_iff.
+      simpl.
+      unfold eval_tt. simpl.
+      rewrite IHl.
+      unfold G at 2.
+      tauto.
+Qed.
+
+Definition cnf_normalise {T: Type} (t: Formula C) (tg: T) : cnf NFormula T :=
+  let f := normalise t in
+  if check_inconsistent f then cnf_ff _ _
+  else cnf_of_list (xnormalise f) tg.
+
+Definition cnf_negate {T: Type} (t: Formula C) (tg: T) : cnf NFormula T :=
+  let f := normalise t in
+  if check_inconsistent f then cnf_tt _ _
+  else cnf_of_list (xnegate f) tg.
+
+Lemma eq0_cnf : forall x,
+    (0 < x -> False) /\ (0 < - x -> False) <-> x == 0.
+Proof.
+  split ; intros.
+  +  apply (SORle_antisymm sor).
+     * now rewrite (Rle_ngt sor).
+     * rewrite (Rle_ngt sor).  rewrite (Rlt_lt_minus sor).
+       setoid_replace (0 - x) with (-x) by ring.
+       tauto.
+  + split; intro.
+      * rewrite (SORlt_le_neq sor) in H0.
+        apply (proj2 H0).
+        now rewrite H.
+      * rewrite (SORlt_le_neq sor) in H0.
+        apply (proj2 H0).
+        rewrite H. ring.
+Qed.
+
+Lemma xnormalise_correct : forall env f,
+    (make_conj (fun x => eval_nformula env x -> False) (xnormalise f)) <-> eval_nformula env f.
+Proof.
+  intros env f.
+  destruct f as [e o]; destruct o eqn:Op; cbn - [psub];
+    repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc;
+      repeat rewrite eval_pol_opp;
+      generalize (eval_pol env e) as x; intro.
+  - apply eq0_cnf.
+  - unfold not. tauto.
+  - symmetry. rewrite (Rlt_nge sor).
+    rewrite (Rle_le_minus sor).
+    setoid_replace (0 - x) with (-x) by ring.
+    tauto.
+  - rewrite (Rle_ngt sor).
+    symmetry.
+    rewrite (Rlt_lt_minus sor).
+    setoid_replace (0 - x) with (-x) by ring.
+    tauto.
+Qed.
+
+
+Lemma xnegate_correct : forall env f,
+    (make_conj (fun x => eval_nformula env x -> False) (xnegate f)) <-> ~ eval_nformula env f.
+Proof.
+  intros env f.
+  destruct f as [e o]; destruct o eqn:Op; cbn - [psub];
+    repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc;
+      repeat rewrite eval_pol_opp;
+      generalize (eval_pol env e) as x; intro.
+  - tauto.
+  - rewrite eq0_cnf.
+    rewrite (Req_dne sor).
+    tauto.
+  - tauto.
+  - tauto.
+Qed.
+
+
+Lemma cnf_normalise_correct : forall (T : Type) env t tg, eval_cnf (Annot:=T) eval_nformula env (cnf_normalise t tg) <-> eval_formula env t.
+Proof.
+  intros T env t tg.
+  unfold cnf_normalise.
+  rewrite normalise_sound.
+  generalize (normalise t) as f;intro.
+  destruct (check_inconsistent f) eqn:U.
+  - destruct f as [e op].
+    assert (US := check_inconsistent_sound _ _ U env).
+    rewrite eval_cnf_ff.
+    tauto.
+  - intros. rewrite cnf_of_list_correct.
+    now apply xnormalise_correct.
+Qed.
+
+Lemma cnf_negate_correct : forall (T : Type) env t (tg:T), eval_cnf eval_nformula env (cnf_negate t tg) <-> ~ eval_formula env t.
+Proof.
+  intros T env t tg.
+  rewrite normalise_sound.
+  unfold cnf_negate.
+  generalize (normalise t) as f;intro.
+  destruct (check_inconsistent f) eqn:U.
+  -
+    destruct f as [e o].
+    assert (US := check_inconsistent_sound _  _ U env).
+    rewrite eval_cnf_tt.
+    tauto.
+  - rewrite cnf_of_list_correct.
+    apply xnegate_correct.
+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  (Pos.add j jmp ) p
+    | PX p j q   => PEadd
+      (PEmul (xdenorm jmp p) (PEpow (PEX jmp) (Npos j)))
+      (xdenorm (Pos.succ jmp) q)
+  end.
+
+Lemma xdenorm_correct : forall p i env,
+  eval_pol (jump i env) p == eval_pexpr env (xdenorm (Pos.succ i) p).
+Proof.
+  unfold eval_pol.
+  induction p.
+  simpl. reflexivity.
+  (* Pinj *)
+  simpl.
+  intros.
+  rewrite Pos.add_succ_r.
+  rewrite <- IHp.
+  symmetry.
+  rewrite Pos.add_comm.
+  rewrite Pjump_add. reflexivity.
+  (* PX *)
+  simpl.
+  intros.
+  rewrite <- IHp1, <- IHp2.
+  unfold Env.tail , Env.hd.
+  rewrite <- Pjump_add.
+  rewrite Pos.add_1_r.
+  unfold Env.nth.
+  unfold jump at 2.
+  rewrite <- Pos.add_1_l.
+  rewrite (rpow_pow_N (SORpower addon)).
+  unfold pow_N. ring.
+Qed.
+
+Definition denorm := xdenorm xH.
+
+Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p).
+Proof.
+  unfold denorm.
+  induction p.
+  reflexivity.
+  simpl.
+  rewrite Pos.add_1_r.
+  apply xdenorm_correct.
+  simpl.
+  intros.
+  rewrite IHp1.
+  unfold Env.tail.
+  rewrite xdenorm_correct.
+  change (Pos.succ xH) with 2%positive.
+  rewrite (rpow_pow_N (SORpower addon)).
+  simpl. reflexivity.
+Qed.
+
+
+(** Sometimes it is convenient to make a distinction between "syntactic" coefficients and "real"
+coefficients that are used to actually compute *)
+
+
+
+Variable S : Type.
+
+Variable C_of_S : S -> C.
+
+Variable phiS : S -> R.
+
+Variable phi_C_of_S :   forall c,  phiS c =  phi (C_of_S c).
+
+Fixpoint map_PExpr (e : PExpr S) : PExpr C :=
+  match e with
+    | PEc c => PEc (C_of_S c)
+    | PEX p => PEX p
+    | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2)
+    | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2)
+    | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2)
+    | PEopp e     => PEopp (map_PExpr e)
+    | PEpow e n   => PEpow (map_PExpr e) n
+  end.
+
+Definition map_Formula (f : Formula S)  : Formula C :=
+  let (l,o,r) := f in
+    Build_Formula (map_PExpr l) o (map_PExpr r).
+
+
+Definition eval_sexpr : PolEnv -> PExpr S -> R :=
+  PEeval rplus rtimes rminus ropp phiS pow_phi rpow.
+
+Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop :=
+  let (lhs, op, rhs) := f in
+    (eval_op2 op) (eval_sexpr env lhs) (eval_sexpr env rhs).
+
+Lemma eval_pexprSC : forall env s, eval_sexpr env s = eval_pexpr env (map_PExpr s).
+Proof.
+  unfold eval_pexpr, eval_sexpr.
+  induction s ; simpl ; try (rewrite IHs1 ; rewrite IHs2) ; try reflexivity.
+  apply phi_C_of_S.
+  rewrite IHs. reflexivity.
+  rewrite IHs. reflexivity.
+Qed.
+
+(** equality might be (too) strong *)
+Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (map_Formula f).
+Proof.
+  destruct f.
+  simpl.
+  repeat rewrite eval_pexprSC.
+  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: *)
diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v
new file mode 100644
index 0000000000..a155207e2e
--- /dev/null
+++ b/theories/micromega/Tauto.v
@@ -0,0 +1,1390 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-20019                            *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import List.
+Require Import Refl.
+Require Import Bool.
+
+Set Implicit Arguments.
+
+
+Section S.
+  Context {TA  : Type}. (* type of interpreted atoms *)
+  Context {TX  : Type}. (* type of uninterpreted terms (Prop) *)
+  Context {AA  : Type}. (* type of annotations for atoms *)
+  Context {AF  : Type}. (* type of formulae identifiers *)
+
+   Inductive GFormula  : Type :=
+  | TT   : GFormula
+  | FF   : GFormula
+  | X    : TX -> GFormula
+  | A    : TA -> AA -> GFormula
+  | Cj   : GFormula  -> GFormula  -> GFormula
+  | D    : GFormula  -> GFormula  -> GFormula
+  | N    : GFormula  -> GFormula
+  | I    : GFormula  -> option AF -> GFormula  -> GFormula.
+
+  Section MAPX.
+    Variable F : TX -> TX.
+
+    Fixpoint mapX (f : GFormula) : GFormula :=
+      match f with
+      | TT => TT
+      | FF => FF
+      | X x => X (F x)
+      | A a an => A a an
+      | Cj f1 f2 => Cj (mapX f1) (mapX f2)
+      | D f1 f2  => D (mapX f1) (mapX f2)
+      | N f      => N (mapX f)
+      | I f1 o f2 => I (mapX f1) o (mapX f2)
+      end.
+
+  End MAPX.
+
+  Section FOLDANNOT.
+    Variable ACC : Type.
+    Variable F : ACC -> AA -> ACC.
+
+    Fixpoint foldA (f : GFormula) (acc : ACC) : ACC :=
+      match f with
+      | TT => acc
+      | FF => acc
+      | X x => acc
+      | A a an => F acc an
+      | Cj f1 f2
+      | D f1 f2
+      | I f1 _ f2 => foldA f1 (foldA f2 acc)
+      | N f      => foldA f acc
+      end.
+
+  End FOLDANNOT.
+
+
+  Definition cons_id (id : option AF) (l : list AF) :=
+    match id with
+    | None => l
+    | Some id => id :: l
+    end.
+
+  Fixpoint ids_of_formula f :=
+    match f with
+    | I f id f' => cons_id id (ids_of_formula f')
+    |  _           => nil
+    end.
+
+  Fixpoint collect_annot (f : GFormula) : list AA :=
+    match f with
+    | TT | FF | X _ => nil
+    | A _ a => a ::nil
+    | Cj f1 f2
+    | D  f1 f2
+    | I f1 _ f2  => collect_annot f1 ++ collect_annot f2
+    | N  f       => collect_annot f
+    end.
+
+  Variable ex : TX -> Prop. (* [ex] will be the identity *)
+
+  Section EVAL.
+
+  Variable ea : TA -> Prop.
+
+  Fixpoint eval_f (f:GFormula) {struct f}: Prop :=
+  match f with
+  | TT  => True
+  | FF  => False
+  | A a _ =>  ea a
+  | X  p => ex p
+  | Cj e1 e2 => (eval_f e1) /\ (eval_f e2)
+  | D e1 e2  => (eval_f e1) \/ (eval_f e2)
+  | N e     => ~ (eval_f e)
+  | I f1 _ f2 => (eval_f f1) -> (eval_f f2)
+  end.
+
+
+  End EVAL.
+
+
+
+
+
+  Lemma eval_f_morph :
+    forall  (ev ev' : TA -> Prop) (f : GFormula),
+      (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f).
+  Proof.
+    induction f ; simpl ; try tauto.
+    intros.
+    apply H.
+  Qed.
+
+
+End S.
+
+
+
+(** Typical boolean formulae *)
+Definition BFormula (A : Type) := @GFormula A Prop unit unit.
+
+Section MAPATOMS.
+  Context {TA TA':Type}.
+  Context {TX  : Type}.
+  Context {AA  : Type}.
+  Context {AF  : Type}.
+
+
+Fixpoint map_bformula (fct : TA -> TA') (f : @GFormula TA TX AA AF ) : @GFormula TA' TX AA AF :=
+  match f with
+  | TT  => TT
+  | FF  => FF
+  | X p => X  p
+  | A a t => A (fct a) t
+  | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2)
+  | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2)
+  | N f     => N (map_bformula fct f)
+  | I f1 a f2 => I (map_bformula fct f1) a (map_bformula fct f2)
+  end.
+
+End MAPATOMS.
+
+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.
+  (** A cnf tracking annotations of atoms. *)
+
+  (** Type parameters *)
+  Variable Env   : Type.
+  Variable Term  : Type.
+  Variable Term' : Type.
+  Variable Annot : Type.
+
+  Variable unsat : Term'  -> bool. (* see [unsat_prop] *)
+  Variable deduce : Term' -> Term' -> option Term'. (* see [deduce_prop] *)
+
+  Definition clause := list  (Term' * Annot).
+  Definition cnf := list clause.
+
+  Variable normalise : Term -> Annot -> cnf.
+  Variable negate : Term -> Annot -> cnf.
+
+
+  Definition cnf_tt : cnf := @nil clause.
+  Definition cnf_ff : cnf :=  cons (@nil (Term' * Annot)) nil.
+
+  (** Our cnf is optimised and detects contradictions on the fly. *)
+
+  Fixpoint add_term (t: Term' * Annot) (cl : clause) : option clause :=
+      match cl with
+      | nil =>
+        match deduce (fst t) (fst t) with
+        | None =>  Some (t ::nil)
+        | Some u => if unsat u then None else Some (t::nil)
+        end
+      | t'::cl =>
+        match deduce (fst t) (fst t') with
+        | None =>
+          match add_term t cl with
+          | None => None
+          | Some cl' => Some (t' :: cl')
+          end
+        | Some u =>
+          if unsat u then None else
+            match add_term t cl with
+            | None => None
+            | Some cl' => Some (t' :: cl')
+            end
+        end
+      end.
+
+    Fixpoint or_clause (cl1 cl2 : clause) : option clause :=
+      match cl1 with
+      | nil => Some cl2
+      | t::cl => match add_term t cl2 with
+               | None => None
+               | Some cl' => or_clause cl cl'
+                 end
+      end.
+
+    Definition xor_clause_cnf (t:clause) (f:cnf) : cnf :=
+      List.fold_left (fun acc e =>
+                         match or_clause t e with
+                         | None => acc
+                         | Some cl => cl :: acc
+                         end) f nil .
+
+    Definition or_clause_cnf (t: clause) (f:cnf) : cnf :=
+      match t with
+      | nil => f
+      | _   => xor_clause_cnf t f
+      end.
+
+
+    Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf :=
+      match f with
+      | nil => cnf_tt
+      | e :: rst => (or_cnf rst f') +++ (or_clause_cnf e f')
+      end.
+
+
+    Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf :=
+      f1 +++ f2.
+
+    (** TX is Prop in Coq and EConstr.constr in Ocaml.
+      AF i s unit in Coq and Names.Id.t in Ocaml
+     *)
+    Definition TFormula (TX: Type) (AF: Type) := @GFormula Term TX Annot AF.
+
+
+    Definition is_cnf_tt (c : cnf) : bool :=
+      match c with
+      | nil => true
+      | _  => false
+      end.
+
+    Definition is_cnf_ff (c : cnf) : bool :=
+      match c with
+      | nil::nil => true
+      | _        => false
+      end.
+
+    Definition and_cnf_opt (f1 : cnf) (f2 : cnf) : cnf :=
+      if is_cnf_ff f1 || is_cnf_ff f2
+      then cnf_ff
+      else and_cnf f1 f2.
+
+    Definition or_cnf_opt (f1 : cnf) (f2 : cnf) : cnf :=
+      if is_cnf_tt f1 || is_cnf_tt f2
+      then cnf_tt
+      else if is_cnf_ff f2
+           then f1 else or_cnf f1 f2.
+
+    Fixpoint xcnf {TX AF: Type} (pol : bool) (f : TFormula TX AF)  {struct f}: cnf :=
+      match f with
+      | TT  => if pol then cnf_tt else cnf_ff
+      | FF  => if pol then cnf_ff else cnf_tt
+      | X  p => if pol then cnf_ff else cnf_ff (* This is not complete - cannot negate any proposition *)
+      | A x t => if pol then normalise x  t else negate x  t
+      | N e  => xcnf (negb pol) e
+      | Cj e1 e2 =>
+        (if pol then and_cnf_opt else or_cnf_opt) (xcnf pol e1) (xcnf pol e2)
+      | D e1 e2  => (if pol then or_cnf_opt else and_cnf_opt) (xcnf pol e1) (xcnf pol e2)
+      | I e1 _ e2
+        =>  (if pol then or_cnf_opt else and_cnf_opt) (xcnf (negb pol) e1) (xcnf pol e2)
+      end.
+
+    Section CNFAnnot.
+
+      (** Records annotations used to optimise the cnf.
+          Those need to be kept when pruning the formula.
+          For efficiency, this is a separate function.
+       *)
+
+      Fixpoint radd_term (t : Term' * Annot) (cl : clause) : clause + list Annot :=
+        match cl with
+        | nil => (* if t is unsat, the clause is empty BUT t is needed. *)
+          match deduce (fst t) (fst t) with
+          | Some u => if unsat u then inr ((snd t)::nil) else inl (t::nil)
+          | None   => inl (t::nil)
+          end
+        | t'::cl => (* if t /\ t' is unsat, the clause is empty BUT t & t' are needed *)
+          match deduce (fst t) (fst t') with
+          | Some u => if unsat u then inr ((snd t)::(snd t')::nil)
+                      else match radd_term t cl with
+                           | inl cl' => inl (t'::cl')
+                           | inr l   => inr l
+                           end
+          | None  => match radd_term t cl  with
+                     | inl cl' => inl (t'::cl')
+                     | inr l   => inr l
+                     end
+          end
+        end.
+
+      Fixpoint ror_clause cl1 cl2 :=
+        match cl1 with
+        | nil => inl cl2
+        | t::cl => match radd_term t cl2 with
+                   | inl cl' => ror_clause cl cl'
+                   | inr l   => inr l
+                   end
+        end.
+
+      Definition xror_clause_cnf t f :=
+        List.fold_left (fun '(acc,tg) e  =>
+                           match ror_clause t e with
+                           | inl cl => (cl :: acc,tg)
+                           | inr l => (acc,tg+++l)
+                           end) f (nil,nil).
+
+      Definition ror_clause_cnf t f :=
+        match t with
+        | nil => (f,nil)
+        | _   => xror_clause_cnf t f
+        end.
+
+
+      Fixpoint ror_cnf (f f':list clause) :=
+        match f with
+        | nil => (cnf_tt,nil)
+        | e :: rst =>
+          let (rst_f',t) := ror_cnf rst f' in
+          let (e_f', t') := ror_clause_cnf e f' in
+          (rst_f' +++ e_f', t +++ t')
+        end.
+
+      Definition annot_of_clause (l : clause) : list Annot :=
+        List.map snd l.
+
+      Definition annot_of_cnf (f : cnf) : list Annot :=
+        List.fold_left (fun acc e => annot_of_clause e +++ acc ) f nil.
+
+
+      Definition ror_cnf_opt f1 f2 :=
+        if is_cnf_tt f1
+        then (cnf_tt ,  nil)
+        else if is_cnf_tt f2
+             then (cnf_tt, nil)
+             else if is_cnf_ff f2
+                  then (f1,nil)
+                  else ror_cnf f1 f2.
+
+
+      Definition ocons {A : Type} (o : option A) (l : list A) : list A :=
+        match o with
+        | None => l
+        | Some e => e ::l
+        end.
+
+      Definition ratom (c : cnf) (a : Annot) : cnf * list Annot :=
+        if is_cnf_ff c || is_cnf_tt c
+        then (c,a::nil)
+        else (c,nil). (* t is embedded in c *)
+
+      Fixpoint rxcnf {TX AF: Type}(polarity : bool) (f : TFormula TX AF) : cnf * list Annot :=
+        match f with
+        | TT => if polarity then (cnf_tt,nil) else (cnf_ff,nil)
+        | FF  => if polarity then (cnf_ff,nil) else (cnf_tt,nil)
+        | X p => if polarity then (cnf_ff,nil) else (cnf_ff,nil)
+        | A x t  => ratom (if polarity then normalise x t else negate x t) t
+        | N e  => rxcnf (negb polarity) e
+        | Cj e1 e2 =>
+          let '(e1,t1) := rxcnf polarity e1 in
+          let '(e2,t2) := rxcnf polarity e2 in
+          if polarity
+          then  (and_cnf_opt e1  e2, t1 +++ t2)
+          else let (f',t') := ror_cnf_opt e1 e2 in
+            (f', t1 +++ t2 +++ t')
+        | D e1 e2  =>
+          let '(e1,t1) := rxcnf polarity e1 in
+          let '(e2,t2) := rxcnf polarity e2 in
+          if polarity
+       then let (f',t') := ror_cnf_opt e1 e2 in
+            (f', t1 +++ t2 +++ t')
+          else (and_cnf_opt e1 e2, t1 +++ t2)
+        | I e1 a e2 =>
+          let '(e1 , t1) := (rxcnf (negb polarity) e1) in
+          if polarity
+          then
+            if is_cnf_ff e1
+            then
+              rxcnf polarity e2
+            else (* compute disjunction *)
+              let '(e2 , t2) := (rxcnf polarity e2) in
+              let (f',t') := ror_cnf_opt e1 e2 in
+              (f', t1 +++ t2 +++ t') (* record the hypothesis *)
+          else
+            let '(e2 , t2) := (rxcnf polarity e2) in
+            (and_cnf_opt e1 e2, t1 +++ t2)
+        end.
+
+
+      Section Abstraction.
+        Variable TX : Type.
+        Variable AF : Type.
+
+        Class to_constrT : Type :=
+          {
+            mkTT : TX;
+            mkFF : TX;
+            mkA  : Term -> Annot -> TX;
+            mkCj : TX -> TX -> TX;
+            mkD  : TX -> TX -> TX;
+            mkI  : TX -> TX -> TX;
+            mkN  : TX -> TX
+          }.
+
+        Context {to_constr : to_constrT}.
+
+        Fixpoint aformula (f : TFormula TX AF) : TX :=
+          match f with
+          | TT => mkTT
+          | FF => mkFF
+          | X p => p
+          | A x t => mkA x t
+          | Cj f1 f2 => mkCj (aformula f1) (aformula f2)
+          | D  f1 f2 => mkD (aformula f1) (aformula f2)
+          | I f1 o f2 => mkI (aformula f1) (aformula f2)
+          | N f       => mkN (aformula f)
+          end.
+
+
+        Definition is_X (f : TFormula TX AF) : option TX :=
+          match f with
+          | X p => Some p
+          | _   => None
+          end.
+
+        Definition is_X_inv : forall f x,
+            is_X f = Some x -> f = X x.
+        Proof.
+          destruct f ; simpl ; congruence.
+        Qed.
+
+
+        Variable needA : Annot -> bool.
+
+        Definition abs_and (f1 f2 : TFormula TX AF)
+                   (c : TFormula TX AF -> TFormula TX AF -> TFormula TX AF) :=
+          match is_X f1 , is_X f2 with
+          | Some _  , _ | _ , Some _ => X (aformula (c f1  f2))
+          |   _     , _ => c f1 f2
+          end.
+
+        Definition abs_or (f1 f2 : TFormula TX AF)
+                   (c : TFormula TX AF -> TFormula TX AF -> TFormula TX AF) :=
+          match is_X f1 , is_X f2 with
+          | Some _  , Some _ => X (aformula (c f1  f2))
+          |   _     , _ => c f1 f2
+          end.
+
+        Definition mk_arrow (o : option AF) (f1 f2: TFormula TX AF) :=
+          match o with
+          | None => I f1 None f2
+          | Some _ => if is_X f1 then f2 else I f1 o f2
+          end.
+
+
+        Fixpoint abst_form  (pol : bool) (f : TFormula TX AF) :=
+          match f with
+          | TT => if pol then TT else X mkTT
+          | FF => if pol then X mkFF else FF
+          | X p => X p
+          | A x t => if needA t then A x t else X (mkA x t)
+          | Cj f1 f2 =>
+            let f1 := abst_form pol f1 in
+            let f2 := abst_form pol f2 in
+            if pol then abs_and f1 f2 Cj
+            else abs_or f1 f2 Cj
+          | D f1 f2 =>
+            let f1 := abst_form pol f1 in
+            let f2 := abst_form pol f2 in
+            if pol then abs_or f1 f2 D
+            else abs_and f1 f2 D
+          | I f1 o f2 =>
+            let f1 := abst_form (negb pol) f1 in
+            let f2 := abst_form pol f2 in
+            if pol
+            then abs_or f1 f2 (mk_arrow o)
+            else abs_and f1 f2 (mk_arrow o)
+          | N f => let f := abst_form (negb pol) f in
+                   match is_X f with
+                   | Some a => X (mkN a)
+                   |  _     => N f
+                   end
+          end.
+
+
+
+
+        Lemma if_same : forall {A: Type} (b:bool) (t:A),
+            (if b then t else t) = t.
+        Proof.
+          destruct b ; reflexivity.
+        Qed.
+
+        Lemma is_cnf_tt_cnf_ff :
+          is_cnf_tt cnf_ff = false.
+        Proof.
+          reflexivity.
+        Qed.
+
+        Lemma is_cnf_ff_cnf_ff :
+          is_cnf_ff cnf_ff = true.
+        Proof.
+          reflexivity.
+        Qed.
+
+
+      Lemma is_cnf_tt_inv : forall f1,
+          is_cnf_tt f1 = true -> f1 = cnf_tt.
+      Proof.
+        unfold cnf_tt.
+        destruct f1 ; simpl ; try congruence.
+      Qed.
+
+      Lemma is_cnf_ff_inv : forall f1,
+          is_cnf_ff f1 = true -> f1 = cnf_ff.
+      Proof.
+        unfold cnf_ff.
+        destruct f1 ; simpl ; try congruence.
+        destruct c ; simpl ; try congruence.
+        destruct f1 ; try congruence.
+        reflexivity.
+      Qed.
+
+
+      Lemma if_cnf_tt : forall f, (if is_cnf_tt f then cnf_tt else f) = f.
+      Proof.
+        intros.
+        destruct (is_cnf_tt f) eqn:EQ.
+        apply is_cnf_tt_inv in EQ;auto.
+        reflexivity.
+      Qed.
+
+      Lemma or_cnf_opt_cnf_ff : forall f,
+          or_cnf_opt cnf_ff f = f.
+      Proof.
+        intros.
+        unfold or_cnf_opt.
+        rewrite is_cnf_tt_cnf_ff.
+        simpl.
+        destruct (is_cnf_tt f) eqn:EQ.
+        apply is_cnf_tt_inv in EQ.
+        congruence.
+        destruct (is_cnf_ff f) eqn:EQ1.
+        apply is_cnf_ff_inv in EQ1.
+        congruence.
+        reflexivity.
+      Qed.
+
+      Lemma abs_and_pol : forall f1 f2 pol,
+          and_cnf_opt (xcnf pol f1) (xcnf pol f2) =
+          xcnf pol (abs_and f1 f2 (if pol then Cj else D)).
+      Proof.
+        unfold abs_and; intros.
+        destruct (is_X f1) eqn:EQ1.
+        apply is_X_inv in EQ1.
+        subst.
+        simpl.
+        rewrite if_same. reflexivity.
+        destruct (is_X f2) eqn:EQ2.
+        apply is_X_inv in EQ2.
+        subst.
+        simpl.
+        rewrite if_same.
+        unfold and_cnf_opt.
+        rewrite orb_comm. reflexivity.
+        destruct pol ; simpl; auto.
+      Qed.
+
+      Lemma abs_or_pol : forall f1 f2 pol,
+          or_cnf_opt (xcnf pol f1) (xcnf pol f2) =
+          xcnf pol (abs_or f1 f2 (if pol then D else Cj)).
+      Proof.
+        unfold abs_or; intros.
+        destruct (is_X f1) eqn:EQ1.
+        apply is_X_inv in EQ1.
+        subst.
+        destruct (is_X f2) eqn:EQ2.
+        apply is_X_inv in EQ2.
+        subst.
+        simpl.
+        rewrite if_same.
+        reflexivity.
+        simpl.
+        rewrite if_same.
+        destruct pol ; simpl; auto.
+        destruct pol ; simpl ; auto.
+      Qed.
+
+      Variable needA_all : forall a, needA a = true.
+
+      Lemma xcnf_true_mk_arrow_l : forall o t f,
+        xcnf true (mk_arrow o (X t) f) = xcnf true f.
+      Proof.
+        destruct o ; simpl; auto.
+        intros. rewrite or_cnf_opt_cnf_ff. reflexivity.
+      Qed.
+
+      Lemma or_cnf_opt_cnf_ff_r : forall f,
+          or_cnf_opt f  cnf_ff = f.
+      Proof.
+        unfold or_cnf_opt.
+        intros.
+        rewrite is_cnf_tt_cnf_ff.
+        rewrite orb_comm.
+        simpl.
+        apply if_cnf_tt.
+      Qed.
+
+      Lemma xcnf_true_mk_arrow_r : forall o t f,
+          xcnf true (mk_arrow o  f (X t)) = xcnf false f.
+      Proof.
+        destruct o ; simpl; auto.
+        - intros.
+          destruct (is_X f) eqn:EQ.
+          apply is_X_inv in EQ. subst. reflexivity.
+          simpl.
+          apply or_cnf_opt_cnf_ff_r.
+        - intros.
+          apply or_cnf_opt_cnf_ff_r.
+      Qed.
+
+
+
+      Lemma abst_form_correct : forall f pol,
+          xcnf pol f = xcnf pol (abst_form pol f).
+      Proof.
+        induction f;intros.
+        - simpl. destruct pol ; reflexivity.
+        - simpl. destruct pol ; reflexivity.
+        - simpl. reflexivity.
+        - simpl. rewrite needA_all.
+          reflexivity.
+        - simpl.
+          specialize (IHf1 pol).
+          specialize (IHf2 pol).
+          rewrite IHf1.
+          rewrite IHf2.
+          destruct pol.
+          +
+            apply abs_and_pol; auto.
+          +
+            apply abs_or_pol; auto.
+        - simpl.
+          specialize (IHf1 pol).
+          specialize (IHf2 pol).
+          rewrite IHf1.
+          rewrite IHf2.
+          destruct pol.
+          +
+            apply abs_or_pol; auto.
+          +
+            apply abs_and_pol; auto.
+        -  simpl.
+           specialize (IHf (negb pol)).
+           destruct (is_X (abst_form (negb pol) f)) eqn:EQ1.
+           + apply is_X_inv in EQ1.
+             rewrite EQ1 in *.
+             simpl in *.
+             destruct pol ; auto.
+           + simpl. congruence.
+        - simpl.
+          specialize (IHf1 (negb pol)).
+          specialize (IHf2 pol).
+          destruct pol.
+            +
+              simpl in *.
+              unfold abs_or.
+              destruct (is_X (abst_form false f1)) eqn:EQ1;
+                destruct (is_X (abst_form true f2)) eqn:EQ2 ; simpl.
+              * apply is_X_inv in EQ1.
+               apply is_X_inv in EQ2.
+               rewrite EQ1 in *.
+               rewrite EQ2 in *.
+               rewrite IHf1. rewrite IHf2.
+               simpl. reflexivity.
+              * apply is_X_inv in EQ1.
+               rewrite EQ1 in *.
+               rewrite IHf1.
+               simpl.
+               rewrite xcnf_true_mk_arrow_l.
+               rewrite or_cnf_opt_cnf_ff.
+               congruence.
+              * apply is_X_inv in EQ2.
+               rewrite EQ2 in *.
+               rewrite IHf2.
+               simpl.
+               rewrite xcnf_true_mk_arrow_r.
+               rewrite or_cnf_opt_cnf_ff_r.
+               congruence.
+              * destruct o ; simpl ; try congruence.
+                rewrite EQ1.
+                simpl. congruence.
+            +  simpl in *.
+               unfold abs_and.
+               destruct (is_X (abst_form true f1)) eqn:EQ1;
+                destruct (is_X (abst_form false f2)) eqn:EQ2 ; simpl.
+              * apply is_X_inv in EQ1.
+               apply is_X_inv in EQ2.
+               rewrite EQ1 in *.
+               rewrite EQ2 in *.
+               rewrite IHf1. rewrite IHf2.
+               simpl. reflexivity.
+              * apply is_X_inv in EQ1.
+               rewrite EQ1 in *.
+               rewrite IHf1.
+               simpl. reflexivity.
+              * apply is_X_inv in EQ2.
+               rewrite EQ2 in *.
+               rewrite IHf2.
+               simpl. unfold and_cnf_opt.
+               rewrite orb_comm. reflexivity.
+              * destruct o; simpl.
+                rewrite EQ1. simpl.
+                congruence.
+                congruence.
+        Qed.
+
+      End Abstraction.
+
+
+      End CNFAnnot.
+
+
+      Lemma radd_term_term : forall a' a cl, radd_term a a' = inl cl -> add_term a a' = Some cl.
+      Proof.
+        induction a' ; simpl.
+        - intros.
+          destruct (deduce (fst a) (fst a)).
+          destruct (unsat t). congruence.
+          inversion H. reflexivity.
+          inversion H ;reflexivity.
+        - intros.
+          destruct (deduce (fst a0) (fst a)).
+          destruct (unsat t). congruence.
+          destruct (radd_term a0 a') eqn:RADD; try congruence.
+          inversion H. subst.
+          apply IHa' in RADD.
+          rewrite RADD.
+          reflexivity.
+          destruct (radd_term a0 a') eqn:RADD; try congruence.
+          inversion H. subst.
+          apply IHa' in RADD.
+          rewrite RADD.
+          reflexivity.
+      Qed.
+
+      Lemma radd_term_term' : forall a' a cl, add_term a a' = Some cl -> radd_term a a' = inl cl.
+      Proof.
+        induction a' ; simpl.
+        - intros.
+          destruct (deduce (fst a) (fst a)).
+          destruct (unsat t). congruence.
+          inversion H. reflexivity.
+          inversion H ;reflexivity.
+        - intros.
+          destruct (deduce (fst a0) (fst a)).
+          destruct (unsat t). congruence.
+          destruct (add_term a0 a') eqn:RADD; try congruence.
+          inversion H. subst.
+          apply IHa' in RADD.
+          rewrite RADD.
+          reflexivity.
+          destruct (add_term a0 a') eqn:RADD; try congruence.
+          inversion H. subst.
+          apply IHa' in RADD.
+          rewrite RADD.
+          reflexivity.
+      Qed.
+
+      Lemma xror_clause_clause : forall a f,
+          fst (xror_clause_cnf a f) = xor_clause_cnf a f.
+      Proof.
+        unfold xror_clause_cnf.
+        unfold xor_clause_cnf.
+        assert (ACC: fst (@nil clause,@nil Annot) = nil).
+        reflexivity.
+        intros.
+        set (F1:= (fun '(acc, tg) (e : clause) =>
+        match ror_clause a e with
+        | inl cl => (cl :: acc, tg)
+        | inr l => (acc, tg +++ l)
+        end)).
+        set (F2:= (fun (acc : list clause) (e : clause) =>
+     match or_clause a e with
+     | Some cl => cl :: acc
+     | None => acc
+     end)).
+        revert ACC.
+        generalize (@nil clause,@nil Annot).
+        generalize (@nil clause).
+        induction f ; simpl ; auto.
+        intros.
+        apply IHf.
+        unfold F1 , F2.
+        destruct p ; simpl in * ; subst.
+        clear.
+        revert a0.
+        induction a; simpl; auto.
+        intros.
+        destruct (radd_term a a1) eqn:RADD.
+        apply radd_term_term in RADD.
+        rewrite RADD.
+        auto.
+        destruct (add_term a a1) eqn:RADD'.
+        apply radd_term_term' in RADD'.
+        congruence.
+        reflexivity.
+      Qed.
+
+      Lemma ror_clause_clause : forall a f,
+          fst (ror_clause_cnf a f) = or_clause_cnf a f.
+      Proof.
+        unfold ror_clause_cnf,or_clause_cnf.
+        destruct a ; auto.
+        apply xror_clause_clause.
+      Qed.
+
+      Lemma ror_cnf_cnf : forall f1 f2, fst (ror_cnf f1 f2) = or_cnf f1 f2.
+      Proof.
+        induction f1 ; simpl ; auto.
+        intros.
+        specialize (IHf1  f2).
+        destruct(ror_cnf f1 f2).
+        rewrite <- ror_clause_clause.
+        destruct(ror_clause_cnf a f2).
+        simpl.
+        rewrite <- IHf1.
+        reflexivity.
+      Qed.
+
+      Lemma ror_opt_cnf_cnf : forall f1 f2, fst (ror_cnf_opt f1 f2) = or_cnf_opt f1 f2.
+      Proof.
+        unfold ror_cnf_opt, or_cnf_opt.
+        intros.
+        destruct (is_cnf_tt f1).
+        - simpl ; auto.
+        - simpl. destruct (is_cnf_tt f2) ; simpl ; auto.
+          destruct (is_cnf_ff f2) eqn:EQ.
+          reflexivity.
+          apply ror_cnf_cnf.
+      Qed.
+
+      Lemma ratom_cnf : forall  f a,
+          fst (ratom f a) = f.
+      Proof.
+        unfold ratom.
+        intros.
+        destruct (is_cnf_ff f || is_cnf_tt f); auto.
+      Qed.
+
+
+
+      Lemma rxcnf_xcnf : forall {TX AF:Type} (f:TFormula TX AF) b,
+        fst (rxcnf  b f) = xcnf b f.
+      Proof.
+        induction f ; simpl ; auto.
+        - destruct b; simpl ; auto.
+        - destruct b; simpl ; auto.
+        - destruct b ; simpl ; auto.
+        - intros. rewrite ratom_cnf. reflexivity.
+        - intros.
+          specialize (IHf1 b).
+          specialize (IHf2 b).
+          destruct (rxcnf b f1).
+          destruct (rxcnf b f2).
+          simpl in *.
+          subst. destruct b ; auto.
+          rewrite <- ror_opt_cnf_cnf.
+          destruct (ror_cnf_opt (xcnf false f1) (xcnf false f2)).
+          reflexivity.
+        - intros.
+          specialize (IHf1 b).
+          specialize (IHf2 b).
+          rewrite <- IHf1.
+          rewrite <- IHf2.
+          destruct (rxcnf b f1).
+          destruct (rxcnf b f2).
+          simpl in *.
+          subst. destruct b ; auto.
+          rewrite <- ror_opt_cnf_cnf.
+          destruct (ror_cnf_opt (xcnf true f1) (xcnf true f2)).
+          reflexivity.
+        - intros.
+          specialize (IHf1 (negb b)).
+          specialize (IHf2 b).
+          rewrite <- IHf1.
+          rewrite <- IHf2.
+          destruct (rxcnf (negb b) f1).
+          destruct (rxcnf b f2).
+          simpl in *.
+          subst.
+          destruct b;auto.
+          generalize (is_cnf_ff_inv (xcnf (negb true) f1)).
+          destruct (is_cnf_ff (xcnf (negb true) f1)).
+          + intros.
+            rewrite H by auto.
+            unfold or_cnf_opt.
+            simpl.
+            destruct (is_cnf_tt (xcnf true f2)) eqn:EQ;auto.
+            apply is_cnf_tt_inv in EQ; auto.
+            destruct (is_cnf_ff (xcnf true f2)) eqn:EQ1.
+            apply is_cnf_ff_inv in EQ1. congruence.
+            reflexivity.
+          +
+            rewrite <- ror_opt_cnf_cnf.
+            destruct (ror_cnf_opt (xcnf (negb true) f1) (xcnf true f2)).
+            intros.
+            reflexivity.
+      Qed.
+
+
+    Variable eval'  : Env -> Term' -> Prop.
+
+    Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d).
+
+
+    Variable unsat_prop : forall t, unsat t  = true ->
+                                    forall env, eval' env t -> False.
+
+
+
+    Variable deduce_prop : forall t t' u,
+        deduce t t' = Some u -> forall env,
+        eval' env t -> eval' env t' -> eval' env u.
+
+
+
+    Definition eval_tt (env : Env) (tt : Term' * Annot) := eval' env (fst tt).
+
+
+    Definition eval_clause (env : Env) (cl : clause) := ~ make_conj  (eval_tt env) cl.
+
+    Definition eval_cnf (env : Env) (f:cnf) := make_conj  (eval_clause  env) f.
+
+
+    Lemma eval_cnf_app : forall env x y, eval_cnf env (x+++y) <-> eval_cnf env x /\ eval_cnf env y.
+    Proof.
+      unfold eval_cnf.
+      intros.
+      rewrite make_conj_rapp.
+      rewrite make_conj_app ; auto.
+      tauto.
+    Qed.
+
+
+    Lemma eval_cnf_ff : forall env, eval_cnf env cnf_ff <-> False.
+    Proof.
+      unfold cnf_ff, eval_cnf,eval_clause.
+      simpl. tauto.
+    Qed.
+
+    Lemma eval_cnf_tt : forall env, eval_cnf env cnf_tt <-> True.
+    Proof.
+      unfold cnf_tt, eval_cnf,eval_clause.
+      simpl. tauto.
+    Qed.
+
+
+    Lemma eval_cnf_and_opt : forall env x y, eval_cnf env (and_cnf_opt x y) <-> eval_cnf env (and_cnf x y).
+    Proof.
+      unfold and_cnf_opt.
+      intros.
+      destruct (is_cnf_ff x) eqn:F1.
+      { apply is_cnf_ff_inv in F1.
+        simpl. subst.
+        unfold and_cnf.
+        rewrite eval_cnf_app.
+        rewrite eval_cnf_ff.
+        tauto.
+      }
+      simpl.
+      destruct (is_cnf_ff y) eqn:F2.
+      { apply is_cnf_ff_inv in F2.
+        simpl. subst.
+        unfold and_cnf.
+        rewrite eval_cnf_app.
+        rewrite eval_cnf_ff.
+        tauto.
+      }
+      tauto.
+    Qed.
+
+
+
+    Definition eval_opt_clause (env : Env) (cl: option clause) :=
+      match cl with
+      | None => True
+      | Some cl => eval_clause env cl
+      end.
+
+
+  Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) <-> eval_clause env (t::cl).
+  Proof.
+    induction cl.
+    - (* BC *)
+    simpl.
+    case_eq (deduce (fst t) (fst t)) ; try tauto.
+    intros.
+    generalize (@deduce_prop _ _ _ H env).
+    case_eq (unsat t0) ; try tauto.
+    { intros.
+      generalize (@unsat_prop _ H0 env).
+      unfold eval_clause.
+      rewrite make_conj_cons.
+      simpl; intros.
+      tauto.
+    }
+    - (* IC *)
+    simpl.
+    case_eq (deduce (fst t) (fst a));
+    intros.
+    generalize (@deduce_prop _ _ _ H env).
+    case_eq (unsat t0); intros.
+    {
+      generalize (@unsat_prop _ H0 env).
+      simpl.
+      unfold eval_clause.
+      repeat rewrite make_conj_cons.
+      tauto.
+    }
+    destruct (add_term t cl) ; simpl in * ; try tauto.
+    {
+      intros.
+      unfold eval_clause in *.
+      repeat rewrite make_conj_cons in *.
+      tauto.
+    }
+    {
+      unfold eval_clause in *.
+      repeat rewrite make_conj_cons in *.
+      tauto.
+    }
+    destruct (add_term t cl) ; simpl in *;
+      unfold eval_clause in * ;
+      repeat rewrite make_conj_cons in *; tauto.
+  Qed.
+
+
+  Lemma no_middle_eval_tt : forall env a,
+      eval_tt env a \/ ~ eval_tt env a.
+  Proof.
+    unfold eval_tt.
+    auto.
+  Qed.
+
+  Hint Resolve no_middle_eval_tt : tauto.
+
+  Lemma or_clause_correct : forall cl cl' env,  eval_opt_clause env (or_clause cl cl') <-> eval_clause env cl \/ eval_clause env cl'.
+  Proof.
+    induction cl.
+    - simpl. unfold eval_clause at 2.  simpl. tauto.
+    - intros *.
+      simpl.
+      assert (HH := add_term_correct env a cl').
+      assert (eval_tt env a \/ ~ eval_tt env a) by (apply no_middle_eval').
+      destruct (add_term a cl'); simpl in *.
+      +
+      rewrite IHcl.
+      unfold eval_clause in *.
+      rewrite !make_conj_cons in *.
+      tauto.
+      + unfold eval_clause in *.
+        repeat rewrite make_conj_cons in *.
+        tauto.
+  Qed.
+
+
+  Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) <-> (eval_clause env t) \/ (eval_cnf env f).
+  Proof.
+    unfold eval_cnf.
+    unfold or_clause_cnf.
+    intros until t.
+    set (F := (fun (acc : list clause) (e : clause)  =>
+                 match or_clause t e with
+                 | Some cl => cl :: acc
+                 | None => acc
+                 end)).
+    intro f.
+    assert (  make_conj (eval_clause env) (fold_left F f nil) <-> (eval_clause env t \/ make_conj (eval_clause env) f) /\ make_conj (eval_clause env) nil).
+    {
+      generalize (@nil clause) as acc.
+      induction f.
+      - simpl.
+        intros ; tauto.
+      - intros.
+        simpl fold_left.
+        rewrite IHf.
+        rewrite make_conj_cons.
+        unfold F in *; clear F.
+        generalize (or_clause_correct t a env).
+        destruct (or_clause t a).
+        +
+        rewrite make_conj_cons.
+        simpl. tauto.
+        + simpl. tauto.
+    }
+    destruct t ; auto.
+    - unfold eval_clause ; simpl. tauto.
+    - unfold xor_clause_cnf.
+      unfold F in H.
+      rewrite H.
+      unfold make_conj at 2. tauto.
+  Qed.
+
+
+  Lemma eval_cnf_cons : forall env a f,  (~ make_conj  (eval_tt env) a  /\ eval_cnf env f) <-> eval_cnf env (a::f).
+  Proof.
+    intros.
+    unfold eval_cnf in *.
+    rewrite make_conj_cons ; eauto.
+    unfold eval_clause at 2.
+    tauto.
+  Qed.
+
+  Lemma eval_cnf_cons_iff : forall env a f,  ((~ make_conj  (eval_tt env) a) /\ eval_cnf env f) <-> eval_cnf env (a::f).
+  Proof.
+    intros.
+    unfold eval_cnf in *.
+    rewrite make_conj_cons ; eauto.
+    unfold eval_clause.
+    tauto.
+  Qed.
+
+
+  Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') <-> (eval_cnf env  f) \/ (eval_cnf  env f').
+  Proof.
+    induction f.
+    unfold eval_cnf.
+    simpl.
+    tauto.
+    (**)
+    intros.
+    simpl.
+    rewrite eval_cnf_app.
+    rewrite <- eval_cnf_cons_iff.
+    rewrite IHf.
+    rewrite or_clause_cnf_correct.
+    unfold eval_clause.
+    tauto.
+  Qed.
+
+  Lemma or_cnf_opt_correct : forall env f f', eval_cnf env (or_cnf_opt f f') <-> eval_cnf env (or_cnf f f').
+  Proof.
+    unfold or_cnf_opt.
+    intros.
+    destruct (is_cnf_tt f) eqn:TF.
+    { simpl.
+      apply is_cnf_tt_inv in TF.
+      subst.
+      rewrite or_cnf_correct.
+      rewrite eval_cnf_tt.
+      tauto.
+    }
+    destruct (is_cnf_tt f') eqn:TF'.
+    { simpl.
+      apply is_cnf_tt_inv in TF'.
+      subst.
+      rewrite or_cnf_correct.
+      rewrite eval_cnf_tt.
+      tauto.
+    }
+    { simpl.
+      destruct (is_cnf_ff f') eqn:EQ.
+      apply is_cnf_ff_inv in EQ.
+      subst.
+      rewrite or_cnf_correct.
+      rewrite eval_cnf_ff.
+      tauto.
+      tauto.
+    }
+  Qed.
+
+
+  Variable eval  : Env -> Term -> Prop.
+
+  Variable normalise_correct : forall env t tg, eval_cnf  env (normalise t tg) -> eval env t.
+
+  Variable negate_correct : forall env t tg, eval_cnf env (negate t tg) -> ~ eval env t.
+
+  Lemma xcnf_correct : forall (f : @GFormula Term Prop Annot unit)  pol env, eval_cnf env (xcnf pol f) -> eval_f (fun x => x) (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.
+    unfold eval_clause ; simpl.
+    tauto.
+    - (* P *)
+    simpl.
+    destruct pol ; intros ;simpl.
+    unfold eval_cnf in H.
+    (* Here I have to drop the proposition *)
+    simpl in H.
+    unfold eval_clause in H ; simpl in H.
+    tauto.
+    (* Here, I could store P in the clause *)
+    unfold eval_cnf in H;simpl in H.
+    unfold eval_clause in H ; simpl in H.
+    tauto.
+    - (* A *)
+    simpl.
+    destruct pol ; simpl.
+    intros.
+    eapply normalise_correct  ; eauto.
+    (* A 2 *)
+    intros.
+    eapply  negate_correct ; eauto.
+    - (* Cj *)
+    destruct pol ; simpl.
+    + (* pol = true *)
+    intros.
+    rewrite eval_cnf_and_opt in H.
+    unfold and_cnf in H.
+    rewrite eval_cnf_app  in H.
+    destruct H.
+    split.
+    apply (IHf1 _ _ H).
+    apply (IHf2 _ _ H0).
+    +  (* pol = false *)
+    intros.
+    rewrite or_cnf_opt_correct in H.
+    rewrite or_cnf_correct in H.
+    destruct H as [H | H].
+    generalize (IHf1 false  env H).
+    simpl.
+    tauto.
+    generalize (IHf2 false  env H).
+    simpl.
+    tauto.
+    - (* D *)
+    simpl.
+    destruct pol.
+    + (* pol = true *)
+    intros.
+    rewrite or_cnf_opt_correct in H.
+    rewrite or_cnf_correct in H.
+    destruct H as [H | H].
+    generalize (IHf1 _  env H).
+    simpl.
+    tauto.
+    generalize (IHf2 _  env H).
+    simpl.
+    tauto.
+    + (* pol = true *)
+    intros.
+    rewrite eval_cnf_and_opt in H.
+    unfold and_cnf.
+    rewrite eval_cnf_app in H.
+    destruct H as [H0 H1].
+    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.
+    rewrite or_cnf_opt_correct in H.
+    rewrite or_cnf_correct in H.
+    destruct H as [H | H].
+    generalize (IHf1 _ _ H).
+    simpl in *.
+    tauto.
+    generalize (IHf2 _ _ H).
+    auto.
+    + (* pol = false *)
+      rewrite eval_cnf_and_opt in H.
+      unfold and_cnf in H.
+      simpl in H.
+      rewrite eval_cnf_app in H.
+      destruct H as [H0 H1].
+      generalize (IHf1 _ _ H0).
+      generalize (IHf2 _ _ H1).
+      simpl.
+      tauto.
+  Qed.
+
+
+  Variable Witness : Type.
+  Variable checker : list (Term'*Annot) -> Witness -> bool.
+
+  Variable checker_sound : forall t  w, checker t w = true -> forall env, make_impl (eval_tt 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  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:@GFormula Term Prop Annot unit) (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 (fun x => x) (eval env)  t.
+  Proof.
+    unfold tauto_checker.
+    intros.
+    change (eval_f (fun x => x) (eval env) t) with (eval_f (fun x => x) (eval env) (if true then t else TT)).
+    apply (xcnf_correct t true).
+    eapply cnf_checker_sound ; eauto.
+  Qed.
+
+  Definition eval_bf {A : Type} (ea : A -> Prop) (f: BFormula A) := eval_f (fun x => x) ea f.
+
+
+  Lemma eval_bf_map : forall T U (fct: T-> U) env f ,
+    eval_bf env  (map_bformula fct f)  = eval_bf (fun x => env (fct x)) f.
+Proof.
+  induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto.
+  rewrite <- IHf.  auto.
+Qed.
+
+
+End S.
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/theories/micromega/VarMap.v b/theories/micromega/VarMap.v
new file mode 100644
index 0000000000..6db62e8401
--- /dev/null
+++ b/theories/micromega/VarMap.v
@@ -0,0 +1,79 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import ZArith_base.
+Require Import Coq.Arith.Max.
+Require Import List.
+Set Implicit Arguments.
+
+(* 
+ * This adds a Leaf constructor to the varmap data structure (plugins/quote/Quote.v)
+ * --- it is harmless and spares a lot of Empty.
+ * It also means smaller proof-terms.
+ * As a side note, by dropping the polymorphism, one gets small, yet noticeable, speed-up.
+ *)
+
+Inductive t {A} : Type :=
+| Empty : t
+| Elt : A -> t
+| Branch : t  -> A -> t  -> t .
+Arguments t : clear implicits.
+
+Section MakeVarMap.
+  
+  Variable A : Type.
+  Variable default : A.
+
+  Notation t := (t A).
+
+  Fixpoint find (vm : t) (p:positive) {struct vm} : A :=
+    match vm with
+      | Empty => default
+      | Elt i => i
+      | Branch l e r => match p with
+                        | xH => e
+                        | xO p => find l p
+                        | xI p => find r p
+                      end
+    end.
+
+  Fixpoint singleton (x:positive) (v : A) : t :=
+    match x with
+    | xH => Elt v
+    | xO p => Branch (singleton p v) default Empty
+    | xI p => Branch Empty default (singleton p v)
+    end.
+  
+  Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t :=
+    match m with
+    | Empty   => singleton x v
+    | Elt vl =>
+      match x with
+      | xH => Elt v
+      | xO p => Branch (singleton p v) vl Empty
+      | xI p => Branch Empty vl (singleton p v)
+      end
+    | Branch l o r =>
+      match x with
+      | xH => Branch l v r
+      | xI p => Branch l o (vm_add p v r)
+      | xO p => Branch (vm_add p v l) o r
+      end
+    end.
+
+  
+End MakeVarMap.  
diff --git a/theories/micromega/ZCoeff.v b/theories/micromega/ZCoeff.v
new file mode 100644
index 0000000000..08f3f39204
--- /dev/null
+++ b/theories/micromega/ZCoeff.v
@@ -0,0 +1,175 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                      Evgeny Makarov, INRIA, 2007                     *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import ZArith_base.
+Require Import InitialRing.
+Require Import Setoid.
+Require Import ZArithRing.
+
+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 (SORsetoid sor) as (Equivalence_Reflexive,_,_).
+  apply Equivalence_Reflexive.
+Qed.
+
+Lemma req_sym : forall x y, req x y -> req y x.
+Proof.
+  destruct (SORsetoid sor) as (_,Equivalence_Symmetric,_).
+  apply Equivalence_Symmetric.
+Qed.
+
+Lemma req_trans : forall x y z, req x y -> req y z -> req x z.
+Proof.
+  destruct (SORsetoid sor) as (_,_,Equivalence_Transitive).
+  apply Equivalence_Transitive.
+Qed.
+
+
+Add Relation R req
+  reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor))
+  symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor))
+  transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor))
+as sor_setoid.
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact (SORplus_wd sor).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact (SORtimes_wd sor).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact (SORopp_wd sor).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+exact (SORle_wd sor).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+exact (SORlt_wd sor).
+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.
+Declare Equivalent Keys gen_order_phi_Z gen_phiZ.
+
+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 Z.add Z.mul Z.sub Z.opp
+             Zeq_bool gen_order_phi_Z.
+Proof.
+exact (gen_phiZ_morph (SORsetoid sor) ring_ops_wd (SORrt sor)).
+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 (Pos.succ x) == 1 + phi_pos1 x.
+Proof.
+exact (ARgen_phiPOS_Psucc (SORsetoid sor) ring_ops_wd
+        (Rth_ARth (SORsetoid sor) ring_ops_wd (SORrt sor))).
+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 Pos.lt_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.
+intros x y H.
+do 2 rewrite (same_genZ (SORsetoid sor) ring_ops_wd (SORrt sor));
+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.
+apply -> (Ropp_lt_mono sor); apply clt_pos_morph.
+red. now rewrite Pos.compare_antisym.
+Qed.
+
+Lemma Zcleb_morph : forall x y : Z, Z.leb x y = true -> [x] <= [y].
+Proof.
+unfold Z.leb; intros x y H.
+case_eq (x ?= y)%Z; intro H1; rewrite H1 in H.
+le_equal. apply (morph_eq Zring_morph). 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 (Z.compare 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 Z.gt_lt_iff in H1.
+apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph.
+Qed.
+
+End InitialMorphism.
diff --git a/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v
new file mode 100644
index 0000000000..9bedb47371
--- /dev/null
+++ b/theories/micromega/ZMicromega.v
@@ -0,0 +1,1743 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2011                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import List.
+Require Import Bool.
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import ZCoeff.
+Require Import Refl.
+Require Import ZArith_base.
+Require Import ZArithRing.
+Require Import Ztac.
+Require PreOmega.
+(*Declare ML Module "micromega_plugin".*)
+Local Open Scope Z_scope.
+
+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.
+
+Lemma eq_le_iff : forall x, 0 = x  <-> (0 <= x /\ x <= 0).
+Proof.
+  intros.
+  split ; intros.
+  - subst.
+    compute. intuition congruence.
+  - destruct H.
+    apply Z.le_antisymm; auto.
+Qed.
+
+Lemma lt_le_iff : forall x,
+    0 < x <-> 0 <= x - 1.
+Proof.
+  split ; intros.
+  - apply Zlt_succ_le.
+    ring_simplify.
+    auto.
+  - apply Zle_lt_succ in H.
+    ring_simplify in H.
+    auto.
+Qed.
+
+Lemma le_0_iff : forall x y,
+    x <= y <-> 0 <= y - x.
+Proof.
+  split ; intros.
+  - apply Zle_minus_le_0; auto.
+  - apply Zle_0_minus_le; auto.
+Qed.
+
+Lemma le_neg : forall x,
+    ((0 <= x) -> False) <-> 0 < -x.
+Proof.
+  intro.
+  rewrite lt_le_iff.
+  split ; intros.
+  - apply Znot_le_gt in H.
+    apply Zgt_le_succ in H.
+    rewrite le_0_iff in H.
+    ring_simplify in H; auto.
+  - assert (C := (Z.add_le_mono _ _ _ _ H H0)).
+    ring_simplify in C.
+    compute in C.
+    apply C ; reflexivity.
+Qed.
+
+Lemma eq_cnf : forall x,
+    (0 <= x - 1 -> False) /\ (0 <= -1 - x -> False) <-> x = 0.
+Proof.
+  intros.
+  rewrite Z.eq_sym_iff.
+  rewrite eq_le_iff.
+  rewrite (le_0_iff x 0).
+  rewrite !le_neg.
+  rewrite !lt_le_iff.
+  replace (- (x - 1) -1) with (-x) by ring.
+  replace (- (-1 - x) -1) with x by ring.
+  split ; intros (H1 &  H2); auto.
+Qed.
+
+
+
+
+Require Import EnvRing.
+
+Lemma Zsor : SOR 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt.
+Proof.
+  constructor ; intros ; subst; try reflexivity.
+  apply Zsth.
+  apply Zth.
+  auto using Z.le_antisymm.
+  eauto using Z.le_trans.
+  apply Z.le_neq.
+  destruct (Z.lt_trichotomy n m) ; intuition.
+  apply Z.add_le_mono_l; assumption.
+  apply Z.mul_pos_pos ; auto.
+  discriminate.
+Qed.
+
+Lemma ZSORaddon :
+  SORaddon 0 1 Z.add Z.mul Z.sub Z.opp  (@eq Z) Z.le (* ring elements *)
+  0%Z 1%Z Z.add Z.mul Z.sub Z.opp (* coefficients *)
+  Zeq_bool Z.leb
+  (fun x => x) (fun x => x) (pow_N 1 Z.mul).
+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  => Z.pow (Zeval_expr env e1) (Z.of_N n)
+    | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2)
+    | PEopp e   => Z.opp (Zeval_expr env e)
+  end.
+
+Definition eval_expr := eval_pexpr  Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => x) (pow_N 1 Z.mul).
+
+Fixpoint Zeval_const  (e: PExpr Z) : option Z :=
+  match e with
+  | PEc c => Some c
+  | PEX x => None
+  | PEadd e1 e2 => map_option2 (fun x y => Some (x + y))
+                               (Zeval_const e1) (Zeval_const e2)
+  | PEmul e1 e2 => map_option2 (fun x y => Some (x * y))
+                               (Zeval_const e1) (Zeval_const e2)
+  | PEpow e1 n  => map_option (fun x => Some (Z.pow x (Z.of_N n)))
+                                 (Zeval_const e1)
+  | PEsub e1 e2 => map_option2 (fun x y => Some (x - y))
+                               (Zeval_const e1)  (Zeval_const e2)
+  | PEopp e   => map_option (fun x => Some (Z.opp x)) (Zeval_const e)
+  end.
+
+Lemma ZNpower : forall r n, r ^ Z.of_N n = pow_N 1 Z.mul r n.
+Proof.
+  destruct n.
+  reflexivity.
+  simpl.
+  unfold Z.pow_pos.
+  replace (pow_pos Z.mul r p) with (1 * (pow_pos Z.mul 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 => Z.le
+| OpGe => Z.ge
+| OpLt => Z.lt
+| OpGt => Z.gt
+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  Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt (fun x => x) (fun x => x) (pow_N 1 Z.mul).
+
+Lemma Zeval_formula_compat' : forall env f,  Zeval_formula env  f <-> Zeval_formula' env f.
+Proof.
+  intros.
+  unfold Zeval_formula.
+  destruct f.
+  repeat rewrite Zeval_expr_compat.
+  unfold Zeval_formula' ; simpl.
+  unfold eval_expr.
+  generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
+        (fun x : N => x) (pow_N 1 Z.mul) env Flhs).
+  generalize ((eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
+        (fun x : N => x) (pow_N 1 Z.mul) env Frhs)).
+  destruct Fop ; simpl; intros;
+    intuition auto using Z.le_ge, Z.ge_le, Z.lt_gt, Z.gt_lt.
+Qed.
+
+
+Definition eval_nformula :=
+  eval_nformula 0 Z.add Z.mul  (@eq Z) Z.le Z.lt (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 Z.add Z.mul Zeq_bool Z.leb.
+
+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  Z.add Z.sub Z.opp Zeq_bool.
+Declare Equivalent Keys psub RingMicromega.psub.
+
+Definition padd  := padd Z0  Z.add Zeq_bool.
+Declare Equivalent Keys padd RingMicromega.padd.
+
+Definition pmul := pmul 0 1 Z.add Z.mul Zeq_bool.
+
+Definition normZ  := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool.
+Declare Equivalent Keys normZ RingMicromega.norm.
+
+Definition eval_pol := eval_pol Z.add Z.mul (fun x => x).
+Declare Equivalent Keys eval_pol RingMicromega.eval_pol.
+
+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_mul : forall env lhs rhs, eval_pol env (pmul  lhs rhs) = eval_pol env lhs * eval_pol env rhs.
+Proof.
+  intros.
+  apply (eval_pol_mul Zsor ZSORaddon).
+Qed.
+
+
+Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (normZ e) .
+Proof.
+  intros.
+  apply (eval_pol_norm Zsor ZSORaddon).
+Qed.
+
+Definition Zunsat := check_inconsistent 0  Zeq_bool Z.leb.
+
+Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool.
+
+Lemma Zunsat_sound : forall f,
+    Zunsat f = true -> forall env, eval_nformula env f -> False.
+Proof.
+  unfold Zunsat.
+  intros.
+  destruct f.
+  eapply check_inconsistent_sound with (1 := Zsor) (2 := ZSORaddon) in H; eauto.
+Qed.
+
+Definition xnnormalise (t : Formula Z) : NFormula Z :=
+  let (lhs,o,rhs) := t in
+  let lhs := normZ lhs in
+  let rhs := normZ rhs in
+  match o with
+  | OpEq  => (psub rhs lhs,  Equal)
+  | OpNEq => (psub rhs lhs,  NonEqual)
+  | OpGt  => (psub lhs rhs,  Strict)
+  | OpLt  => (psub rhs lhs,  Strict)
+  | OpGe  => (psub lhs rhs,  NonStrict)
+  | OpLe =>  (psub rhs lhs,  NonStrict)
+  end.
+
+Lemma xnnormalise_correct :
+  forall env f,
+    eval_nformula env (xnnormalise f) <-> Zeval_formula env  f.
+Proof.
+  intros.
+  rewrite Zeval_formula_compat'.
+  unfold xnnormalise.
+  destruct f as [lhs o rhs].
+  destruct o eqn:O ; cbn ; rewrite ?eval_pol_sub;
+    rewrite <- !eval_pol_norm ; simpl in *;
+      unfold eval_expr;
+      generalize (   eval_pexpr  Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
+                                 (fun x : N => x) (pow_N 1 Z.mul) env lhs);
+      generalize (eval_pexpr  Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
+                              (fun x : N => x) (pow_N 1 Z.mul) env rhs); intros.
+  - split ; intros.
+    + assert (z0 + (z - z0) = z0 + 0) by congruence.
+      rewrite Z.add_0_r in H0.
+      rewrite <- H0.
+      ring.
+    + subst.
+      ring.
+  - split ; repeat intro.
+    subst. apply H. ring.
+    apply H.
+    assert (z0 + (z - z0) = z0 + 0) by congruence.
+    rewrite Z.add_0_r in H1.
+    rewrite <- H1.
+    ring.
+  - split ; intros.
+    + apply Zle_0_minus_le; auto.
+    + apply Zle_minus_le_0; auto.
+  - split ; intros.
+    + apply Zle_0_minus_le; auto.
+    + apply Zle_minus_le_0; auto.
+  - split ; intros.
+    + apply Zlt_0_minus_lt; auto.
+    + apply Zlt_left_lt in H.
+      apply H.
+  - split ; intros.
+    + apply Zlt_0_minus_lt ; auto.
+    + apply Zlt_left_lt in H.
+      apply H.
+Qed.
+
+Definition xnormalise (f: NFormula Z) : list (NFormula Z) :=
+  let (e,o) := f in
+  match o with
+  | Equal     => (psub e (Pc 1),NonStrict) :: (psub (Pc (-1)) e, NonStrict) :: nil
+  | NonStrict =>  ((psub (Pc (-1)) e,NonStrict)::nil)
+  | Strict    =>  ((psub (Pc 0)) e, NonStrict)::nil
+  | NonEqual  =>  (e, Equal)::nil
+  end.
+
+Lemma eval_pol_Pc : forall env z,
+    eval_pol env (Pc z) = z.
+Proof.
+  reflexivity.
+Qed.
+
+Ltac iff_ring :=
+  match goal with
+  | |- ?F 0  ?X <-> ?F 0  ?Y => replace X with Y by ring ; tauto
+  end.
+
+
+Lemma xnormalise_correct : forall env f,
+    (make_conj (fun x => eval_nformula env x -> False) (xnormalise f)) <-> eval_nformula env f.
+Proof.
+  intros.
+  destruct f as [e o]; destruct o eqn:Op; cbn - [psub];
+    repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc;
+      generalize (eval_pol env e) as x; intro.
+  - apply eq_cnf.
+  - unfold not. tauto.
+  - rewrite le_neg.
+    iff_ring.
+  - rewrite le_neg.
+    rewrite lt_le_iff.
+    iff_ring.
+Qed.
+
+
+Require Import Coq.micromega.Tauto BinNums.
+
+Definition cnf_of_list {T: Type} (tg : T) (l : list (NFormula Z)) :=
+  List.fold_right (fun x acc =>
+                     if Zunsat x then acc else ((x,tg)::nil)::acc)
+                  (cnf_tt _ _)  l.
+
+Lemma cnf_of_list_correct :
+  forall {T : Type} (tg:T)  (f : list (NFormula Z)) env,
+  eval_cnf eval_nformula env (cnf_of_list tg f) <->
+  make_conj (fun x : NFormula Z => eval_nformula env x -> False) f.
+Proof.
+  unfold cnf_of_list.
+  intros.
+  set (F := (fun (x : NFormula Z) (acc : list (list (NFormula Z * T))) =>
+        if Zunsat x then acc else ((x, tg) :: nil) :: acc)).
+  set (E := ((fun x : NFormula Z => eval_nformula env x -> False))).
+  induction f.
+  - compute.
+    tauto.
+  - rewrite make_conj_cons.
+    simpl.
+    unfold F at 1.
+    destruct (Zunsat a) eqn:EQ.
+    + rewrite IHf.
+      unfold E at 1.
+      specialize (Zunsat_sound _ EQ env).
+      tauto.
+    +
+      rewrite <- eval_cnf_cons_iff.
+      rewrite IHf.
+      simpl.
+      unfold E at 2.
+      unfold eval_tt. simpl.
+      tauto.
+Qed.
+
+Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T :=
+  let f := xnnormalise t in
+  if Zunsat f then cnf_ff _ _
+  else cnf_of_list tg (xnormalise f).
+
+Lemma normalise_correct : forall (T: Type) env t (tg:T), eval_cnf eval_nformula env (normalise t tg) <-> Zeval_formula env t.
+Proof.
+  intros.
+  rewrite <- xnnormalise_correct.
+  unfold normalise.
+  generalize (xnnormalise t) as f;intro.
+  destruct (Zunsat f) eqn:U.
+  - assert (US := Zunsat_sound _  U env).
+    rewrite eval_cnf_ff.
+    tauto.
+  - rewrite cnf_of_list_correct.
+    apply xnormalise_correct.
+Qed.
+
+Definition xnegate (f:NFormula Z) : list (NFormula Z)  :=
+  let (e,o) := f in
+    match o with
+      | Equal  => (e,Equal) :: nil
+      | NonEqual => (psub e (Pc 1),NonStrict) :: (psub (Pc (-1)) e, NonStrict) :: nil
+      | NonStrict => (e,NonStrict)::nil
+      | Strict    => (psub e (Pc 1),NonStrict)::nil
+    end.
+
+Definition negate {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T :=
+  let f := xnnormalise t in
+  if Zunsat f then cnf_tt _ _
+  else cnf_of_list tg (xnegate f).
+
+Lemma xnegate_correct : forall env f,
+    (make_conj (fun x => eval_nformula env x -> False) (xnegate f)) <-> ~ eval_nformula env f.
+Proof.
+  intros.
+  destruct f as [e o]; destruct o eqn:Op; cbn - [psub];
+    repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc;
+      generalize (eval_pol env e) as x; intro.
+  - tauto.
+  - rewrite eq_cnf.
+    destruct (Z.eq_decidable x 0);tauto.
+  - rewrite lt_le_iff.
+    tauto.
+  - tauto.
+Qed.
+
+Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env  t.
+Proof.
+  intros.
+  rewrite <- xnnormalise_correct.
+  unfold negate.
+  generalize (xnnormalise t) as f;intro.
+  destruct (Zunsat f) eqn:U.
+  - assert (US := Zunsat_sound _  U env).
+    rewrite eval_cnf_tt.
+    tauto.
+  - rewrite cnf_of_list_correct.
+    apply xnegate_correct.
+Qed.
+
+Definition cnfZ (Annot: Type) (TX : Type)  (AF : Type)  (f : TFormula (Formula Z) Annot TX AF) :=
+  rxcnf Zunsat Zdeduce normalise negate true f.
+
+Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool :=
+  @tauto_checker (Formula Z)  (NFormula Z) unit Zunsat Zdeduce normalise negate  ZWitness (fun cl => ZWeakChecker (List.map fst cl)) f w.
+
+(* To get a complete checker, the proof format has to be enriched *)
+
+Require Import Zdiv.
+Local Open Scope Z_scope.
+
+Definition ceiling (a b:Z) : Z :=
+  let (q,r) := Z.div_eucl a b in
+    match r with
+      | Z0 => q
+      | _  => q + 1
+    end.
+
+
+Require Import Znumtheory.
+
+Lemma Zdivide_ceiling : forall a b, (b | a) -> ceiling a b = Z.div a b.
+Proof.
+  unfold ceiling.
+  intros.
+  apply Zdivide_mod in H.
+  case_eq (Z.div_eucl a b).
+  intros.
+  change z with (fst (z,z0)).
+  rewrite <- H0.
+  change (fst (Z.div_eucl a b)) with (Z.div a b).
+  change z0 with (snd (z,z0)).
+  rewrite <- H0.
+  change (snd (Z.div_eucl a b)) with (Z.modulo a b).
+  rewrite H.
+  reflexivity.
+Qed.
+
+Lemma narrow_interval_lower_bound a b x :
+  a > 0 -> a * x  >= b -> x >= ceiling b a.
+Proof.
+  rewrite !Z.ge_le_iff.
+  unfold ceiling.
+  intros Ha H.
+  generalize (Z_div_mod b a Ha).
+  destruct (Z.div_eucl b a) as (q,r). intros (->,(H1,H2)).
+  destruct r as [|r|r].
+  - rewrite Z.add_0_r in H.
+    apply Z.mul_le_mono_pos_l in H; auto with zarith.
+  - assert (0 < Z.pos r) by easy.
+    rewrite Z.add_1_r, Z.le_succ_l.
+    apply Z.mul_lt_mono_pos_l with a.
+    auto using Z.gt_lt.
+    eapply Z.lt_le_trans. 2: eassumption.
+    now apply Z.lt_add_pos_r.
+  - now elim H1.
+Qed.
+
+(** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *)
+
+Require Import QArith.
+
+Inductive ZArithProof :=
+| DoneProof
+| RatProof : ZWitness -> ZArithProof -> ZArithProof
+| CutProof : ZWitness -> ZArithProof -> ZArithProof
+| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof
+| ExProof   : positive -> ZArithProof -> ZArithProof
+(*ExProof x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *)
+.
+(*| SplitProof :   PolC Z -> ZArithProof -> ZArithProof -> ZArithProof.*)
+
+
+
+(* n/d <= x  -> d*x - n >= 0 *)
+
+
+(* 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) := Z.max (Z.gcd 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 (Z.div 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. 1-2: easy.
+  simpl.
+  case_eq (Zgcd_pol p1).
+  case_eq (Zgcd_pol p3).
+  intros.
+  simpl.
+  unfold ZgcdM.
+  apply Z.le_ge; transitivity 1. easy.
+  apply Z.le_max_r.
+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 Z.divide_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 ) -> (Z.gcd a b | c).
+Proof.
+  intros a b c (q,Hq).
+  destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _].
+  set (g:=Z.gcd a b) in *; clearbody g.
+  exists (q * a' + b').
+  symmetry in Hq. rewrite <- Z.add_move_r in Hq.
+  rewrite <- Hq, Hb, Ha. ring.
+Qed.
+
+Lemma Zdivide_pol_sub : forall p a b,
+  0 < Z.gcd a b ->
+  Zdivide_pol a (PsubC Z.sub p b) ->
+   Zdivide_pol (Z.gcd 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 Z.sub p 0) ->
+   Zdivide_pol a p.
+Proof.
+  induction p.
+  simpl.
+  intros. inversion H.
+  constructor. rewrite Z.sub_0_r in *. assumption.
+  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 Z.sub 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 (Z.gcd (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  (Z.gcd z1 z2)  1) as [HH2 | HH2].
+  destruct HH2.
+  rewrite H2.
+  apply Zdivide_pol_sub ; auto.
+  apply Z.lt_le_trans with 1. reflexivity. now apply Z.ge_le.
+  destruct HH2. rewrite H2.
+  apply Zdivide_pol_one.
+  unfold ZgcdM in HH1. unfold ZgcdM.
+  destruct (Zmax_spec  (Z.gcd z1 z2)  1) as [HH2 | HH2].
+  destruct HH2. rewrite H2 in *.
+  destruct (Zgcd_is_gcd (Z.gcd 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 Z.sub 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 Z.gtb g Z0
+      then (Zdiv_pol (PsubC Z.sub p c) g , Z.opp (ceiling (Z.opp 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 (Z.gtb g Z0) (andb (negb (Zeq_bool c Z0)) (negb (Zeq_bool (Z.gcd g c) g)))
+          then None (* inconsistent *)
+          else (* Could be optimised Zgcd_pol is recomputed *)
+            let (p,c) := makeCuttingPlane e  in
+              Some (p,c,Equal)
+      | NonEqual => Some (e,Z0,op)
+      | Strict   =>  let (p,c) := makeCuttingPlane (PsubC Z.sub 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 Z.add Z.mul Zeq_bool Z.leb.
+
+
+Definition valid_cut_sign (op:Op1) :=
+  match op with 
+    | Equal => true
+    | NonStrict => true
+    | _         => false
+  end.
+
+
+Definition bound_var (v : positive) : Formula Z :=
+  Build_Formula (PEX v) OpGe (PEc 0).
+
+Definition mk_eq_pos (x : positive) (y:positive) (t : positive) : Formula Z :=
+  Build_Formula (PEX x) OpEq (PEsub (PEX y) (PEX t)).
+
+
+Fixpoint vars (jmp : positive) (p : Pol Z) : list positive :=
+  match p with
+  | Pc c => nil
+  | Pinj j p => vars (Pos.add j jmp) p
+  | PX p j q => jmp::(vars jmp p)++vars (Pos.succ jmp) q
+  end.
+
+Fixpoint max_var (jmp : positive) (p : Pol Z) : positive :=
+  match p with
+  | Pc _ => jmp
+  | Pinj j p => max_var (Pos.add j jmp) p
+  | PX p j q => Pos.max (max_var jmp p) (max_var (Pos.succ jmp) q)
+  end.
+
+Lemma pos_le_add : forall y x,
+    (x <= y + x)%positive.
+Proof.
+  intros.
+  assert  ((Z.pos x) <= Z.pos (x + y))%Z.
+  rewrite <- (Z.add_0_r (Zpos x)).
+  rewrite <- Pos2Z.add_pos_pos.
+  apply Z.add_le_mono_l.
+  compute. congruence.
+  rewrite Pos.add_comm in H.
+  apply H.
+Qed.
+
+
+Lemma max_var_le : forall p v,
+    (v <= max_var v p)%positive.
+Proof.
+  induction p; simpl.
+  - intros.
+    apply Pos.le_refl.
+  - intros.
+    specialize (IHp (p+v)%positive).
+    eapply Pos.le_trans ; eauto.
+    assert (xH + v <= p + v)%positive.
+    { apply Pos.add_le_mono.
+      apply Pos.le_1_l.
+      apply Pos.le_refl.
+    }
+    eapply Pos.le_trans ; eauto.
+    apply pos_le_add.
+  - intros.
+    apply Pos.max_case_strong;intros ; auto.
+    specialize (IHp2 (Pos.succ v)%positive).
+    eapply Pos.le_trans ; eauto.
+Qed.
+
+Lemma max_var_correct : forall p j v,
+    In v (vars j p) -> Pos.le v (max_var j p).
+Proof.
+  induction p; simpl.
+  - tauto.
+  - auto.
+  - intros.
+    rewrite in_app_iff in H.
+    destruct H as [H |[ H | H]].
+    + subst.
+      apply Pos.max_case_strong;intros ; auto.
+      apply max_var_le.
+      eapply Pos.le_trans ; eauto.
+      apply max_var_le.
+    + apply Pos.max_case_strong;intros ; auto.
+      eapply Pos.le_trans ; eauto.
+    + apply Pos.max_case_strong;intros ; auto.
+      eapply Pos.le_trans ; eauto.
+Qed.
+
+Definition max_var_nformulae (l : list (NFormula Z)) :=
+  List.fold_left  (fun acc f => Pos.max acc (max_var xH (fst f))) l xH.
+
+Section MaxVar.
+
+  Definition F (acc : positive) (f : Pol Z * Op1) := Pos.max acc (max_var 1 (fst f)).
+
+  Lemma max_var_nformulae_mono_aux :
+    forall l v acc,
+      (v <= acc ->
+       v <= fold_left F l acc)%positive.
+  Proof.
+    induction l ; simpl ; [easy|].
+    intros.
+    apply IHl.
+    unfold F.
+    apply Pos.max_case_strong;intros ; auto.
+    eapply Pos.le_trans ; eauto.
+  Qed.
+
+  Lemma max_var_nformulae_mono_aux' :
+    forall l acc acc',
+      (acc <= acc' ->
+       fold_left F l acc <= fold_left F l acc')%positive.
+  Proof.
+    induction l ; simpl ; [easy|].
+    intros.
+    apply IHl.
+    unfold F.
+    apply Pos.max_le_compat_r; auto.
+  Qed.
+
+
+
+
+  Lemma max_var_nformulae_correct_aux : forall l p o v,
+      In (p,o) l -> In v (vars xH p) -> Pos.le v (fold_left F l 1)%positive.
+  Proof.
+  intros.
+  generalize 1%positive as acc.
+  revert p o v H H0.
+  induction l.
+  - simpl. tauto.
+  - simpl.
+    intros.
+    destruct H ; subst.
+    + unfold F at 2.
+      simpl.
+      apply max_var_correct in H0.
+      apply max_var_nformulae_mono_aux.
+      apply Pos.max_case_strong;intros ; auto.
+      eapply Pos.le_trans ; eauto.
+    + eapply IHl ; eauto.
+  Qed.
+
+End MaxVar.
+
+Lemma max_var_nformalae_correct : forall l p o v,
+      In (p,o) l -> In v (vars xH p) -> Pos.le v (max_var_nformulae l)%positive.
+Proof.
+  intros l p o v.
+  apply max_var_nformulae_correct_aux.
+Qed.
+
+
+Fixpoint max_var_psatz (w : Psatz Z) : positive :=
+  match w with
+  | PsatzIn _ n => xH
+  | PsatzSquare p => max_var xH (Psquare 0 1 Z.add Z.mul Zeq_bool p)
+  | PsatzMulC p w => Pos.max (max_var xH p) (max_var_psatz w)
+  | PsatzMulE w1 w2 => Pos.max (max_var_psatz w1) (max_var_psatz w2)
+  | PsatzAdd w1 w2  => Pos.max (max_var_psatz w1) (max_var_psatz w2)
+  | _   => xH
+  end.
+
+Fixpoint max_var_prf (w : ZArithProof) : positive :=
+  match w with
+  | DoneProof => xH
+  | RatProof w pf | CutProof w pf => Pos.max (max_var_psatz w) (max_var_prf pf)
+  | EnumProof w1 w2 l => List.fold_left (fun acc prf => Pos.max acc (max_var_prf prf)) l
+                                        (Pos.max (max_var_psatz w1) (max_var_psatz w2))
+  | ExProof _ pf => max_var_prf pf
+  end.
+
+
+
+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 Zunsat 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
+    | ExProof x prf =>
+      let fr := max_var_nformulae l in
+      if Pos.leb x fr then
+      let z    := Pos.succ fr in
+      let t    := Pos.succ z in
+      let nfx  := xnnormalise (mk_eq_pos x z t) in
+      let posz := xnnormalise (bound_var z) in
+      let post := xnnormalise (bound_var t) in
+      ZChecker (nfx::posz::post::l) prf
+      else false
+      | 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) =>
+               if (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd e1 e2))
+                 then 
+                   (fix label (pfs:list ZArithProof) :=
+                   fun lb ub =>
+                     match pfs with
+                       | nil => if Z.gtb lb ub then true else false
+                       | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Z.add lb 1%Z) ub)
+                     end)   pf (Z.opp z1)  z2
+                  else false
+              |   _    ,   _   => true
+           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 => Nat.max (bdepth pf) x)   O l)
+    | ExProof _ p   => S (bdepth p)
+  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) => Nat.max (bdepth pf) x) 0%nat l)).
+  intros.
+  generalize (bdepth y) ; intros.
+  rewrite Nat.lt_succ_r. apply Nat.le_max_l.
+  generalize (IHl a0 b  y  H).
+  unfold ltof.
+  simpl.
+  generalize (      (fold_right (fun (pf : ZArithProof) (x : nat) => Nat.max (bdepth pf) x) 0%nat
+         l)).
+  intros.
+  eapply lt_le_trans. eassumption.
+  rewrite <- Nat.succ_le_mono.
+  apply Nat.le_max_r.
+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_ns_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 (Z.gtb g 0).
+  intros.
+  inv H2.
+  change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in *.
+  apply Zgcd_pol_correct_lt with (env:=env) in H1. 2: auto using Z.gt_lt.
+  apply Z.le_add_le_sub_l, Z.ge_le; rewrite Z.add_0_r.
+  apply (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g)) H0).
+  apply Z.le_ge.
+  rewrite <- Z.sub_0_l.
+  apply Z.le_sub_le_add_r.
+  rewrite <- H1.
+  assumption.
+  (* 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.
+  case_eq (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))) ; [discriminate|].
+  case_eq (makeCuttingPlane e).
+  intros.
+  inv H3.
+  unfold makeCuttingPlane in H.
+  rewrite H1 in H.
+  revert H.
+  change (eval_pol env e = 0) in H2.
+  case_eq (Z.gtb g 0).
+  intros.
+  rewrite <- Zgt_is_gt_bool in H.  
+  rewrite Zgcd_pol_correct_lt with (1:= H1)  in H2. 2: auto using Z.gt_lt.
+  unfold nformula_of_cutting_plane.  
+  change (eval_pol env (padd e' (Pc z)) = 0).
+  inv H3.
+  rewrite eval_pol_add.
+  set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub e c) g)) in *; clearbody x.
+  simpl.
+  rewrite andb_false_iff in H0.
+  destruct H0.
+  rewrite Zgt_is_gt_bool in H ; congruence.
+  rewrite andb_false_iff in H0.
+  destruct H0.
+  rewrite negb_false_iff in H0.
+  apply Zeq_bool_eq in H0.
+  subst. simpl.
+  rewrite Z.add_0_r, Z.mul_eq_0 in H2.
+  intuition subst; easy.
+  rewrite negb_false_iff in H0.
+  apply Zeq_bool_eq in H0.
+  assert (HH := Zgcd_is_gcd g c).
+  rewrite H0 in HH.
+  inv HH.
+  apply Zdivide_opp_r in H4.
+  rewrite Zdivide_ceiling ; auto.
+  apply Z.sub_move_0_r.
+  apply Z.div_unique_exact. now intros ->.
+  now rewrite Z.add_move_0_r in H2.
+  intros.
+  unfold nformula_of_cutting_plane.
+  inv H3.
+  change (eval_pol env (padd e' (Pc 0)) = 0).
+  rewrite eval_pol_add.
+  simpl.
+  now rewrite Z.add_0_r.
+  (* 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. now rewrite Z.add_0_r.
+  (* Strict *)
+  destruct p as [[e' z] op].
+  case_eq (makeCuttingPlane (PsubC Z.sub e 1)).
+  intros.
+  inv H1.
+  apply makeCuttingPlane_ns_sound with (env:=env) (2:= H).
+  simpl in *.
+  rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
+  now apply Z.lt_le_pred.
+  (* NonStrict *)
+  destruct p as [[e' z] op].
+  case_eq (makeCuttingPlane e).
+  intros.
+  inv H1.
+  apply makeCuttingPlane_ns_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 (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))).
+  intros.
+  flatten_bool.
+  rewrite negb_true_iff in H5.
+  apply Zeq_bool_neq in H5.
+  rewrite <- Zgt_is_gt_bool in H3.
+  rewrite negb_true_iff in H.
+  apply Zeq_bool_neq in H.
+  change (eval_pol env p = 0) in H2.
+  rewrite Zgcd_pol_correct_lt with (1:= H0) in H2. 2: auto using Z.gt_lt.
+  set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) in *; clearbody x.
+  contradict H5.
+  apply Zis_gcd_gcd. apply Z.lt_le_incl, Z.gt_lt; assumption.
+  constructor; auto with zarith.
+  exists (-x).
+  rewrite Z.mul_opp_l, Z.mul_comm.
+  now apply Z.add_move_0_l.
+  (**)
+  destruct (makeCuttingPlane p);  discriminate.
+  discriminate.
+  destruct (makeCuttingPlane (PsubC Z.sub p 1)) ; discriminate.
+  destruct (makeCuttingPlane p) ; discriminate.
+Qed.
+
+Lemma eval_nformula_mk_eq_pos : forall env x z t,
+    env x = env z - env t ->
+    eval_nformula env (xnnormalise (mk_eq_pos x z t)).
+Proof.
+  intros.
+  rewrite xnnormalise_correct.
+  simpl. auto.
+Qed.
+
+Lemma eval_nformula_bound_var : forall env x,
+    env x >= 0 ->
+    eval_nformula env (xnnormalise (bound_var x)).
+Proof.
+  intros.
+  rewrite xnnormalise_correct.
+  simpl. auto.
+Qed.
+
+
+Definition agree_env (fr : positive) (env env' : positive -> Z) : Prop :=
+  forall x, Pos.le x fr -> env x = env' x.
+
+Lemma agree_env_subset : forall v1 v2 env env',
+    agree_env v1 env env' ->
+    Pos.le v2 v1 ->
+    agree_env v2 env env'.
+Proof.
+  unfold agree_env.
+  intros.
+  apply H.
+  eapply Pos.le_trans ; eauto.
+Qed.
+
+
+Lemma agree_env_jump : forall fr j env env',
+    agree_env (fr + j) env env' ->
+    agree_env fr (Env.jump j env) (Env.jump j env').
+Proof.
+  intros.
+  unfold agree_env ; intro.
+  intros.
+  unfold Env.jump.
+  apply H.
+  apply Pos.add_le_mono_r; auto.
+Qed.
+
+
+Lemma agree_env_tail : forall fr env env',
+    agree_env (Pos.succ fr) env env' ->
+    agree_env fr (Env.tail env) (Env.tail env').
+Proof.
+  intros.
+  unfold Env.tail.
+  apply agree_env_jump.
+  rewrite <- Pos.add_1_r in H.
+  apply H.
+Qed.
+
+
+Lemma max_var_acc : forall p i j,
+    (max_var (i + j) p = max_var i p + j)%positive.
+Proof.
+  induction p; simpl.
+  - reflexivity.
+  - intros.
+    rewrite ! IHp.
+    rewrite Pos.add_assoc.
+    reflexivity.
+  - intros.
+    rewrite !Pplus_one_succ_l.
+    rewrite ! IHp1.
+    rewrite ! IHp2.
+    rewrite ! Pos.add_assoc.
+    rewrite <- Pos.add_max_distr_r.
+    reflexivity.
+Qed.
+
+
+
+Lemma agree_env_eval_nformula :
+  forall env env' e
+         (AGREE : agree_env (max_var xH (fst e))  env env'),
+    eval_nformula env e  <->  eval_nformula env' e.
+Proof.
+  destruct e.
+  simpl; intros.
+  assert ((RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env p)
+          =
+          (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x) env' p)).
+  {
+    revert env env' AGREE.
+    generalize xH.
+    induction p ; simpl.
+    - reflexivity.
+    - intros.
+      apply IHp with (p := p1%positive).
+      apply agree_env_jump.
+      eapply agree_env_subset; eauto.
+      rewrite (Pos.add_comm p).
+      rewrite max_var_acc.
+      apply Pos.le_refl.
+    - intros.
+      f_equal.
+      f_equal.
+      { apply IHp1 with (p:= p).
+        eapply agree_env_subset; eauto.
+        apply Pos.le_max_l.
+      }
+      f_equal.
+      { unfold Env.hd.
+        unfold Env.nth.
+        apply AGREE.
+        apply Pos.le_1_l.
+      }
+      {
+        apply IHp2 with (p := p).
+        apply agree_env_tail.
+        eapply agree_env_subset; eauto.
+        rewrite !Pplus_one_succ_r.
+        rewrite max_var_acc.
+        apply Pos.le_max_r.
+      }
+  }
+  rewrite H. tauto.
+Qed.
+
+Lemma agree_env_eval_nformulae :
+  forall env env' l
+         (AGREE : agree_env (max_var_nformulae l) env env'),
+         make_conj (eval_nformula env) l <->
+         make_conj (eval_nformula env') l.
+Proof.
+  induction l.
+  - simpl. tauto.
+  - intros.
+    rewrite ! make_conj_cons.
+    assert (eval_nformula env a <-> eval_nformula env' a).
+    {
+      apply agree_env_eval_nformula.
+      eapply agree_env_subset ; eauto.
+      unfold max_var_nformulae.
+      simpl.
+      rewrite Pos.max_1_l.
+      apply max_var_nformulae_mono_aux.
+      apply Pos.le_refl.
+    }
+    rewrite H.
+    apply  and_iff_compat_l.
+    apply IHl.
+    eapply agree_env_subset ; eauto.
+    unfold max_var_nformulae.
+    simpl.
+    apply max_var_nformulae_mono_aux'.
+    apply Pos.le_1_l.
+Qed.
+
+
+Lemma eq_true_iff_eq :
+  forall b1 b2 : bool, (b1 = true <-> b2 = true) <-> b1 = b2.
+Proof.
+  destruct b1,b2 ; intuition congruence.
+Qed.
+
+Ltac pos_tac :=
+  repeat
+  match goal with
+  | |- false = _ => symmetry
+  | |- Pos.eqb ?X ?Y = false => rewrite Pos.eqb_neq ; intro
+  | H : @eq positive ?X ?Y |- _ =>  apply Zpos_eq in H
+  | H : context[Z.pos (Pos.succ ?X)] |- _ => rewrite (Pos2Z.inj_succ X) in H
+  | H : Pos.leb ?X ?Y = true |- _ => rewrite Pos.leb_le in H ;
+                                     apply (Pos2Z.pos_le_pos X Y) in H
+  end.
+
+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 | x pf].
+  - (* DoneProof *)
+  simpl. discriminate.
+  - (* RatProof *)
+  simpl.
+  intros l. case_eq (eval_Psatz l w) ; [| discriminate].
+  intros f Hf.
+  case_eq (Zunsat f).
+  intros.
+  apply (checker_nf_sound Zsor ZSORaddon l w).
+  unfold check_normalised_formulas.  unfold eval_Psatz in Hf. rewrite Hf.
+  unfold Zunsat 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.
+  intros 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 *)
+  intros l.
+  simpl.
+  case_eq (eval_Psatz l w1) ; [  | discriminate].
+  case_eq (eval_Psatz l w2) ; [  | discriminate].
+  intros f1 Hf1 f2 Hf2.
+  case_eq (genCuttingPlane f2).
+  destruct p as [ [p1 z1] op1].
+  case_eq (genCuttingPlane f1).
+  destruct p as [ [p2 z2] op2].
+  case_eq (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd p1 p2)).
+  intros Hcond.
+  flatten_bool.
+  rename H1 into HZ0.
+  rename H2 into Hop1.
+  rename H3 into Hop2.
+  intros HCutL HCutR Hfix env.
+  (* 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 HCutR.
+   unfold nformula_of_cutting_plane in HCutR.
+   unfold eval_nformula in HCutR.
+   unfold RingMicromega.eval_nformula in HCutR.
+   change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutR.
+   unfold eval_op1 in HCutR.
+   destruct op1 ; simpl in Hop1 ; try discriminate;
+     rewrite eval_pol_add in HCutR; simpl in HCutR.
+     rewrite Z.add_move_0_l in HCutR; rewrite HCutR, Z.opp_involutive; reflexivity.
+     now apply Z.le_sub_le_add_r in HCutR.
+   (**)
+   apply is_pol_Z0_eval_pol with (env := env) in HZ0.
+   rewrite eval_pol_add, Z.add_move_r, Z.sub_0_l in HZ0.
+   rewrite HZ0.
+   apply  eval_Psatz_sound with (env:=env) in Hf1 ; auto.
+   apply cutting_plane_sound with (1:= Hf1) in HCutL.
+   unfold nformula_of_cutting_plane in HCutL.
+   unfold eval_nformula in HCutL.
+   unfold RingMicromega.eval_nformula in HCutL.
+   change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutL.
+   unfold eval_op1 in HCutL.
+   rewrite eval_pol_add in HCutL. simpl in HCutL.
+   destruct op2 ; simpl in Hop2 ; try discriminate.
+   rewrite Z.add_move_r, Z.sub_0_l in HCutL.
+   now rewrite HCutL, Z.opp_involutive.
+   now rewrite <- Z.le_sub_le_add_l in HCutL.
+  revert Hfix.
+  match goal with
+    | |- context[?F pf (-z1) z2 = true] => set (FF := F)
+  end.
+  intros.
+  assert (HH :forall x, -z1 <= x <= z2 -> exists pr,
+    (In pr pf /\
+      ZChecker ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z).
+  clear HZ0 Hop1 Hop2 HCutL HCutR H0 H1.
+  revert Hfix.
+  generalize (-z1). clear z1. intro z1.
+  revert z1 z2.
+  induction pf;simpl ;intros.
+  revert Hfix.
+  now case (Z.gtb_spec); [ | easy ]; intros LT; elim (Zlt_not_le _ _ LT); transitivity x.
+  flatten_bool.
+  destruct (Z_le_lt_eq_dec _ _ (proj1 H0)) as [ LT | -> ].
+  2: exists a; auto.
+  rewrite <- Z.le_succ_l in LT.
+  assert (LE: (Z.succ z1 <= x <= z2)%Z) by intuition.
+  elim IHpf with (2:=H2) (3:= LE).
+  intros.
+  exists x0 ; split;tauto.
+  intros until 1. 
+  apply H ; auto. 
+  unfold ltof in *.
+  simpl in *.
+  PreOmega.zify.
+  intuition subst. assumption.
+  eapply Z.lt_le_trans. eassumption.
+  apply Z.add_le_mono_r. assumption.
+  (*/asser *)
+  destruct (HH _ H1) as [pr [Hin Hcheker]].
+  assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False).
+   eapply (H pr)  ;auto.
+   apply in_bdepth ; auto.
+  rewrite <- make_conj_impl in H2.
+  apply H2.
+  rewrite  make_conj_cons.
+  split ;auto.
+  unfold  eval_nformula.
+  unfold RingMicromega.eval_nformula.
+  simpl.
+  rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
+  unfold eval_pol. ring.
+  discriminate.
+  (* No cutting plane *)
+  intros.
+  rewrite <- make_conj_impl.
+  intros.
+  apply eval_Psatz_sound with (2:= Hf1) in H3.
+  apply genCuttingPlaneNone with (2:= H3) ; auto.
+  (* No Cutting plane (bis) *)
+  intros.
+  rewrite <- make_conj_impl.
+  intros.
+  apply eval_Psatz_sound with (2:= Hf2) in H2.
+  apply genCuttingPlaneNone with (2:= H2) ; auto.
+- intros l.
+  unfold ZChecker.
+  fold ZChecker.
+  set (fr := (max_var_nformulae l)%positive).
+  set (z1 := (Pos.succ fr)) in *.
+  set (t1 := (Pos.succ z1)) in *.
+  destruct (x <=? fr)%positive eqn:LE ; [|congruence].
+  intros.
+  set (env':= fun v => if Pos.eqb v z1
+                       then if Z.leb (env x) 0 then 0 else env x
+                       else if Pos.eqb v t1
+                            then if Z.leb (env x) 0 then -(env x) else 0
+                            else env v).
+  apply H with (env:=env') in H0.
+  + rewrite <- make_conj_impl in *.
+    intro.
+    rewrite !make_conj_cons in H0.
+    apply H0 ; repeat split.
+    *
+      apply eval_nformula_mk_eq_pos.
+      unfold env'.
+      rewrite! Pos.eqb_refl.
+      replace (x=?z1)%positive with false.
+      replace (x=?t1)%positive with false.
+      replace (t1=?z1)%positive with false.
+      destruct (env x <=? 0); ring.
+      { unfold t1.
+        pos_tac; normZ.
+        lia (Hyp H2).
+      }
+      {
+        unfold t1, z1.
+        pos_tac; normZ.
+        lia (Add (Hyp LE) (Hyp H3)).
+      }
+      {
+        unfold z1.
+        pos_tac; normZ.
+        lia (Add (Hyp LE) (Hyp H3)).
+      }
+    *
+      apply eval_nformula_bound_var.
+      unfold env'.
+      rewrite! Pos.eqb_refl.
+      destruct (env x <=? 0) eqn:EQ.
+      compute. congruence.
+      rewrite Z.leb_gt in EQ.
+      normZ.
+      lia (Add (Hyp EQ) (Hyp H2)).
+    *
+      apply eval_nformula_bound_var.
+      unfold env'.
+      rewrite! Pos.eqb_refl.
+      replace (t1 =? z1)%positive with false.
+      destruct (env x <=? 0) eqn:EQ.
+      rewrite Z.leb_le in EQ.
+      normZ.
+      lia (Add (Hyp EQ) (Hyp H2)).
+      compute; congruence.
+      unfold t1.
+      clear.
+      pos_tac; normZ.
+      lia (Hyp H).
+    *
+      rewrite agree_env_eval_nformulae with (env':= env') in H1;auto.
+      unfold agree_env; intros.
+      unfold env'.
+      replace (x0 =? z1)%positive with false.
+      replace (x0 =? t1)%positive with false.
+      reflexivity.
+      {
+        unfold t1, z1.
+        unfold fr in *.
+        apply Pos2Z.pos_le_pos in H2.
+        pos_tac; normZ.
+        lia (Add (Hyp H2) (Hyp H4)).
+      }
+      {
+        unfold z1, fr in *.
+        apply Pos2Z.pos_le_pos in H2.
+        pos_tac; normZ.
+        lia (Add (Hyp H2) (Hyp H4)).
+      }
+  + unfold ltof.
+    simpl.
+    apply Nat.lt_succ_diag_r.
+Qed.
+
+
+
+Definition ZTautoChecker  (f : BFormula (Formula Z)) (w: list ZArithProof): bool :=
+  @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate  ZArithProof (fun cl => ZChecker (List.map fst cl)) f w.
+
+Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_bf  (Zeval_formula env)  f.
+Proof.
+  intros f w.
+  unfold ZTautoChecker.
+  apply tauto_checker_sound with (eval' := eval_nformula).
+  - apply Zeval_nformula_dec.
+  - intros until env.
+  unfold eval_nformula. unfold RingMicromega.eval_nformula.
+  destruct t.
+  apply (check_inconsistent_sound Zsor ZSORaddon) ; auto.
+  - unfold Zdeduce. intros. revert H.
+     apply (nformula_plus_nformula_correct Zsor ZSORaddon); auto.
+  -
+    intros.
+    rewrite normalise_correct  in H.
+    auto.
+  -
+    intros.
+    rewrite negate_correct in H ; auto.
+  - intros t w0.
+    unfold eval_tt.
+    intros.
+    rewrite make_impl_map with (eval := eval_nformula env).
+    eapply ZChecker_sound; eauto.
+    tauto.
+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
+    | ExProof _ pt  =>  xhyps_of_pt (S (S (S base ))) acc pt
+  end.
+
+Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt.
+
+Open Scope Z_scope.
+
+(** To ease bindings from ml code **)
+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.Branch Z.
+Definition empty := @VarMap.Empty Z.
+Definition leaf := @VarMap.Elt Z.
+
+Definition coneMember := ZWitness.
+
+Definition eval := eval_formula.
+
+Definition prod_pos_nat := prod positive nat.
+
+Notation n_of_Z := Z.to_N (only parsing).
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
+
+
diff --git a/theories/micromega/Zify.v b/theories/micromega/Zify.v
new file mode 100644
index 0000000000..18cd196148
--- /dev/null
+++ b/theories/micromega/Zify.v
@@ -0,0 +1,90 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+Require Import ZifyClasses.
+Require Export ZifyInst.
+Require Import InitialRing.
+
+(** From PreOmega *)
+
+(** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *)
+
+Ltac zify_unop_core t thm a :=
+ (* Let's introduce the specification theorem for t *)
+ pose proof (thm a);
+ (* Then we replace (t a) everywhere with a fresh variable *)
+ let z := fresh "z" in set (z:=t a) in *; clearbody z.
+
+Ltac zify_unop_var_or_term t thm a :=
+ (* If a is a variable, no need for aliasing *)
+ let za := fresh "z" in
+ (rename a into za; rename za into a; zify_unop_core t thm a) ||
+ (* Otherwise, a is a complex term: we alias it. *)
+ (remember a as za; zify_unop_core t thm za).
+
+Ltac zify_unop t thm a :=
+ (* If a is a scalar, we can simply reduce the unop. *)
+ (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *)
+ let isz := isZcst a in
+ match isz with
+  | true =>
+    let u := eval compute in (t a) in
+    change (t a) with u in *
+  | _ => zify_unop_var_or_term t thm a
+ end.
+
+Ltac zify_unop_nored t thm a :=
+ (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *)
+ let isz := isZcst a in
+ match isz with
+  | true => zify_unop_core t thm a
+  | _ => zify_unop_var_or_term t thm a
+ end.
+
+Ltac zify_binop t thm a b:=
+ (* works as zify_unop, except that we should be careful when
+    dealing with b, since it can be equal to a *)
+ let isza := isZcst a in
+ match isza with
+   | true => zify_unop (t a) (thm a) b
+   | _ =>
+       let za := fresh "z" in
+       (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) ||
+       (remember a as za; match goal with
+         | H : za = b |- _ => zify_unop_nored (t za) (thm za) za
+         | _ => zify_unop_nored (t za) (thm za) b
+        end)
+ end.
+
+(* end from PreOmega *)
+
+Ltac applySpec S :=
+  let t := type of S in
+  match t with
+  | @BinOpSpec _ _ ?Op _ =>
+    let Spec := (eval unfold S, BSpec in (@BSpec _ _ Op _ S)) in
+    repeat
+      match goal with
+      | H : context[Op ?X ?Y] |- _ => zify_binop Op Spec X Y
+      | |- context[Op ?X ?Y]       => zify_binop Op Spec X Y
+      end
+  | @UnOpSpec _ _ ?Op _ =>
+    let Spec := (eval unfold S, USpec in (@USpec _ _ Op _ S)) in
+    repeat
+      match goal with
+      | H : context[Op ?X] |- _ => zify_unop Op Spec X
+      | |- context[Op ?X ]       => zify_unop Op Spec X
+      end
+  end.
+
+(** [zify_post_hook] is there to be redefined. *)
+Ltac zify_post_hook := idtac.
+
+Ltac zify := zify_op ; (zify_iter_specs applySpec) ; zify_post_hook.
diff --git a/theories/micromega/ZifyBool.v b/theories/micromega/ZifyBool.v
new file mode 100644
index 0000000000..4060478363
--- /dev/null
+++ b/theories/micromega/ZifyBool.v
@@ -0,0 +1,278 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+Require Import Bool ZArith.
+Require Import Zify ZifyClasses.
+Local Open Scope Z_scope.
+(* Instances of [ZifyClasses] for dealing with boolean operators.
+   Various encodings of boolean are possible.  One objective is to
+   have an encoding that is terse but also lia friendly.
+ *)
+
+(** [Z_of_bool] is the injection function for boolean *)
+Definition Z_of_bool (b : bool) : Z := if b then 1 else 0.
+
+(** [bool_of_Z] is a compatible reverse operation *)
+Definition bool_of_Z (z : Z) : bool := negb (Z.eqb z 0).
+
+Lemma Z_of_bool_bound : forall x,   0 <= Z_of_bool x <= 1.
+Proof.
+  destruct x ; simpl; compute; intuition congruence.
+Qed.
+
+Instance Inj_bool_Z : InjTyp bool Z :=
+  { inj := Z_of_bool ; pred :=(fun x => 0 <= x <= 1) ; cstr := Z_of_bool_bound}.
+Add InjTyp Inj_bool_Z.
+
+(** Boolean operators *)
+
+Instance Op_andb : BinOp andb :=
+  { TBOp := Z.min ;
+    TBOpInj := ltac: (destruct n,m; reflexivity)}.
+Add BinOp Op_andb.
+
+Instance Op_orb : BinOp orb :=
+  { TBOp := Z.max ;
+    TBOpInj := ltac:(destruct n,m; reflexivity)}.
+Add BinOp Op_orb.
+
+Instance Op_implb : BinOp implb :=
+  { TBOp := fun x y => Z.max (1 - x) y;
+    TBOpInj := ltac:(destruct n,m; reflexivity) }.
+Add BinOp Op_implb.
+
+Instance Op_xorb : BinOp xorb :=
+  { TBOp := fun x y => Z.max (x - y) (y - x);
+    TBOpInj := ltac:(destruct n,m; reflexivity) }.
+Add BinOp Op_xorb.
+
+Instance Op_negb : UnOp negb :=
+  { TUOp := fun x => 1 - x ; TUOpInj := ltac:(destruct x; reflexivity)}.
+Add UnOp Op_negb.
+
+Instance Op_eq_bool : BinRel (@eq bool) :=
+  {TR := @eq Z ; TRInj := ltac:(destruct n,m; simpl ; intuition congruence) }.
+Add BinRel Op_eq_bool.
+
+Instance Op_true : CstOp true :=
+  { TCst := 1 ; TCstInj := eq_refl }.
+Add CstOp Op_true.
+
+Instance Op_false : CstOp false :=
+  { TCst := 0 ; TCstInj := eq_refl }.
+Add CstOp Op_false.
+
+(** Comparisons are encoded using the predicates [isZero] and [isLeZero].*)
+
+Definition isZero (z : Z) := Z_of_bool (Z.eqb z 0).
+
+Definition isLeZero (x : Z) := Z_of_bool (Z.leb x 0).
+
+Instance Op_isZero : UnOp isZero :=
+  { TUOp := isZero; TUOpInj := ltac: (reflexivity) }.
+Add UnOp Op_isZero.
+
+Instance Op_isLeZero : UnOp isLeZero :=
+  { TUOp := isLeZero; TUOpInj := ltac: (reflexivity) }.
+Add UnOp Op_isLeZero.
+
+(* Some intermediate lemma *)
+
+Lemma Z_eqb_isZero : forall n m,
+    Z_of_bool (n =? m) = isZero (n - m).
+Proof.
+  intros ; unfold isZero.
+  destruct ( n =? m) eqn:EQ.
+  - simpl. rewrite Z.eqb_eq in EQ.
+    rewrite EQ. rewrite Z.sub_diag.
+    reflexivity.
+  -
+    destruct (n - m =? 0) eqn:EQ'.
+    rewrite Z.eqb_neq in EQ.
+    rewrite Z.eqb_eq in EQ'.
+    apply Zminus_eq in EQ'.
+    congruence.
+    reflexivity.
+Qed.
+
+Lemma Z_leb_sub : forall x y, x <=? y  = ((x - y) <=? 0).
+Proof.
+  intros.
+  destruct (x <=?y) eqn:B1 ;
+    destruct (x - y <=?0) eqn:B2 ; auto.
+  - rewrite Z.leb_le in B1.
+    rewrite Z.leb_nle in B2.
+    rewrite Z.le_sub_0 in B2. tauto.
+  - rewrite Z.leb_nle in B1.
+    rewrite Z.leb_le in B2.
+    rewrite Z.le_sub_0 in B2. tauto.
+Qed.
+
+Lemma Z_ltb_leb : forall x y, x <? y  = (x +1 <=? y).
+Proof.
+  intros.
+  destruct (x <?y) eqn:B1 ;
+    destruct (x + 1 <=?y) eqn:B2 ; auto.
+  - rewrite Z.ltb_lt in B1.
+    rewrite Z.leb_nle in B2.
+    apply Zorder.Zlt_le_succ in B1.
+    unfold Z.succ in B1.
+    tauto.
+  - rewrite Z.ltb_nlt in B1.
+    rewrite Z.leb_le in B2.
+    apply Zorder.Zle_lt_succ in B2.
+    unfold Z.succ in B2.
+    apply Zorder.Zplus_lt_reg_r in B2.
+    tauto.
+Qed.
+
+
+(** Comparison over Z *)
+
+Instance Op_Zeqb : BinOp Z.eqb :=
+  { TBOp := fun x y => isZero (Z.sub x y) ; TBOpInj := Z_eqb_isZero}.
+
+Instance Op_Zleb : BinOp Z.leb :=
+  { TBOp := fun x y => isLeZero (x-y) ;
+    TBOpInj :=
+      ltac: (intros;unfold isLeZero;
+               rewrite Z_leb_sub;
+               auto) }.
+Add BinOp Op_Zleb.
+
+Instance Op_Zgeb : BinOp Z.geb :=
+  { TBOp := fun x y => isLeZero (y-x) ;
+    TBOpInj := ltac:(
+                 intros;
+                   unfold isLeZero;
+                   rewrite Z.geb_leb;
+                   rewrite Z_leb_sub;
+                   auto) }.
+Add BinOp Op_Zgeb.
+
+Instance Op_Zltb : BinOp Z.ltb :=
+  { TBOp := fun x y => isLeZero (x+1-y) ;
+    TBOpInj := ltac:(
+                 intros;
+                   unfold isLeZero;
+                   rewrite Z_ltb_leb;
+                   rewrite <- Z_leb_sub;
+                   reflexivity) }.
+
+Instance Op_Zgtb : BinOp Z.gtb :=
+  { TBOp := fun x y => isLeZero (y-x+1) ;
+    TBOpInj := ltac:(
+                 intros;
+                   unfold isLeZero;
+                   rewrite Z.gtb_ltb;
+                   rewrite Z_ltb_leb;
+                   rewrite Z_leb_sub;
+                   rewrite Z.add_sub_swap;
+                   reflexivity) }.
+Add BinOp Op_Zgtb.
+
+(** Comparison over nat *)
+
+
+Lemma Z_of_nat_eqb_iff : forall n m,
+    (n =? m)%nat = (Z.of_nat n =? Z.of_nat m).
+Proof.
+  intros.
+  rewrite Nat.eqb_compare.
+  rewrite Z.eqb_compare.
+  rewrite Nat2Z.inj_compare.
+  reflexivity.
+Qed.
+
+Lemma Z_of_nat_leb_iff : forall n m,
+    (n <=? m)%nat = (Z.of_nat n <=? Z.of_nat m).
+Proof.
+  intros.
+  rewrite Nat.leb_compare.
+  rewrite Z.leb_compare.
+  rewrite Nat2Z.inj_compare.
+  reflexivity.
+Qed.
+
+Lemma Z_of_nat_ltb_iff : forall n m,
+    (n <? m)%nat = (Z.of_nat n <? Z.of_nat m).
+Proof.
+  intros.
+  rewrite Nat.ltb_compare.
+  rewrite Z.ltb_compare.
+  rewrite Nat2Z.inj_compare.
+  reflexivity.
+Qed.
+
+Instance Op_nat_eqb : BinOp Nat.eqb :=
+   { TBOp := fun x y => isZero (Z.sub x y) ;
+     TBOpInj := ltac:(
+                  intros; simpl;
+                    rewrite  <- Z_eqb_isZero;
+                  f_equal; apply Z_of_nat_eqb_iff) }.
+Add BinOp Op_nat_eqb.
+
+Instance Op_nat_leb : BinOp Nat.leb :=
+  { TBOp := fun x y => isLeZero (x-y) ;
+    TBOpInj := ltac:(
+                 intros;
+                 rewrite Z_of_nat_leb_iff;
+                 unfold isLeZero;
+                 rewrite Z_leb_sub;
+                 auto) }.
+Add BinOp Op_nat_leb.
+
+Instance Op_nat_ltb : BinOp Nat.ltb :=
+  { TBOp := fun x y => isLeZero (x+1-y) ;
+     TBOpInj := ltac:(
+                  intros;
+                  rewrite Z_of_nat_ltb_iff;
+                    unfold isLeZero;
+                    rewrite Z_ltb_leb;
+                    rewrite <- Z_leb_sub;
+                    reflexivity) }.
+Add BinOp Op_nat_ltb.
+
+(** Injected boolean operators *)
+
+Lemma Z_eqb_ZSpec_ok : forall x,  0 <= isZero x <= 1 /\
+                                  (x = 0 <-> isZero x = 1).
+Proof.
+  intros.
+  unfold isZero.
+  destruct (x =? 0) eqn:EQ.
+  -  apply Z.eqb_eq in EQ.
+     simpl. intuition try congruence;
+     compute ; congruence.
+  - apply Z.eqb_neq in EQ.
+    simpl. intuition try congruence;
+             compute ; congruence.
+Qed.
+
+
+Instance Z_eqb_ZSpec : UnOpSpec isZero :=
+  {| UPred := fun n r => 0 <= r <= 1 /\ (n = 0 <-> isZero n = 1) ; USpec := Z_eqb_ZSpec_ok |}.
+Add Spec Z_eqb_ZSpec.
+
+Lemma leZeroSpec_ok : forall x,  x <= 0 /\ isLeZero x = 1 \/ x > 0 /\ isLeZero x = 0.
+Proof.
+  intros.
+  unfold isLeZero.
+  destruct (x <=? 0) eqn:EQ.
+  -  apply Z.leb_le in EQ.
+     simpl. intuition congruence.
+  -  simpl.
+     apply Z.leb_nle in EQ.
+     apply Zorder.Znot_le_gt in EQ.
+     tauto.
+Qed.
+
+Instance leZeroSpec : UnOpSpec isLeZero :=
+  {| UPred := fun n r => (n<=0 /\ r = 1) \/ (n > 0 /\ r = 0) ; USpec := leZeroSpec_ok|}.
+Add Spec leZeroSpec.
diff --git a/theories/micromega/ZifyClasses.v b/theories/micromega/ZifyClasses.v
new file mode 100644
index 0000000000..d3f7f91074
--- /dev/null
+++ b/theories/micromega/ZifyClasses.v
@@ -0,0 +1,232 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+Set Primitive Projections.
+
+(** An alternative to [zify] in ML parametrised by user-provided classes instances.
+
+    The framework has currently several limitations that are in place for simplicity.
+    For instance, we only consider binary operators of type [Op: S -> S -> S].
+    Another limitation is that our injection theorems e.g. [TBOpInj],
+    are using Leibniz equality; the payoff is that there is no need for morphisms...
+ *)
+
+(** An injection [InjTyp S T] declares an injection
+    from source type S to target type T.
+*)
+Class InjTyp (S : Type) (T : Type) :=
+  mkinj {
+      (* [inj] is the injection function *)
+      inj  : S -> T;
+      pred : T -> Prop;
+      (* [cstr] states that [pred] holds for any injected element.
+         [cstr (inj x)] is introduced in the goal for any leaf
+         term of the form [inj x]
+       *)
+      cstr : forall x, pred (inj x)
+    }.
+
+(** [BinOp Op] declares a source operator [Op: S1 -> S2 -> S3].
+ *)
+Class BinOp {S1 S2 S3:Type} {T:Type} (Op : S1 -> S2 -> S3) {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} {I3 : InjTyp S3 T} :=
+  mkbop {
+      (* [TBOp] is the target operator after injection of operands. *)
+      TBOp : T -> T -> T;
+      (* [TBOpInj] states the correctness of the injection. *)
+      TBOpInj : forall (n:S1) (m:S2), inj (Op n m) = TBOp (inj n) (inj m)
+    }.
+
+(** [Unop Op] declares a source operator [Op : S1 -> S2]. *)
+Class UnOp {S1 S2 T:Type} (Op : S1 -> S2) {I1 : InjTyp S1 T} {I2 : InjTyp S2 T}  :=
+  mkuop {
+      (* [TUOp] is the target operator after injection of operands. *)
+      TUOp : T -> T;
+      (* [TUOpInj] states the correctness of the injection. *)
+      TUOpInj : forall (x:S1), inj (Op x) = TUOp (inj x)
+    }.
+
+(** [CstOp Op] declares a source constant [Op : S]. *)
+Class CstOp {S T:Type} (Op : S) {I : InjTyp S T} :=
+  mkcst {
+      (* [TCst] is the target constant. *)
+      TCst : T;
+      (* [TCstInj] states the correctness of the injection. *)
+      TCstInj : inj Op = TCst
+    }.
+
+(** In the framework, [Prop] is mapped to [Prop] and the injection is phrased in
+    terms  of [=] instead of [<->].
+*)
+
+(** [BinRel R] declares the injection of a binary relation. *)
+Class BinRel {S:Type} {T:Type} (R : S -> S -> Prop) {I : InjTyp S T}  :=
+    mkbrel {
+        TR : T -> T -> Prop;
+        TRInj : forall n m : S, R n m <->  TR (@inj _ _ I n) (inj m)
+      }.
+
+(** [PropOp Op] declares morphisms for [<->].
+    This will be used to deal with e.g. [and], [or],... *)
+Class PropOp (Op : Prop -> Prop -> Prop) :=
+  mkprop {
+      op_iff : forall (p1 p2 q1 q2:Prop), (p1 <-> q1) -> (p2 <-> q2) -> (Op p1 p2 <-> Op q1 q2)
+    }.
+
+Class PropUOp (Op : Prop -> Prop) :=
+  mkuprop {
+      uop_iff : forall (p1 q1 :Prop), (p1 <-> q1) -> (Op p1 <-> Op q1)
+    }.
+
+
+
+(** Once the term is injected, terms can be replaced by their specification.
+    NB1: The Ltac code is currently limited to (Op: Z -> Z -> Z)
+    NB2: This is not sufficient to cope with [Z.div] or [Z.mod]
+ *)
+Class BinOpSpec {S T: Type} (Op : T -> T -> T) {I : InjTyp S T} :=
+  mkbspec {
+      BPred : T -> T -> T -> Prop;
+      BSpec : forall x y, BPred x y (Op x y)
+    }.
+
+Class UnOpSpec {S T: Type} (Op : T -> T) {I : InjTyp S T} :=
+  mkuspec {
+      UPred : T -> T -> Prop;
+      USpec : forall x, UPred x (Op x)
+    }.
+
+(** After injections, e.g. nat -> Z,
+    the fact that Z.of_nat x * Z.of_nat y is positive is lost.
+    This information can be recovered using instance of the  [Saturate] class.
+*)
+Class Saturate {T: Type} (Op : T -> T -> T) :=
+  mksat {
+      (** Given [Op x y],
+          - [PArg1] is the pre-condition of x
+          - [PArg2] is the pre-condition of y
+          - [PRes]  is the pos-condition of (Op x y) *)
+      PArg1 : T -> Prop;
+      PArg2 : T -> Prop;
+      PRes  : T -> Prop;
+      (** [SatOk] states the correctness of the reasoning *)
+      SatOk : forall x y, PArg1 x -> PArg2 y -> PRes (Op x y)
+    }.
+(* The [ZifyInst.saturate] iterates over all the instances
+   and for every pattern of the form
+   [H1 : PArg1 ?x , H2 : PArg2 ?y , T : context[Op ?x ?y] |- _ ]
+   [H1 : PArg1 ?x , H2 : PArg2 ?y |- context[Op ?x ?y] ]
+   asserts  (SatOK x y H1 H2) *)
+
+(** The rest of the file is for internal use by the ML tactic.
+    There are  data-structures and lemmas used to inductively construct
+    the injected terms. *)
+
+(** The data-structures [injterm] and [injected_prop]
+    are used to store source and target expressions together
+    with a correctness proof. *)
+
+Record injterm {S T: Type} {I : S -> T} :=
+  mkinjterm { source : S ; target : T ; inj_ok : I source = target}.
+
+Record injprop  :=
+  mkinjprop {
+      source_prop : Prop ; target_prop : Prop ;
+      injprop_ok : source_prop <-> target_prop}.
+
+(** Lemmas for building [injterm] and [injprop]. *)
+
+Definition mkprop_op  (Op : Prop -> Prop -> Prop) (POp : PropOp Op)
+           (p1 :injprop) (p2: injprop) : injprop :=
+  {| source_prop := (Op (source_prop p1) (source_prop p2)) ;
+     target_prop := (Op (target_prop p1) (target_prop p2)) ;
+     injprop_ok  := (op_iff (source_prop p1) (source_prop p2) (target_prop p1) (target_prop p2)
+                            (injprop_ok p1) (injprop_ok p2))
+  |}.
+
+
+Definition mkuprop_op  (Op : Prop -> Prop) (POp : PropUOp Op)
+           (p1 :injprop)  : injprop :=
+  {| source_prop := (Op (source_prop p1)) ;
+     target_prop := (Op (target_prop p1)) ;
+     injprop_ok  := (uop_iff (source_prop p1) (target_prop p1)  (injprop_ok p1))
+  |}.
+
+
+Lemma mkapp2 (S1 S2 S3 T : Type) (Op : S1 -> S2 -> S3)
+      {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} {I3 : InjTyp S3 T}
+         (B : @BinOp S1 S2 S3 T Op I1 I2 I3)
+         (t1 : @injterm S1 T inj) (t2 : @injterm S2 T inj)
+         : @injterm S3 T inj.
+Proof.
+  apply (mkinjterm _ _ inj (Op (source t1) (source t2)) (TBOp (target t1) (target t2))).
+   (rewrite <- inj_ok;
+    rewrite <- inj_ok;
+    apply TBOpInj).
+Defined.
+
+Lemma mkapp (S1 S2 T : Type) (Op : S1 -> S2)
+      {I1 : InjTyp S1 T}
+      {I2 : InjTyp S2 T}
+      (B : @UnOp S1 S2 T Op I1 I2 )
+      (t1 : @injterm S1 T inj)
+         : @injterm S2 T inj.
+Proof.
+  apply (mkinjterm _ _ inj (Op (source t1)) (TUOp (target t1))).
+  (rewrite <- inj_ok; apply TUOpInj).
+Defined.
+
+Lemma mkapp0 (S T : Type) (Op : S)
+      {I : InjTyp S T}
+      (B : @CstOp S T Op I)
+         : @injterm S T inj.
+Proof.
+  apply (mkinjterm _ _ inj Op  TCst).
+   (apply TCstInj).
+Defined.
+
+Lemma mkrel (S T : Type) (R : S -> S -> Prop)
+         {Inj : InjTyp S T}
+         (B : @BinRel S T R Inj)
+         (t1 : @injterm S T inj) (t2 : @injterm S T inj)
+         : @injprop.
+Proof.
+  apply (mkinjprop  (R (source t1) (source t2)) (TR (target t1) (target t2))).
+  (rewrite <- inj_ok; rewrite <- inj_ok;apply TRInj).
+Defined.
+
+(** Registering constants for use by the plugin *)
+Register target_prop as ZifyClasses.target_prop.
+Register mkrel       as ZifyClasses.mkrel.
+Register target      as ZifyClasses.target.
+Register mkapp2      as ZifyClasses.mkapp2.
+Register mkapp       as ZifyClasses.mkapp.
+Register mkapp0      as ZifyClasses.mkapp0.
+Register op_iff      as ZifyClasses.op_iff.
+Register uop_iff     as ZifyClasses.uop_iff.
+Register TR          as ZifyClasses.TR.
+Register TBOp        as ZifyClasses.TBOp.
+Register TUOp        as ZifyClasses.TUOp.
+Register TCst        as ZifyClasses.TCst.
+Register mkprop_op   as ZifyClasses.mkprop_op.
+Register mkuprop_op  as ZifyClasses.mkuprop_op.
+Register injprop_ok  as ZifyClasses.injprop_ok.
+Register inj_ok      as ZifyClasses.inj_ok.
+Register source      as ZifyClasses.source.
+Register source_prop as ZifyClasses.source_prop.
+Register inj         as ZifyClasses.inj.
+Register TRInj       as ZifyClasses.TRInj.
+Register TUOpInj     as ZifyClasses.TUOpInj.
+Register not         as ZifyClasses.not.
+Register mkinjterm   as ZifyClasses.mkinjterm.
+Register eq_refl     as ZifyClasses.eq_refl.
+Register mkinjprop   as ZifyClasses.mkinjprop.
+Register iff_refl    as ZifyClasses.iff_refl.
+Register source_prop as ZifyClasses.source_prop.
+Register injprop_ok  as ZifyClasses.injprop_ok.
+Register iff         as ZifyClasses.iff.
diff --git a/theories/micromega/ZifyComparison.v b/theories/micromega/ZifyComparison.v
new file mode 100644
index 0000000000..df75cf2c05
--- /dev/null
+++ b/theories/micromega/ZifyComparison.v
@@ -0,0 +1,82 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+Require Import Bool ZArith.
+Require Import Zify ZifyClasses.
+Require Import Lia.
+Local Open Scope Z_scope.
+
+(** [Z_of_comparison] is the injection function for comparison *)
+Definition Z_of_comparison (c : comparison) : Z :=
+  match c with
+  | Lt => -1
+  | Eq => 0
+  | Gt => 1
+  end.
+
+Lemma Z_of_comparison_bound : forall x,   -1 <= Z_of_comparison x <= 1.
+Proof.
+  destruct x ; simpl; compute; intuition congruence.
+Qed.
+
+Instance Inj_comparison_Z : InjTyp comparison Z :=
+  { inj := Z_of_comparison ; pred :=(fun x => -1 <= x <= 1) ; cstr := Z_of_comparison_bound}.
+Add InjTyp Inj_comparison_Z.
+
+Definition ZcompareZ (x y : Z) :=
+  Z_of_comparison (Z.compare x y).
+
+Program Instance BinOp_Zcompare : BinOp Z.compare :=
+  { TBOp := ZcompareZ }.
+Add BinOp BinOp_Zcompare.
+
+Instance Op_eq_comparison : BinRel (@eq comparison) :=
+  {TR := @eq Z ; TRInj := ltac:(destruct n,m; simpl ; intuition congruence) }.
+Add BinRel Op_eq_comparison.
+
+Instance Op_Eq : CstOp Eq :=
+  { TCst := 0 ; TCstInj := eq_refl }.
+Add CstOp Op_Eq.
+
+Instance Op_Lt : CstOp Lt :=
+  { TCst := -1 ; TCstInj := eq_refl }.
+Add CstOp Op_Lt.
+
+Instance Op_Gt : CstOp Gt :=
+  { TCst := 1 ; TCstInj := eq_refl }.
+Add CstOp Op_Gt.
+
+
+Lemma Zcompare_spec : forall x y,
+    (x = y -> ZcompareZ x y = 0)
+    /\
+    (x > y -> ZcompareZ x y = 1)
+    /\
+    (x < y  -> ZcompareZ x y = -1).
+Proof.
+  unfold ZcompareZ.
+  intros.
+  destruct (x ?= y) eqn:C; simpl.
+  - rewrite Z.compare_eq_iff in C.
+    lia.
+  - rewrite Z.compare_lt_iff in C.
+    lia.
+  - rewrite Z.compare_gt_iff in C.
+    lia.
+Qed.
+
+Instance ZcompareSpec : BinOpSpec ZcompareZ :=
+  {| BPred := fun x y r => (x = y -> r = 0)
+                           /\
+                           (x > y -> r = 1)
+                           /\
+                           (x < y  -> r = -1)
+              ; BSpec := Zcompare_spec|}.
+Add Spec ZcompareSpec.
diff --git a/theories/micromega/ZifyInst.v b/theories/micromega/ZifyInst.v
new file mode 100644
index 0000000000..edfb5a2a94
--- /dev/null
+++ b/theories/micromega/ZifyInst.v
@@ -0,0 +1,544 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(* Instances of [ZifyClasses] for emulating the existing zify.
+   Each instance is registered using a Add 'class' 'name_of_instance'.
+ *)
+
+Require Import Arith Max Min BinInt BinNat Znat Nnat.
+Require Import ZifyClasses.
+Declare ML Module "zify_plugin".
+Local Open Scope Z_scope.
+
+(** Propositional logic *)
+Instance PropAnd : PropOp and.
+Proof.
+  constructor.
+  tauto.
+Defined.
+Add PropOp PropAnd.
+
+Instance PropOr : PropOp or.
+Proof.
+  constructor.
+  tauto.
+Defined.
+Add PropOp PropOr.
+
+Instance PropArrow : PropOp (fun x y => x -> y).
+Proof.
+  constructor.
+  intros.
+  tauto.
+Defined.
+Add PropOp PropArrow.
+
+Instance PropIff : PropOp iff.
+Proof.
+  constructor.
+  intros.
+  tauto.
+Defined.
+Add PropOp PropIff.
+
+Instance PropNot : PropUOp not.
+Proof.
+  constructor.
+  intros.
+  tauto.
+Defined.
+Add PropUOp PropNot.
+
+
+Instance Inj_Z_Z : InjTyp Z Z :=
+  mkinj _ _ (fun x => x) (fun x =>  True ) (fun _ => I).
+Add InjTyp Inj_Z_Z.
+
+(** Support for nat *)
+
+Instance Inj_nat_Z : InjTyp nat Z :=
+  mkinj _ _ Z.of_nat (fun x =>  0 <= x ) Nat2Z.is_nonneg.
+Add InjTyp Inj_nat_Z.
+
+(* zify_nat_rel *)
+Instance Op_ge : BinRel ge :=
+  {| TR := Z.ge; TRInj := Nat2Z.inj_ge |}.
+Add BinRel Op_ge.
+
+Instance Op_lt : BinRel lt :=
+  {| TR := Z.lt; TRInj := Nat2Z.inj_lt |}.
+Add BinRel Op_lt.
+
+Instance Op_gt : BinRel gt :=
+  {| TR := Z.gt; TRInj := Nat2Z.inj_gt |}.
+Add BinRel Op_gt.
+
+Instance Op_le : BinRel le :=
+  {| TR := Z.le; TRInj := Nat2Z.inj_le |}.
+Add BinRel Op_le.
+
+Instance Op_eq_nat : BinRel (@eq nat) :=
+  {| TR := @eq Z ; TRInj := fun x y : nat => iff_sym (Nat2Z.inj_iff x y) |}.
+Add BinRel Op_eq_nat.
+
+(* zify_nat_op *)
+Instance Op_plus : BinOp Nat.add :=
+  {| TBOp := Z.add; TBOpInj := Nat2Z.inj_add |}.
+Add BinOp Op_plus.
+
+Instance Op_sub : BinOp Nat.sub :=
+  {| TBOp := fun n m => Z.max 0 (n - m) ; TBOpInj := Nat2Z.inj_sub_max |}.
+Add BinOp Op_sub.
+
+Instance Op_mul : BinOp Nat.mul :=
+  {| TBOp := Z.mul ; TBOpInj := Nat2Z.inj_mul |}.
+Add BinOp Op_mul.
+
+Instance Op_min : BinOp Nat.min :=
+  {| TBOp := Z.min ; TBOpInj := Nat2Z.inj_min |}.
+Add BinOp Op_min.
+
+Instance Op_max : BinOp Nat.max :=
+  {| TBOp := Z.max ; TBOpInj := Nat2Z.inj_max |}.
+Add BinOp Op_max.
+
+Instance Op_pred : UnOp Nat.pred :=
+  {| TUOp := fun n => Z.max 0 (n - 1) ; TUOpInj := Nat2Z.inj_pred_max |}.
+Add UnOp Op_pred.
+
+Instance Op_S : UnOp S :=
+  {| TUOp := fun x => Z.add x 1 ; TUOpInj := Nat2Z.inj_succ |}.
+Add UnOp Op_S.
+
+Instance Op_O : CstOp O :=
+  {| TCst := Z0 ; TCstInj := eq_refl (Z.of_nat 0) |}.
+Add CstOp Op_O.
+
+Instance Op_Z_abs_nat : UnOp  Z.abs_nat :=
+  { TUOp := Z.abs ; TUOpInj := Zabs2Nat.id_abs }.
+Add UnOp Op_Z_abs_nat.
+
+(** Support for positive *)
+
+Instance Inj_pos_Z : InjTyp positive Z :=
+  {| inj := Zpos ; pred := (fun x =>  0 < x ) ; cstr := Pos2Z.pos_is_pos |}.
+Add InjTyp Inj_pos_Z.
+
+Instance Op_pos_to_nat : UnOp  Pos.to_nat :=
+  {TUOp := (fun x => x); TUOpInj := positive_nat_Z}.
+Add UnOp Op_pos_to_nat.
+
+Instance Inj_N_Z : InjTyp N Z :=
+  mkinj _ _ Z.of_N (fun x =>  0 <= x ) N2Z.is_nonneg.
+Add InjTyp Inj_N_Z.
+
+
+Instance Op_N_to_nat : UnOp  N.to_nat :=
+  { TUOp := fun x => x ; TUOpInj := N_nat_Z }.
+Add UnOp Op_N_to_nat.
+
+(* zify_positive_rel *)
+
+Instance Op_pos_ge : BinRel Pos.ge :=
+  {| TR := Z.ge; TRInj := fun x y => iff_refl (Z.pos x >= Z.pos y) |}.
+Add BinRel Op_pos_ge.
+
+Instance Op_pos_lt : BinRel Pos.lt :=
+  {| TR := Z.lt; TRInj := fun x y => iff_refl (Z.pos x < Z.pos y) |}.
+Add BinRel Op_pos_lt.
+
+Instance Op_pos_gt : BinRel Pos.gt :=
+  {| TR := Z.gt; TRInj := fun x y => iff_refl (Z.pos x > Z.pos y)  |}.
+Add BinRel Op_pos_gt.
+
+Instance Op_pos_le : BinRel Pos.le :=
+  {| TR := Z.le; TRInj := fun x y => iff_refl (Z.pos x <= Z.pos y) |}.
+Add BinRel Op_pos_le.
+
+Instance Op_eq_pos : BinRel (@eq positive) :=
+  {| TR := @eq Z ; TRInj := fun x y  => iff_sym (Pos2Z.inj_iff x y) |}.
+Add BinRel Op_eq_pos.
+
+(* zify_positive_op *)
+
+
+Instance Op_Z_of_N : UnOp Z.of_N :=
+  { TUOp := (fun x => x) ; TUOpInj := fun x => eq_refl (Z.of_N x) }.
+Add UnOp Op_Z_of_N.
+
+Instance Op_Z_to_N : UnOp Z.to_N :=
+  { TUOp := fun x => Z.max 0 x ; TUOpInj := ltac:(now intro x; destruct x) }.
+Add UnOp Op_Z_to_N.
+
+Instance Op_Z_neg : UnOp Z.neg :=
+  { TUOp :=  Z.opp ; TUOpInj := (fun x => eq_refl (Zneg x))}.
+Add UnOp Op_Z_neg.
+
+Instance Op_Z_pos : UnOp Z.pos :=
+  { TUOp := (fun x =>  x) ; TUOpInj := (fun x => eq_refl (Z.pos x))}.
+Add UnOp Op_Z_pos.
+
+Instance Op_pos_succ : UnOp Pos.succ :=
+  { TUOp := fun x => x + 1; TUOpInj := Pos2Z.inj_succ  }.
+Add UnOp Op_pos_succ.
+
+Instance Op_pos_pred_double : UnOp Pos.pred_double :=
+  { TUOp := fun x => 2 * x - 1; TUOpInj := ltac:(reflexivity) }.
+Add UnOp Op_pos_pred_double.
+
+Instance Op_pos_pred : UnOp Pos.pred :=
+  { TUOp := fun x => Z.max 1 (x - 1) ;
+    TUOpInj := ltac :
+                 (intros;
+                    rewrite <- Pos.sub_1_r;
+                    apply Pos2Z.inj_sub_max) }.
+Add UnOp Op_pos_pred.
+
+Instance Op_pos_predN : UnOp Pos.pred_N :=
+  { TUOp := fun x => x - 1 ;
+    TUOpInj := ltac: (now destruct x; rewrite N.pos_pred_spec) }.
+Add UnOp Op_pos_predN.
+
+Instance Op_pos_of_succ_nat : UnOp Pos.of_succ_nat :=
+  { TUOp := fun x => x + 1 ; TUOpInj := Zpos_P_of_succ_nat }.
+Add UnOp Op_pos_of_succ_nat.
+
+Instance Op_pos_of_nat : UnOp Pos.of_nat :=
+  { TUOp := fun x => Z.max 1 x ;
+    TUOpInj := ltac: (now destruct x;
+                        [|rewrite <- Pos.of_nat_succ, <- (Nat2Z.inj_max 1)]) }.
+Add UnOp Op_pos_of_nat.
+
+Instance Op_pos_add : BinOp Pos.add :=
+  { TBOp := Z.add ; TBOpInj := ltac: (reflexivity) }.
+Add BinOp Op_pos_add.
+
+Instance Op_pos_add_carry : BinOp Pos.add_carry :=
+  { TBOp := fun x y => x + y + 1 ;
+    TBOpInj := ltac:(now intros; rewrite Pos.add_carry_spec, Pos2Z.inj_succ) }.
+Add BinOp Op_pos_add_carry.
+
+Instance Op_pos_sub : BinOp Pos.sub :=
+  { TBOp := fun n m => Z.max 1 (n - m) ;TBOpInj := Pos2Z.inj_sub_max }.
+Add BinOp Op_pos_sub.
+
+Instance Op_pos_mul : BinOp Pos.mul :=
+  { TBOp :=  Z.mul ; TBOpInj := ltac: (reflexivity) }.
+Add BinOp Op_pos_mul.
+
+Instance Op_pos_min : BinOp Pos.min :=
+  { TBOp := Z.min ; TBOpInj := Pos2Z.inj_min }.
+Add BinOp Op_pos_min.
+
+Instance Op_pos_max : BinOp Pos.max :=
+  { TBOp := Z.max ; TBOpInj := Pos2Z.inj_max }.
+Add BinOp Op_pos_max.
+
+Instance Op_pos_pow : BinOp Pos.pow :=
+  { TBOp := Z.pow ; TBOpInj := Pos2Z.inj_pow }.
+Add BinOp Op_pos_pow.
+
+Instance Op_pos_square : UnOp Pos.square :=
+  { TUOp := Z.square ; TUOpInj := Pos2Z.inj_square }.
+Add UnOp Op_pos_square.
+
+Instance Op_xO : UnOp xO :=
+  { TUOp := fun x => 2 * x ; TUOpInj := ltac: (reflexivity) }.
+Add UnOp Op_xO.
+
+Instance Op_xI : UnOp xI :=
+  { TUOp := fun x => 2 * x + 1 ; TUOpInj := ltac: (reflexivity) }.
+Add UnOp Op_xI.
+
+Instance Op_xH : CstOp xH :=
+  { TCst := 1%Z ; TCstInj := ltac:(reflexivity)}.
+Add CstOp Op_xH.
+
+Instance Op_Z_of_nat : UnOp Z.of_nat:=
+  { TUOp := fun x => x ; TUOpInj := ltac:(reflexivity) }.
+Add UnOp Op_Z_of_nat.
+
+(* zify_N_rel *)
+Instance Op_N_ge : BinRel N.ge :=
+  {| TR := Z.ge ; TRInj := N2Z.inj_ge |}.
+Add BinRel Op_N_ge.
+
+Instance Op_N_lt : BinRel N.lt :=
+  {| TR := Z.lt ; TRInj := N2Z.inj_lt |}.
+Add BinRel Op_N_lt.
+
+Instance Op_N_gt : BinRel N.gt :=
+  {| TR := Z.gt ; TRInj := N2Z.inj_gt |}.
+Add BinRel Op_N_gt.
+
+Instance Op_N_le : BinRel N.le :=
+  {| TR := Z.le ; TRInj := N2Z.inj_le |}.
+Add BinRel Op_N_le.
+
+Instance Op_eq_N : BinRel (@eq N) :=
+  {| TR := @eq Z ; TRInj := fun x y : N => iff_sym (N2Z.inj_iff x y) |}.
+Add BinRel Op_eq_N.
+
+(* zify_N_op *)
+Instance Op_N_of_nat : UnOp  N.of_nat :=
+  { TUOp := fun x => x ; TUOpInj := nat_N_Z }.
+Add UnOp Op_N_of_nat.
+
+Instance Op_Z_abs_N : UnOp Z.abs_N :=
+  { TUOp := Z.abs ; TUOpInj := N2Z.inj_abs_N }.
+Add UnOp Op_Z_abs_N.
+
+Instance Op_N_pos : UnOp N.pos :=
+  { TUOp := fun x => x ; TUOpInj := ltac:(reflexivity)}.
+Add UnOp Op_N_pos.
+
+Instance Op_N_add : BinOp N.add :=
+  {| TBOp := Z.add ; TBOpInj := N2Z.inj_add |}.
+Add BinOp Op_N_add.
+
+Instance Op_N_min : BinOp N.min :=
+  {| TBOp := Z.min ; TBOpInj := N2Z.inj_min |}.
+Add BinOp Op_N_min.
+
+Instance Op_N_max : BinOp N.max :=
+  {| TBOp := Z.max ; TBOpInj := N2Z.inj_max |}.
+Add BinOp Op_N_max.
+
+Instance Op_N_mul : BinOp N.mul :=
+  {| TBOp := Z.mul ; TBOpInj := N2Z.inj_mul |}.
+Add BinOp Op_N_mul.
+
+Instance Op_N_sub : BinOp N.sub :=
+  {| TBOp := fun x y => Z.max 0 (x - y) ; TBOpInj := N2Z.inj_sub_max|}.
+Add BinOp Op_N_sub.
+
+Instance Op_N_div : BinOp N.div :=
+  {| TBOp := Z.div ; TBOpInj := N2Z.inj_div|}.
+Add BinOp Op_N_div.
+
+Instance Op_N_mod : BinOp N.modulo :=
+  {| TBOp := Z.rem ; TBOpInj := N2Z.inj_rem|}.
+Add BinOp Op_N_mod.
+
+Instance Op_N_pred : UnOp N.pred :=
+  { TUOp := fun x  => Z.max 0 (x - 1) ;
+    TUOpInj :=
+      ltac:(intros; rewrite N.pred_sub; apply N2Z.inj_sub_max) }.
+Add UnOp Op_N_pred.
+
+Instance Op_N_succ : UnOp N.succ :=
+  {| TUOp := fun x => x + 1 ; TUOpInj := N2Z.inj_succ |}.
+Add UnOp Op_N_succ.
+
+(** Support for Z - injected to itself *)
+
+(* zify_Z_rel *)
+Instance Op_Z_ge : BinRel Z.ge :=
+  {| TR := Z.ge ; TRInj := fun x y  => iff_refl (x>= y)|}.
+Add BinRel Op_Z_ge.
+
+Instance Op_Z_lt : BinRel Z.lt :=
+  {| TR := Z.lt ;  TRInj := fun x y  => iff_refl (x < y)|}.
+Add BinRel Op_Z_lt.
+
+Instance Op_Z_gt : BinRel Z.gt :=
+  {| TR := Z.gt ;TRInj := fun x y  => iff_refl (x > y)|}.
+Add BinRel Op_Z_gt.
+
+Instance Op_Z_le : BinRel Z.le :=
+  {| TR := Z.le ;TRInj := fun x y  => iff_refl (x <= y)|}.
+Add BinRel Op_Z_le.
+
+Instance Op_eqZ : BinRel (@eq Z) :=
+  { TR := @eq Z ; TRInj := fun x y  => iff_refl (x = y) }.
+Add BinRel Op_eqZ.
+
+Instance Op_Z_add : BinOp Z.add :=
+  { TBOp := Z.add  ; TBOpInj := ltac:(reflexivity) }.
+Add BinOp Op_Z_add.
+
+Instance Op_Z_min : BinOp Z.min :=
+  { TBOp := Z.min ; TBOpInj := ltac:(reflexivity) }.
+Add BinOp Op_Z_min.
+
+Instance Op_Z_max : BinOp Z.max :=
+  { TBOp := Z.max ; TBOpInj := ltac:(reflexivity) }.
+Add BinOp Op_Z_max.
+
+Instance Op_Z_mul : BinOp Z.mul :=
+  { TBOp := Z.mul ; TBOpInj := ltac:(reflexivity) }.
+Add BinOp Op_Z_mul.
+
+Instance Op_Z_sub : BinOp Z.sub :=
+  { TBOp := Z.sub ; TBOpInj := ltac:(reflexivity) }.
+Add BinOp Op_Z_sub.
+
+Instance Op_Z_div : BinOp Z.div :=
+  { TBOp := Z.div ; TBOpInj := ltac:(reflexivity) }.
+Add BinOp Op_Z_div.
+
+Instance Op_Z_mod : BinOp Z.modulo :=
+  { TBOp := Z.modulo ; TBOpInj := ltac:(reflexivity) }.
+Add BinOp Op_Z_mod.
+
+Instance Op_Z_rem : BinOp Z.rem :=
+  { TBOp := Z.rem ; TBOpInj := ltac:(reflexivity) }.
+Add BinOp Op_Z_rem.
+
+Instance Op_Z_quot : BinOp Z.quot :=
+  { TBOp := Z.quot ; TBOpInj := ltac:(reflexivity) }.
+Add BinOp Op_Z_quot.
+
+Instance Op_Z_succ : UnOp Z.succ :=
+  { TUOp := fun x => x + 1 ; TUOpInj := ltac:(reflexivity) }.
+Add UnOp Op_Z_succ.
+
+Instance Op_Z_pred : UnOp Z.pred :=
+  { TUOp := fun x => x - 1 ; TUOpInj := ltac:(reflexivity) }.
+Add UnOp Op_Z_pred.
+
+Instance Op_Z_opp : UnOp Z.opp :=
+  { TUOp := Z.opp ; TUOpInj := ltac:(reflexivity) }.
+Add UnOp Op_Z_opp.
+
+Instance Op_Z_abs : UnOp Z.abs :=
+  { TUOp := Z.abs ; TUOpInj := ltac:(reflexivity) }.
+Add UnOp Op_Z_abs.
+
+Instance Op_Z_sgn : UnOp Z.sgn :=
+  { TUOp := Z.sgn ; TUOpInj := ltac:(reflexivity) }.
+Add UnOp Op_Z_sgn.
+
+Instance Op_Z_pow : BinOp Z.pow :=
+  { TBOp := Z.pow ; TBOpInj := ltac:(reflexivity) }.
+Add BinOp Op_Z_pow.
+
+Instance Op_Z_pow_pos : BinOp Z.pow_pos :=
+  { TBOp := Z.pow ; TBOpInj := ltac:(reflexivity) }.
+Add BinOp Op_Z_pow_pos.
+
+Instance Op_Z_double : UnOp Z.double :=
+  { TUOp := Z.mul 2 ; TUOpInj := Z.double_spec }.
+Add UnOp Op_Z_double.
+
+Instance Op_Z_pred_double : UnOp Z.pred_double :=
+  { TUOp := fun x => 2 * x - 1 ; TUOpInj := Z.pred_double_spec }.
+Add UnOp Op_Z_pred_double.
+
+Instance Op_Z_succ_double : UnOp Z.succ_double :=
+  { TUOp := fun x => 2 * x + 1 ; TUOpInj := Z.succ_double_spec }.
+Add UnOp Op_Z_succ_double.
+
+Instance Op_Z_square : UnOp Z.square :=
+  { TUOp := fun x => x * x ; TUOpInj := Z.square_spec }.
+Add UnOp Op_Z_square.
+
+Instance Op_Z_div2 : UnOp Z.div2 :=
+  { TUOp := fun x => x / 2 ; TUOpInj := Z.div2_div }.
+Add UnOp Op_Z_div2.
+
+Instance Op_Z_quot2 : UnOp Z.quot2 :=
+  { TUOp := fun x => Z.quot x 2 ; TUOpInj := Zeven.Zquot2_quot }.
+Add UnOp Op_Z_quot2.
+
+Lemma of_nat_to_nat_eq : forall x,  Z.of_nat (Z.to_nat x) = Z.max 0 x.
+Proof.
+  destruct x.
+  - reflexivity.
+  - rewrite Z2Nat.id.
+    reflexivity.
+    compute. congruence.
+  - reflexivity.
+Qed.
+
+Instance Op_Z_to_nat : UnOp Z.to_nat :=
+  { TUOp := fun x => Z.max 0 x ; TUOpInj := of_nat_to_nat_eq }.
+Add UnOp Op_Z_to_nat.
+
+(** Specification of derived operators over Z *)
+
+Lemma z_max_spec : forall n m,
+    n <= Z.max n m /\ m <= Z.max n m /\ (Z.max n m = n \/ Z.max n m = m).
+Proof.
+  intros.
+  generalize (Z.le_max_l n m).
+  generalize (Z.le_max_r n m).
+  generalize (Z.max_spec_le n m).
+  intuition idtac.
+Qed.
+
+Instance ZmaxSpec : BinOpSpec Z.max :=
+  {| BPred := fun n m r => n < m /\ r = m \/ m <= n /\ r = n ; BSpec := Z.max_spec|}.
+Add Spec ZmaxSpec.
+
+Lemma z_min_spec : forall n m,
+    Z.min n m <= n /\ Z.min n m <= m /\ (Z.min n m = n \/ Z.min n m = m).
+Proof.
+  intros.
+  generalize (Z.le_min_l n m).
+  generalize (Z.le_min_r n m).
+  generalize (Z.min_spec_le n m).
+  intuition idtac.
+Qed.
+
+
+Instance ZminSpec : BinOpSpec Z.min :=
+  {| BPred := fun n m r => n < m /\ r = n \/ m <= n /\ r = m ;
+     BSpec := Z.min_spec |}.
+Add Spec ZminSpec.
+
+Instance ZsgnSpec : UnOpSpec Z.sgn :=
+  {| UPred := fun n r : Z => 0 < n /\ r = 1 \/ 0 = n /\ r = 0 \/ n < 0 /\ r = - (1) ;
+     USpec := Z.sgn_spec|}.
+Add Spec ZsgnSpec.
+
+Instance ZabsSpec : UnOpSpec Z.abs :=
+  {| UPred := fun n r: Z =>  0 <= n /\ r = n \/ n < 0 /\ r = - n ;
+     USpec := Z.abs_spec|}.
+Add Spec ZabsSpec.
+
+(** Saturate positivity constraints *)
+
+Instance SatProd : Saturate Z.mul :=
+  {|
+    PArg1 := fun x => 0 <= x;
+    PArg2 := fun y => 0 <= y;
+    PRes  := fun r => 0 <= r;
+    SatOk := Z.mul_nonneg_nonneg
+  |}.
+Add Saturate SatProd.
+
+Instance SatProdPos : Saturate Z.mul :=
+  {|
+    PArg1 := fun x => 0 < x;
+    PArg2 := fun y => 0 < y;
+    PRes  := fun r => 0 < r;
+    SatOk := Z.mul_pos_pos
+  |}.
+Add Saturate SatProdPos.
+
+Lemma pow_pos_strict :
+  forall a b,
+    0 < a -> 0 < b -> 0 < a ^ b.
+Proof.
+  intros.
+  apply Z.pow_pos_nonneg; auto.
+  apply Z.lt_le_incl;auto.
+Qed.
+
+
+Instance SatPowPos : Saturate Z.pow :=
+  {|
+    PArg1 := fun x => 0 < x;
+    PArg2 := fun y => 0 < y;
+    PRes  := fun r => 0 < r;
+    SatOk := pow_pos_strict
+  |}.
+Add Saturate SatPowPos.
diff --git a/theories/micromega/Ztac.v b/theories/micromega/Ztac.v
new file mode 100644
index 0000000000..091f58a0ef
--- /dev/null
+++ b/theories/micromega/Ztac.v
@@ -0,0 +1,140 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** Tactics for doing arithmetic proofs.
+    Useful to bootstrap lia.
+ *)
+
+Require Import ZArithRing.
+Require Import ZArith_base.
+Local Open Scope Z_scope.
+
+Lemma eq_incl :
+  forall (x y:Z), x = y -> x <= y /\ y <= x.
+Proof.
+  intros; split;
+  apply Z.eq_le_incl; auto.
+Qed.
+
+Lemma elim_concl_eq :
+  forall x y, (x < y \/ y < x -> False) -> x = y.
+Proof.
+  intros.
+  destruct (Z_lt_le_dec x y).
+  exfalso. apply H ; auto.
+  destruct (Zle_lt_or_eq y x);auto.
+  exfalso.
+  apply H ; auto.
+Qed.
+
+Lemma elim_concl_le :
+  forall x y, (y < x -> False) -> x <= y.
+Proof.
+  intros.
+  destruct (Z_lt_le_dec y x).
+  exfalso ; auto.
+  auto.
+Qed.
+
+Lemma elim_concl_lt :
+  forall x y, (y <= x -> False) -> x < y.
+Proof.
+  intros.
+  destruct (Z_lt_le_dec x y).
+  auto.
+  exfalso ; auto.
+Qed.
+
+
+
+Lemma Zlt_le_add_1 : forall n m : Z, n < m -> n + 1 <= m.
+Proof. exact (Zlt_le_succ). Qed.
+
+
+Ltac normZ :=
+  repeat
+  match goal with
+  | H : _ < _ |- _ =>  apply Zlt_le_add_1 in H
+  | H : ?Y <= _ |- _ =>
+    lazymatch Y with
+    | 0 => fail
+    | _ => apply Zle_minus_le_0 in H
+    end
+  | H : _ >= _ |- _ => apply Z.ge_le in H
+  | H : _ > _  |- _ => apply Z.gt_lt in H
+  | H : _ = _  |- _ => apply eq_incl in H ; destruct H
+  | |- @eq Z _ _  => apply elim_concl_eq ; let H := fresh "HZ" in intros [H|H]
+  | |- _ <= _ => apply elim_concl_le ; intros
+  | |- _ < _ => apply elim_concl_lt ; intros
+  | |- _ >= _ => apply Z.le_ge
+  end.
+
+
+Inductive proof :=
+| Hyp (e : Z) (prf : 0 <= e)
+| Add (p1 p2: proof)
+| Mul (p1 p2: proof)
+| Cst (c : Z)
+.
+
+Lemma add_le : forall e1 e2, 0 <= e1 -> 0 <= e2 -> 0 <= e1+e2.
+Proof.
+  intros.
+  change 0 with (0+ 0).
+  apply Z.add_le_mono; auto.
+Qed.
+
+Lemma mul_le : forall e1 e2, 0 <= e1 -> 0 <= e2 -> 0 <= e1*e2.
+Proof.
+  intros.
+  change 0 with (0* e2).
+  apply Zmult_le_compat_r; auto.
+Qed.
+
+Fixpoint eval_proof (p : proof) : { e : Z | 0 <= e} :=
+  match p with
+  | Hyp e prf => exist _ e prf
+  | Add p1 p2 => let (e1,p1) := eval_proof p1 in
+                 let (e2,p2) := eval_proof p2 in
+                 exist _ _ (add_le _ _ p1 p2)
+  | Mul p1 p2  => let (e1,p1) := eval_proof p1 in
+                 let (e2,p2) := eval_proof p2 in
+                 exist _ _ (mul_le _ _ p1 p2)
+  | Cst c      =>  match Z_le_dec 0 c with
+                   | left prf => exist _ _ prf
+                   |  _       => exist _ _ Z.le_0_1
+                 end
+  end.
+
+Ltac lia_step p :=
+  let H := fresh in
+  let prf := (eval cbn - [Z.le Z.mul Z.opp Z.sub Z.add] in (eval_proof p)) in
+  match prf with
+  | @exist _ _ _ ?P =>  pose proof P as H
+  end ; ring_simplify in H.
+
+Ltac lia_contr :=
+  match goal with
+  | H : 0 <= - (Zpos _) |- _ =>
+    rewrite <- Z.leb_le in H;
+    compute in H ; discriminate
+  | H : 0 <= (Zneg _) |- _ =>
+    rewrite <- Z.leb_le in H;
+    compute in H ; discriminate
+  end.
+
+
+Ltac lia p :=
+  lia_step p ; lia_contr.
+
+Ltac slia H1 H2 :=
+  normZ ; lia (Add (Hyp _ H1) (Hyp _ H2)).
+
+Arguments Hyp {_} prf.