summaryrefslogtreecommitdiff
path: root/contrib/micromega
diff options
context:
space:
mode:
authorGravatar Samuel Mimram <smimram@debian.org>2008-07-25 15:12:53 +0200
committerGravatar Samuel Mimram <smimram@debian.org>2008-07-25 15:12:53 +0200
commita0cfa4f118023d35b767a999d5a2ac4b082857b4 (patch)
treedabcac548e299fee1da464c93b3dba98484f45b1 /contrib/micromega
parent2281410e38ef99d025ea77194585a9bc019fdaa9 (diff)
Imported Upstream version 8.2~beta3+dfsgupstream/8.2.beta3+dfsg
Diffstat (limited to 'contrib/micromega')
-rw-r--r--contrib/micromega/CheckerMaker.v129
-rw-r--r--contrib/micromega/Env.v182
-rw-r--r--contrib/micromega/EnvRing.v1403
-rw-r--r--contrib/micromega/LICENSE.sos29
-rw-r--r--contrib/micromega/MExtraction.v23
-rw-r--r--contrib/micromega/Micromegatac.v79
-rw-r--r--contrib/micromega/OrderedRing.v458
-rw-r--r--contrib/micromega/QMicromega.v259
-rw-r--r--contrib/micromega/RMicromega.v148
-rw-r--r--contrib/micromega/Refl.v129
-rw-r--r--contrib/micromega/RingMicromega.v779
-rw-r--r--contrib/micromega/Tauto.v324
-rw-r--r--contrib/micromega/VarMap.v258
-rw-r--r--contrib/micromega/ZCoeff.v173
-rw-r--r--contrib/micromega/ZMicromega.v714
-rw-r--r--contrib/micromega/certificate.ml618
-rw-r--r--contrib/micromega/coq_micromega.ml1290
-rw-r--r--contrib/micromega/csdpcert.ml333
-rw-r--r--contrib/micromega/g_micromega.ml459
-rw-r--r--contrib/micromega/mfourier.ml667
-rw-r--r--contrib/micromega/micromega.ml1512
-rw-r--r--contrib/micromega/micromega.mli398
-rw-r--r--contrib/micromega/mutils.ml305
-rw-r--r--contrib/micromega/sos.ml1919
-rw-r--r--contrib/micromega/sos.mli66
-rw-r--r--contrib/micromega/vector.ml674
26 files changed, 12928 insertions, 0 deletions
diff --git a/contrib/micromega/CheckerMaker.v b/contrib/micromega/CheckerMaker.v
new file mode 100644
index 00000000..93b4d213
--- /dev/null
+++ b/contrib/micromega/CheckerMaker.v
@@ -0,0 +1,129 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import Setoid.
+Require Import Decidable.
+Require Import List.
+Require Import Refl.
+
+Set Implicit Arguments.
+
+Section CheckerMaker.
+
+(* 'Formula' is a syntactic representation of a certain kind of propositions. *)
+Variable Formula : Type.
+
+Variable Env : Type.
+
+Variable eval : Env -> Formula -> Prop.
+
+Variable Formula' : Type.
+
+Variable eval' : Env -> Formula' -> Prop.
+
+Variable normalise : Formula -> Formula'.
+
+Variable negate : Formula -> Formula'.
+
+Hypothesis normalise_sound :
+ forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t).
+
+Hypothesis negate_correct :
+ forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)).
+
+Variable Witness : Type.
+
+Variable check_formulas' : list Formula' -> Witness -> bool.
+
+Hypothesis check_formulas'_sound :
+ forall (l : list Formula') (w : Witness),
+ check_formulas' l w = true ->
+ forall env : Env, make_impl (eval' env) l False.
+
+Definition normalise_list : list Formula -> list Formula' := map normalise.
+Definition negate_list : list Formula -> list Formula' := map negate.
+
+Definition check_formulas (l : list Formula) (w : Witness) : bool :=
+ check_formulas' (map normalise l) w.
+
+(* Contraposition of normalise_sound for lists *)
+Lemma normalise_sound_contr : forall (env : Env) (l : list Formula),
+ make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False.
+Proof.
+intros env l; induction l as [| t l IH]; simpl in *.
+trivial.
+intros H1 H2. apply IH. apply H1. now apply normalise_sound.
+Qed.
+
+Theorem check_formulas_sound :
+ forall (l : list Formula) (w : Witness),
+ check_formulas l w = true -> forall env : Env, make_impl (eval env) l False.
+Proof.
+unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *.
+pose proof (check_formulas'_sound H env) as H1; now simpl in H1.
+intro H1. apply normalise_sound in H1.
+pose proof (check_formulas'_sound H env) as H2; simpl in H2.
+apply H2 in H1. now apply normalise_sound_contr.
+Qed.
+
+(* In check_conj_formulas', t2 is supposed to be a list of negations of
+formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then
+check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is
+inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that
+A1 /\ A2 -> B1 /\ B2. *)
+
+Fixpoint check_conj_formulas'
+ (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool :=
+match t2 with
+| nil => true
+| t':: rt2 =>
+ match wits with
+ | nil => false
+ | w :: rwits =>
+ match check_formulas' (t':: t1) w with
+ | true => check_conj_formulas' t1 rwits rt2
+ | false => false
+ end
+ end
+end.
+
+(* checks whether the conjunction of t1 implies the conjunction of t2 *)
+
+Definition check_conj_formulas
+ (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool :=
+ check_conj_formulas' (normalise_list t1) wits (negate_list t2).
+
+Theorem check_conj_formulas_sound :
+ forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness),
+ check_conj_formulas t1 wits t2 = true ->
+ forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2).
+Proof.
+intro t1; induction t2 as [| a2 t2' IH].
+intros; apply make_impl_true.
+intros wits H env.
+unfold check_conj_formulas in H; simpl in H.
+destruct wits as [| w ws]; simpl in H. discriminate.
+case_eq (check_formulas' (negate a2 :: normalise_list t1) w);
+intro H1; rewrite H1 in H; [| discriminate].
+assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by
+now apply check_formulas'_sound with (w := w). clear H1.
+pose proof (IH ws H env) as H1. simpl in H2.
+assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False)
+by auto using normalise_sound_contr. clear H2.
+rewrite <- make_conj_impl in *.
+rewrite make_conj_cons. intro H2. split.
+apply <- negate_correct. intro; now elim H3. exact (H1 H2).
+Qed.
+
+End CheckerMaker.
diff --git a/contrib/micromega/Env.v b/contrib/micromega/Env.v
new file mode 100644
index 00000000..40db9e46
--- /dev/null
+++ b/contrib/micromega/Env.v
@@ -0,0 +1,182 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import ZArith.
+Require Import Coq.Arith.Max.
+Require Import List.
+Set Implicit Arguments.
+
+(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v)
+ -- this is harmless and spares a lot of Empty.
+ This means smaller proof-terms.
+ BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up.
+*)
+
+Section S.
+
+ Variable D :Type.
+
+ Definition Env := positive -> D.
+
+ Definition jump (j:positive) (e:Env) := fun x => e (Pplus x j).
+
+ Definition nth (n:positive) (e : Env ) := e n.
+
+ Definition hd (x:D) (e: Env) := nth xH e.
+
+ Definition tail (e: Env) := jump xH e.
+
+ Lemma psucc : forall p, (match p with
+ | xI y' => xO (Psucc y')
+ | xO y' => xI y'
+ | 1%positive => 2%positive
+ end) = (p+1)%positive.
+ Proof.
+ destruct p.
+ auto with zarith.
+ rewrite xI_succ_xO.
+ auto with zarith.
+ reflexivity.
+ Qed.
+
+ Lemma jump_Pplus : forall i j l,
+ forall x, jump (i + j) l x = jump i (jump j l) x.
+ Proof.
+ unfold jump.
+ intros.
+ rewrite Pplus_assoc.
+ reflexivity.
+ Qed.
+
+ Lemma jump_simpl : forall p l,
+ forall x, jump p l x =
+ match p with
+ | xH => tail l x
+ | xO p => jump p (jump p l) x
+ | xI p => jump p (jump p (tail l)) x
+ end.
+ Proof.
+ destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus.
+ (* xI p = p + p + 1 *)
+ rewrite xI_succ_xO.
+ rewrite Pplus_diag.
+ rewrite <- Pplus_one_succ_r.
+ reflexivity.
+ (* xO p = p + p *)
+ rewrite Pplus_diag.
+ reflexivity.
+ reflexivity.
+ Qed.
+
+ Ltac jump_s :=
+ repeat
+ match goal with
+ | |- context [jump xH ?e] => rewrite (jump_simpl xH)
+ | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
+ | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
+ end.
+
+ Lemma jump_tl : forall j l, forall x, tail (jump j l) x = jump j (tail l) x.
+ Proof.
+ unfold tail.
+ intros.
+ repeat rewrite <- jump_Pplus.
+ rewrite Pplus_comm.
+ reflexivity.
+ Qed.
+
+ Lemma jump_Psucc : forall j l,
+ forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x).
+ Proof.
+ intros.
+ rewrite <- jump_Pplus.
+ rewrite Pplus_one_succ_r.
+ rewrite Pplus_comm.
+ reflexivity.
+ Qed.
+
+ Lemma jump_Pdouble_minus_one : forall i l,
+ forall x, (jump (Pdouble_minus_one i) (tail l)) x = (jump i (jump i l)) x.
+ Proof.
+ unfold tail.
+ intros.
+ repeat rewrite <- jump_Pplus.
+ rewrite <- Pplus_one_succ_r.
+ rewrite Psucc_o_double_minus_one_eq_xO.
+ rewrite Pplus_diag.
+ reflexivity.
+ Qed.
+
+ Lemma jump_x0_tail : forall p l, forall x, jump (xO p) (tail l) x = jump (xI p) l x.
+ Proof.
+ intros.
+ unfold jump.
+ unfold tail.
+ unfold jump.
+ rewrite <- Pplus_assoc.
+ simpl.
+ reflexivity.
+ Qed.
+
+ Lemma nth_spec : forall p l x,
+ nth p l =
+ match p with
+ | xH => hd x l
+ | xO p => nth p (jump p l)
+ | xI p => nth p (jump p (tail l))
+ end.
+ Proof.
+ unfold nth.
+ destruct p.
+ intros.
+ unfold jump, tail.
+ unfold jump.
+ rewrite Pplus_diag.
+ rewrite xI_succ_xO.
+ simpl.
+ reflexivity.
+ unfold jump.
+ rewrite Pplus_diag.
+ reflexivity.
+ unfold hd.
+ unfold nth.
+ reflexivity.
+ Qed.
+
+
+ Lemma nth_jump : forall p l x, nth p (tail l) = hd x (jump p l).
+ Proof.
+ unfold tail.
+ unfold hd.
+ unfold jump.
+ unfold nth.
+ intros.
+ rewrite Pplus_comm.
+ reflexivity.
+ Qed.
+
+ Lemma nth_Pdouble_minus_one :
+ forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
+ Proof.
+ intros.
+ unfold tail.
+ unfold nth, jump.
+ rewrite Pplus_diag.
+ rewrite <- Psucc_o_double_minus_one_eq_xO.
+ rewrite Pplus_one_succ_r.
+ reflexivity.
+ Qed.
+
+End S.
+
diff --git a/contrib/micromega/EnvRing.v b/contrib/micromega/EnvRing.v
new file mode 100644
index 00000000..04e68272
--- /dev/null
+++ b/contrib/micromega/EnvRing.v
@@ -0,0 +1,1403 @@
+(************************************************************************)
+(* V * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* F. Besson: to evaluate polynomials, the original code is using a list.
+ For big polynomials, this is inefficient -- linear access.
+ I have modified the code to use binary trees -- logarithmic access. *)
+
+
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinList.
+Require Import Env.
+Require Import BinPos.
+Require Import BinNat.
+Require Import BinInt.
+Require Export Ring_theory.
+
+Open Local Scope positive_scope.
+Import RingSyntax.
+
+Section MakeRingPol.
+
+ (* Ring elements *)
+ Variable R:Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
+ Variable req : R -> R -> Prop.
+
+ (* Ring properties *)
+ Variable Rsth : Setoid_Theory R req.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
+
+ (* Coefficients *)
+ Variable C: Type.
+ Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
+ Variable ceqb : C->C->bool.
+ Variable phi : C -> R.
+ Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
+ cO cI cadd cmul csub copp ceqb phi.
+
+ (* Power coefficients *)
+ Variable Cpow : Set.
+ Variable Cp_phi : N -> Cpow.
+ Variable rpow : R -> Cpow -> R.
+ Variable pow_th : power_theory rI rmul req Cp_phi rpow.
+
+
+ (* R notations *)
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ Notation "x == y" := (req x y).
+
+ (* C notations *)
+ Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
+ Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
+ Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+
+ (* Usefull tactics *)
+ Add Setoid R req Rsth as R_set1.
+ Ltac rrefl := gen_reflexivity Rsth.
+ Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed.
+ Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed.
+ Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed.
+ Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
+ Ltac add_push := gen_add_push radd Rsth Reqe ARth.
+ Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth.
+
+ (* Definition of multivariable polynomials with coefficients in C :
+ Type [Pol] represents [X1 ... Xn].
+ The representation is Horner's where a [n] variable polynomial
+ (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients
+ are polynomials with [n-1] variables (C[X2..Xn]).
+ There are several optimisations to make the repr compacter:
+ - [Pc c] is the constant polynomial of value c
+ == c*X1^0*..*Xn^0
+ - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables.
+ variable indices are shifted of j in Q.
+ == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn}
+ - [PX P i Q] is an optimised Horner form of P*X^i + Q
+ with P not the null polynomial
+ == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn}
+
+ In addition:
+ - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden
+ since they can be represented by the simpler form (PX P (i+j) Q)
+ - (Pinj i (Pinj j P)) is (Pinj (i+j) P)
+ - (Pinj i (Pc c)) is (Pc c)
+ *)
+
+ Inductive Pol : Type :=
+ | Pc : C -> Pol
+ | Pinj : positive -> Pol -> Pol
+ | PX : Pol -> positive -> Pol -> Pol.
+
+ Definition P0 := Pc cO.
+ Definition P1 := Pc cI.
+
+ Fixpoint Peq (P P' : Pol) {struct P'} : bool :=
+ match P, P' with
+ | Pc c, Pc c' => c ?=! c'
+ | Pinj j Q, Pinj j' Q' =>
+ match Pcompare j j' Eq with
+ | Eq => Peq Q Q'
+ | _ => false
+ end
+ | PX P i Q, PX P' i' Q' =>
+ match Pcompare i i' Eq with
+ | Eq => if Peq P P' then Peq Q Q' else false
+ | _ => false
+ end
+ | _, _ => false
+ end.
+
+ Notation " P ?== P' " := (Peq P P').
+
+ Definition mkPinj j P :=
+ match P with
+ | Pc _ => P
+ | Pinj j' Q => Pinj ((j + j'):positive) Q
+ | _ => Pinj j P
+ end.
+
+ Definition mkPinj_pred j P:=
+ match j with
+ | xH => P
+ | xO j => Pinj (Pdouble_minus_one j) P
+ | xI j => Pinj (xO j) P
+ end.
+
+ Definition mkPX P i Q :=
+ match P with
+ | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q
+ | Pinj _ _ => PX P i Q
+ | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q
+ end.
+
+ Definition mkXi i := PX P1 i P0.
+
+ Definition mkX := mkXi 1.
+
+ (** Opposite of addition *)
+
+ Fixpoint Popp (P:Pol) : Pol :=
+ match P with
+ | Pc c => Pc (-! c)
+ | Pinj j Q => Pinj j (Popp Q)
+ | PX P i Q => PX (Popp P) i (Popp Q)
+ end.
+
+ Notation "-- P" := (Popp P).
+
+ (** Addition et subtraction *)
+
+ Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol :=
+ match P with
+ | Pc c1 => Pc (c1 +! c)
+ | Pinj j Q => Pinj j (PaddC Q c)
+ | PX P i Q => PX P i (PaddC Q c)
+ end.
+
+ Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol :=
+ match P with
+ | Pc c1 => Pc (c1 -! c)
+ | Pinj j Q => Pinj j (PsubC Q c)
+ | PX P i Q => PX P i (PsubC Q c)
+ end.
+
+ Section PopI.
+
+ Variable Pop : Pol -> Pol -> Pol.
+ Variable Q : Pol.
+
+ Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol :=
+ match P with
+ | Pc c => mkPinj j (PaddC Q c)
+ | Pinj j' Q' =>
+ match ZPminus j' j with
+ | Zpos k => mkPinj j (Pop (Pinj k Q') Q)
+ | Z0 => mkPinj j (Pop Q' Q)
+ | Zneg k => mkPinj j' (PaddI k Q')
+ end
+ | PX P i Q' =>
+ match j with
+ | xH => PX P i (Pop Q' Q)
+ | xO j => PX P i (PaddI (Pdouble_minus_one j) Q')
+ | xI j => PX P i (PaddI (xO j) Q')
+ end
+ end.
+
+ Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol :=
+ match P with
+ | Pc c => mkPinj j (PaddC (--Q) c)
+ | Pinj j' Q' =>
+ match ZPminus j' j with
+ | Zpos k => mkPinj j (Pop (Pinj k Q') Q)
+ | Z0 => mkPinj j (Pop Q' Q)
+ | Zneg k => mkPinj j' (PsubI k Q')
+ end
+ | PX P i Q' =>
+ match j with
+ | xH => PX P i (Pop Q' Q)
+ | xO j => PX P i (PsubI (Pdouble_minus_one j) Q')
+ | xI j => PX P i (PsubI (xO j) Q')
+ end
+ end.
+
+ Variable P' : Pol.
+
+ Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol :=
+ match P with
+ | Pc c => PX P' i' P
+ | Pinj j Q' =>
+ match j with
+ | xH => PX P' i' Q'
+ | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q')
+ | xI j => PX P' i' (Pinj (xO j) Q')
+ end
+ | PX P i Q' =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+ | Z0 => mkPX (Pop P P') i Q'
+ | Zneg k => mkPX (PaddX k P) i Q'
+ end
+ end.
+
+ Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol :=
+ match P with
+ | Pc c => PX (--P') i' P
+ | Pinj j Q' =>
+ match j with
+ | xH => PX (--P') i' Q'
+ | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q')
+ | xI j => PX (--P') i' (Pinj (xO j) Q')
+ end
+ | PX P i Q' =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+ | Z0 => mkPX (Pop P P') i Q'
+ | Zneg k => mkPX (PsubX k P) i Q'
+ end
+ end.
+
+
+ End PopI.
+
+ Fixpoint Padd (P P': Pol) {struct P'} : Pol :=
+ match P' with
+ | Pc c' => PaddC P c'
+ | Pinj j' Q' => PaddI Padd Q' j' P
+ | PX P' i' Q' =>
+ match P with
+ | Pc c => PX P' i' (PaddC Q' c)
+ | Pinj j Q =>
+ match j with
+ | xH => PX P' i' (Padd Q Q')
+ | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q')
+ | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
+ end
+ | PX P i Q =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q')
+ | Z0 => mkPX (Padd P P') i (Padd Q Q')
+ | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q')
+ end
+ end
+ end.
+ Notation "P ++ P'" := (Padd P P').
+
+ Fixpoint Psub (P P': Pol) {struct P'} : Pol :=
+ match P' with
+ | Pc c' => PsubC P c'
+ | Pinj j' Q' => PsubI Psub Q' j' P
+ | PX P' i' Q' =>
+ match P with
+ | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c)
+ | Pinj j Q =>
+ match j with
+ | xH => PX (--P') i' (Psub Q Q')
+ | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q')
+ | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
+ end
+ | PX P i Q =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q')
+ | Z0 => mkPX (Psub P P') i (Psub Q Q')
+ | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q')
+ end
+ end
+ end.
+ Notation "P -- P'" := (Psub P P').
+
+ (** Multiplication *)
+
+ Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol :=
+ match P with
+ | Pc c' => Pc (c' *! c)
+ | Pinj j Q => mkPinj j (PmulC_aux Q c)
+ | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c)
+ end.
+
+ Definition PmulC P c :=
+ if c ?=! cO then P0 else
+ if c ?=! cI then P else PmulC_aux P c.
+
+ Section PmulI.
+ Variable Pmul : Pol -> Pol -> Pol.
+ Variable Q : Pol.
+ Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol :=
+ match P with
+ | Pc c => mkPinj j (PmulC Q c)
+ | Pinj j' Q' =>
+ match ZPminus j' j with
+ | Zpos k => mkPinj j (Pmul (Pinj k Q') Q)
+ | Z0 => mkPinj j (Pmul Q' Q)
+ | Zneg k => mkPinj j' (PmulI k Q')
+ end
+ | PX P' i' Q' =>
+ match j with
+ | xH => mkPX (PmulI xH P') i' (Pmul Q' Q)
+ | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q')
+ | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
+ end
+ end.
+
+ End PmulI.
+(* A symmetric version of the multiplication *)
+
+ Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol :=
+ match P'' with
+ | Pc c => PmulC P c
+ | Pinj j' Q' => PmulI Pmul Q' j' P
+ | PX P' i' Q' =>
+ match P with
+ | Pc c => PmulC P'' c
+ | Pinj j Q =>
+ let QQ' :=
+ match j with
+ | xH => Pmul Q Q'
+ | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q'
+ | xI j => Pmul (Pinj (xO j) Q) Q'
+ end in
+ mkPX (Pmul P P') i' QQ'
+ | PX P i Q=>
+ let QQ' := Pmul Q Q' in
+ let PQ' := PmulI Pmul Q' xH P in
+ let QP' := Pmul (mkPinj xH Q) P' in
+ let PP' := Pmul P P' in
+ (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ'
+ end
+ end.
+
+(* Non symmetric *)
+(*
+ Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol :=
+ match P' with
+ | Pc c' => PmulC P c'
+ | Pinj j' Q' => PmulI Pmul_aux Q' j' P
+ | PX P' i' Q' =>
+ (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P)
+ end.
+
+ Definition Pmul P P' :=
+ match P with
+ | Pc c => PmulC P' c
+ | Pinj j Q => PmulI Pmul_aux Q j P'
+ | PX P i Q =>
+ (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P')
+ end.
+*)
+ Notation "P ** P'" := (Pmul P P').
+
+ Fixpoint Psquare (P:Pol) : Pol :=
+ match P with
+ | Pc c => Pc (c *! c)
+ | Pinj j Q => Pinj j (Psquare Q)
+ | PX P i Q =>
+ let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in
+ let Q2 := Psquare Q in
+ let P2 := Psquare P in
+ mkPX (mkPX P2 i P0 ++ twoPQ) i Q2
+ end.
+
+ (** Monomial **)
+
+ Inductive Mon: Set :=
+ mon0: Mon
+ | zmon: positive -> Mon -> Mon
+ | vmon: positive -> Mon -> Mon.
+
+ Fixpoint Mphi(l:Env R) (M: Mon) {struct M} : R :=
+ match M with
+ mon0 => rI
+ | zmon j M1 => Mphi (jump j l) M1
+ | vmon i M1 =>
+ let x := hd 0 l in
+ let xi := pow_pos rmul x i in
+ (Mphi (tail l) M1) * xi
+ end.
+
+ Definition mkZmon j M :=
+ match M with mon0 => mon0 | _ => zmon j M end.
+
+ Definition zmon_pred j M :=
+ match j with xH => M | _ => mkZmon (Ppred j) M end.
+
+ Definition mkVmon i M :=
+ match M with
+ | mon0 => vmon i mon0
+ | zmon j m => vmon i (zmon_pred j m)
+ | vmon i' m => vmon (i+i') m
+ end.
+
+ Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol :=
+ match P, M with
+ _, mon0 => (Pc cO, P)
+ | Pc _, _ => (P, Pc cO)
+ | Pinj j1 P1, zmon j2 M1 =>
+ match (j1 ?= j2) Eq with
+ Eq => let (R,S) := MFactor P1 M1 in
+ (mkPinj j1 R, mkPinj j1 S)
+ | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in
+ (mkPinj j1 R, mkPinj j1 S)
+ | Gt => (P, Pc cO)
+ end
+ | Pinj _ _, vmon _ _ => (P, Pc cO)
+ | PX P1 i Q1, zmon j M1 =>
+ let M2 := zmon_pred j M1 in
+ let (R1, S1) := MFactor P1 M in
+ let (R2, S2) := MFactor Q1 M2 in
+ (mkPX R1 i R2, mkPX S1 i S2)
+ | PX P1 i Q1, vmon j M1 =>
+ match (i ?= j) Eq with
+ Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+ (mkPX R1 i Q1, S1)
+ | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in
+ (mkPX R1 i Q1, S1)
+ | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+ (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO))
+ end
+ end.
+
+ Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol :=
+ let (Q1,R1) := MFactor P1 M1 in
+ match R1 with
+ (Pc c) => if c ?=! cO then None
+ else Some (Padd Q1 (Pmul P2 R1))
+ | _ => Some (Padd Q1 (Pmul P2 R1))
+ end.
+
+ Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
+ match POneSubst P1 M1 P2 with
+ Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end
+ | _ => P1
+ end.
+
+ Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol :=
+ match POneSubst P1 M1 P2 with
+ Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end
+ | _ => None
+ end.
+
+ Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}:
+ Pol :=
+ match LM1 with
+ cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
+ | _ => P1
+ end.
+
+ Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol :=
+ match LM1 with
+ cons (M1,P2) LM2 =>
+ match PNSubst P1 M1 P2 n with
+ Some P3 => Some (PSubstL1 P3 LM2 n)
+ | None => PSubstL P1 LM2 n
+ end
+ | _ => None
+ end.
+
+ Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol :=
+ match PSubstL P1 LM1 n with
+ Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
+ | _ => P1
+ end.
+
+ (** Evaluation of a polynomial towards R *)
+
+ Fixpoint Pphi(l:Env R) (P:Pol) {struct P} : R :=
+ match P with
+ | Pc c => [c]
+ | Pinj j Q => Pphi (jump j l) Q
+ | PX P i Q =>
+ let x := hd 0 l in
+ let xi := pow_pos rmul x i in
+ (Pphi l P) * xi + (Pphi (tail l) Q)
+ end.
+
+ Reserved Notation "P @ l " (at level 10, no associativity).
+ Notation "P @ l " := (Pphi l P).
+ (** Proofs *)
+ Lemma ZPminus_spec : forall x y,
+ match ZPminus x y with
+ | Z0 => x = y
+ | Zpos k => x = (y + k)%positive
+ | Zneg k => y = (x + k)%positive
+ end.
+ Proof.
+ induction x;destruct y.
+ replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial.
+ assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+ replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial.
+ assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial.
+ apply Pplus_xI_double_minus_one.
+ simpl;trivial.
+ replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial.
+ assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial.
+ apply Pplus_xI_double_minus_one.
+ replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial.
+ assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+ replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial.
+ rewrite <- Pplus_one_succ_l.
+ rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+ replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial.
+ replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial.
+ rewrite <- Pplus_one_succ_l.
+ rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+ simpl;trivial.
+ Qed.
+
+ Lemma Peq_ok : forall P P',
+ (P ?== P') = true -> forall l, P@l == P'@ l.
+ Proof.
+ induction P;destruct P';simpl;intros;try discriminate;trivial.
+ apply (morph_eq CRmorph);trivial.
+ assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+ try discriminate H.
+ rewrite (IHP P' H); rewrite H1;trivial;rrefl.
+ assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+ try discriminate H.
+ rewrite H1;trivial. clear H1.
+ assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2);
+ destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H]
+ |discriminate H].
+ rewrite (H1 H);rewrite (H2 H);rrefl.
+ Qed.
+
+ Lemma Pphi0 : forall l, P0@l == 0.
+ Proof.
+ intros;simpl;apply (morph0 CRmorph).
+ Qed.
+
+Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) ->
+ p @ e1 = p @ e2.
+Proof.
+ induction p ; simpl.
+ reflexivity.
+ intros.
+ apply IHp.
+ intros.
+ unfold jump.
+ apply H.
+ intros.
+ rewrite (IHp1 e1 e2) ; auto.
+ rewrite (IHp2 (tail e1) (tail e2)) ; auto.
+ unfold hd. unfold nth. rewrite H. reflexivity.
+ unfold tail. unfold jump. intros ; apply H.
+Qed.
+
+Lemma Pjump_Pplus : forall P i j l, P @ (jump (i + j) l ) = P @ (jump j (jump i l)).
+Proof.
+ intros. apply env_morph. intros. rewrite <- jump_Pplus.
+ rewrite Pplus_comm.
+ reflexivity.
+Qed.
+
+Lemma Pjump_xO_tail : forall P p l,
+ P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l).
+Proof.
+ intros.
+ apply env_morph.
+ intros.
+ rewrite (@jump_simpl R (xI p)).
+ rewrite (@jump_simpl R (xO p)).
+ reflexivity.
+Qed.
+
+Lemma Pjump_Pdouble_minus_one : forall P p l,
+ P @ (jump (Pdouble_minus_one p) (tail l)) = P @ (jump (xO p) l).
+Proof.
+ intros.
+ apply env_morph.
+ intros.
+ rewrite jump_Pdouble_minus_one.
+ rewrite (@jump_simpl R (xO p)).
+ reflexivity.
+Qed.
+
+
+
+ Lemma Pphi1 : forall l, P1@l == 1.
+ Proof.
+ intros;simpl;apply (morph1 CRmorph).
+ Qed.
+
+ Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l).
+ Proof.
+ intros j l p;destruct p;simpl;rsimpl.
+ rewrite Pjump_Pplus.
+ reflexivity.
+ Qed.
+
+ Let pow_pos_Pplus :=
+ pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc).
+
+ Lemma mkPX_ok : forall l P i Q,
+ (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l).
+ Proof.
+ intros l P i Q;unfold mkPX.
+ destruct P;try (simpl;rrefl).
+ assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl.
+ rewrite (H (refl_equal true));rewrite (morph0 CRmorph).
+ rewrite mkPinj_ok;rsimpl;simpl;rrefl.
+ assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl.
+ rewrite (H (refl_equal true));trivial.
+ rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+
+
+ Ltac Esimpl :=
+ repeat (progress (
+ match goal with
+ | |- context [P0@?l] => rewrite (Pphi0 l)
+ | |- context [P1@?l] => rewrite (Pphi1 l)
+ | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P)
+ | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q)
+ | |- context [[cO]] => rewrite (morph0 CRmorph)
+ | |- context [[cI]] => rewrite (morph1 CRmorph)
+ | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y)
+ | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y)
+ | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y)
+ | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x)
+ end));
+ rsimpl; simpl.
+
+ Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c].
+ Proof.
+ induction P;simpl;intros;Esimpl;trivial.
+ rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c].
+ Proof.
+ induction P;simpl;intros.
+ Esimpl.
+ rewrite IHP;rsimpl.
+ rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c].
+ Proof.
+ induction P;simpl;intros;Esimpl;trivial.
+ rewrite IHP1;rewrite IHP2;rsimpl.
+ mul_push ([c]);rrefl.
+ Qed.
+
+ Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c].
+ Proof.
+ intros c P l; unfold PmulC.
+ assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO).
+ rewrite (H (refl_equal true));Esimpl.
+ assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
+ rewrite (H1 (refl_equal true));Esimpl.
+ apply PmulC_aux_ok.
+ Qed.
+
+ Lemma Popp_ok : forall P l, (--P)@l == - P@l.
+ Proof.
+ induction P;simpl;intros.
+ Esimpl.
+ apply IHP.
+ rewrite IHP1;rewrite IHP2;rsimpl.
+ Qed.
+
+ Ltac Esimpl2 :=
+ Esimpl;
+ repeat (progress (
+ match goal with
+ | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l)
+ | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l)
+ | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
+ | |- context [(--?P)@?l] => rewrite (Popp_ok P l)
+ end)); Esimpl.
+
+
+
+
+ Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l.
+ Proof.
+ induction P';simpl;intros;Esimpl2.
+ generalize P p l;clear P p l.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARadd_comm ARth).
+ assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+ rewrite H;Esimpl. rewrite IHP';rrefl.
+ rewrite H;Esimpl. rewrite IHP';Esimpl.
+ rewrite Pjump_Pplus. rrefl.
+ rewrite H;Esimpl. rewrite IHP.
+ rewrite Pjump_Pplus. rrefl.
+ destruct p0;simpl.
+ rewrite IHP2;simpl. rsimpl.
+ rewrite Pjump_xO_tail. Esimpl.
+ rewrite IHP2;simpl.
+ rewrite Pjump_Pdouble_minus_one.
+ rsimpl.
+ rewrite IHP'.
+ rsimpl.
+ destruct P;simpl.
+ Esimpl2;add_push [c];rrefl.
+ destruct p0;simpl;Esimpl2.
+ rewrite IHP'2;simpl.
+ rewrite Pjump_xO_tail.
+ rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+ rewrite IHP'2;simpl.
+ rewrite Pjump_Pdouble_minus_one. rsimpl.
+ add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+ rewrite IHP'2;rsimpl.
+ unfold tail.
+ add_push (P @ (jump 1 l));rrefl.
+ assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
+ rewrite IHP'1;rewrite IHP'2;rsimpl.
+ add_push (P3 @ (tail l));rewrite H;rrefl.
+ rewrite IHP'1;rewrite IHP'2;simpl;Esimpl.
+ rewrite H;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;rsimpl.
+ add_push (P3 @ (tail l));rrefl.
+ assert (forall P k l,
+ (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k).
+ induction P;simpl;intros;try apply (ARadd_comm ARth).
+ destruct p2; simpl; try apply (ARadd_comm ARth).
+ rewrite Pjump_xO_tail.
+ apply (ARadd_comm ARth).
+ rewrite Pjump_Pdouble_minus_one.
+ apply (ARadd_comm ARth).
+ assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
+ rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl.
+ rewrite IHP'1;simpl;Esimpl.
+ rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;Esimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;rsimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite H0;rsimpl.
+ add_push (P3 @ (tail l)).
+ rewrite H;rewrite Pplus_comm.
+ rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl.
+ add_push (P3 @ (tail l));rrefl.
+ Qed.
+
+ Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
+ Proof.
+ induction P';simpl;intros;Esimpl2;trivial.
+ generalize P p l;clear P p l.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARadd_comm ARth).
+ assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+ rewrite H;Esimpl. rewrite IHP';rsimpl.
+ rewrite H;Esimpl. rewrite IHP';Esimpl.
+ rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
+ rewrite H;Esimpl. rewrite IHP.
+ rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
+ destruct p0;simpl.
+ rewrite IHP2;simpl; try rewrite Pjump_xO_tail ; rsimpl.
+ rewrite IHP2;simpl.
+ rewrite Pjump_Pdouble_minus_one;rsimpl.
+ unfold tail ; rsimpl.
+ rewrite IHP';rsimpl.
+ destruct P;simpl.
+ repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl.
+ destruct p0;simpl;Esimpl2.
+ rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial.
+ rewrite Pjump_xO_tail.
+ add_push (P @ ((jump (xI p0) l)));rrefl.
+ rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl.
+ add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl.
+ unfold tail.
+ rewrite IHP'2;rsimpl;add_push (P @ (jump 1 l));rrefl.
+ assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
+ rewrite IHP'1; rewrite IHP'2;rsimpl.
+ add_push (P3 @ (tail l));rewrite H;rrefl.
+ rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl.
+ rewrite H;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;rsimpl.
+ add_push (P3 @ (tail l));rrefl.
+ assert (forall P k l,
+ (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k).
+ induction P;simpl;intros.
+ rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial.
+ destruct p2;simpl; rewrite Popp_ok;rsimpl.
+ rewrite Pjump_xO_tail.
+ apply (ARadd_comm ARth);trivial.
+ rewrite Pjump_Pdouble_minus_one.
+ apply (ARadd_comm ARth);trivial.
+ apply (ARadd_comm ARth);trivial.
+ assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
+ rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl.
+ rewrite IHP'1;rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;Esimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;rsimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite H0;rsimpl.
+ rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)).
+ rewrite H;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+(* Proof for the symmetric version *)
+
+ Lemma PmulI_ok :
+ forall P',
+ (forall (P : Pol) (l : Env R), (Pmul P P') @ l == P @ l * P' @ l) ->
+ forall (P : Pol) (p : positive) (l : Env R),
+ (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARmul_comm ARth).
+ assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
+ rewrite H1; rewrite H;rrefl.
+ rewrite H1; rewrite H.
+ rewrite Pjump_Pplus;simpl;rrefl.
+ rewrite H1.
+ rewrite Pjump_Pplus;rewrite IHP;rrefl.
+ destruct p0;Esimpl2.
+ rewrite IHP1;rewrite IHP2;rsimpl.
+ rewrite Pjump_xO_tail.
+ mul_push (pow_pos rmul (hd 0 l) p);rrefl.
+ rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p); rewrite Pjump_Pdouble_minus_one.
+ rrefl.
+ rewrite IHP1;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p).
+ rewrite H;rrefl.
+ Qed.
+
+(*
+ Lemma PmulI_ok :
+ forall P',
+ (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) ->
+ forall (P : Pol) (p : positive) (l : list R),
+ (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARmul_comm ARth).
+ assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
+ rewrite H1; rewrite H;rrefl.
+ rewrite H1; rewrite H.
+ rewrite Pplus_comm.
+ rewrite jump_Pplus;simpl;rrefl.
+ rewrite H1;rewrite Pplus_comm.
+ rewrite jump_Pplus;rewrite IHP;rrefl.
+ destruct p0;Esimpl2.
+ rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p);rrefl.
+ rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
+ rewrite IHP1;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p).
+ rewrite H;rrefl.
+ Qed.
+
+ Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l.
+ Proof.
+ induction P';simpl;intros.
+ Esimpl2;trivial.
+ apply PmulI_ok;trivial.
+ rewrite Padd_ok;Esimpl2.
+ rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl.
+ Qed.
+*)
+
+(* Proof for the symmetric version *)
+ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Proof.
+ intros P P';generalize P;clear P;induction P';simpl;intros.
+ apply PmulC_ok. apply PmulI_ok;trivial.
+ destruct P.
+ rewrite (ARmul_comm ARth);Esimpl2;Esimpl2.
+ Esimpl2. rewrite IHP'1;Esimpl2.
+ assert (match p0 with
+ | xI j => Pinj (xO j) P ** P'2
+ | xO j => Pinj (Pdouble_minus_one j) P ** P'2
+ | 1 => P ** P'2
+ end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)).
+ destruct p0;rewrite IHP'2;Esimpl.
+ rewrite Pjump_xO_tail. reflexivity.
+ rewrite Pjump_Pdouble_minus_one;Esimpl.
+ rewrite H;Esimpl.
+ rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2.
+ repeat (rewrite IHP'1 || rewrite IHP'2);simpl.
+ rewrite PmulI_ok;trivial.
+ unfold tail.
+ mul_push (P'1@l). simpl. mul_push (P'2 @ (jump 1 l)). Esimpl.
+ Qed.
+
+(*
+Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Proof.
+ destruct P;simpl;intros.
+ Esimpl2;apply (ARmul_comm ARth).
+ rewrite (PmulI_ok P (Pmul_aux_ok P)).
+ apply (ARmul_comm ARth).
+ rewrite Padd_ok; Esimpl2.
+ rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial.
+ rewrite Pmul_aux_ok;mul_push (P' @ l).
+ rewrite (ARmul_comm ARth (P' @ l));rrefl.
+ Qed.
+*)
+
+ Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l.
+ Proof.
+ induction P;simpl;intros;Esimpl2.
+ apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2.
+ rewrite IHP1;rewrite IHP2.
+ mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l).
+ rrefl.
+ Qed.
+
+ Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) ->
+ Mphi env P = Mphi env' P.
+ Proof.
+ induction P ; simpl.
+ reflexivity.
+ intros.
+ apply IHP.
+ intros.
+ unfold jump.
+ apply H.
+ (**)
+ intros.
+ replace (Mphi (tail env) P) with (Mphi (tail env') P).
+ unfold hd. unfold nth.
+ rewrite H.
+ reflexivity.
+ apply IHP.
+ unfold tail,jump.
+ intros. symmetry. apply H.
+ Qed.
+
+Lemma Mjump_xO_tail : forall M p l,
+ Mphi (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M.
+Proof.
+ intros.
+ apply Mphi_morph.
+ intros.
+ rewrite (@jump_simpl R (xI p)).
+ rewrite (@jump_simpl R (xO p)).
+ reflexivity.
+Qed.
+
+Lemma Mjump_Pdouble_minus_one : forall M p l,
+ Mphi (jump (Pdouble_minus_one p) (tail l)) M = Mphi (jump (xO p) l) M.
+Proof.
+ intros.
+ apply Mphi_morph.
+ intros.
+ rewrite jump_Pdouble_minus_one.
+ rewrite (@jump_simpl R (xO p)).
+ reflexivity.
+Qed.
+
+Lemma Mjump_Pplus : forall M i j l, Mphi (jump (i + j) l ) M = Mphi (jump j (jump i l)) M.
+Proof.
+ intros. apply Mphi_morph. intros. rewrite <- jump_Pplus.
+ rewrite Pplus_comm.
+ reflexivity.
+Qed.
+
+
+
+ Lemma mkZmon_ok: forall M j l,
+ Mphi l (mkZmon j M) == Mphi l (zmon j M).
+ intros M j l; case M; simpl; intros; rsimpl.
+ Qed.
+
+ Lemma zmon_pred_ok : forall M j l,
+ Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M).
+ Proof.
+ destruct j; simpl;intros l; rsimpl.
+ rewrite mkZmon_ok;rsimpl.
+ simpl.
+ rewrite Mjump_xO_tail.
+ reflexivity.
+ rewrite mkZmon_ok;simpl.
+ rewrite Mjump_Pdouble_minus_one; rsimpl.
+ Qed.
+
+ Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i.
+ Proof.
+ destruct M;simpl;intros;rsimpl.
+ rewrite zmon_pred_ok;simpl;rsimpl.
+ rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+
+
+ Lemma Mphi_ok: forall P M l,
+ let (Q,R) := MFactor P M in
+ P@l == Q@l + (Mphi l M) * (R@l).
+ Proof.
+ intros P; elim P; simpl; auto; clear P.
+ intros c M l; case M; simpl; auto; try intro p; try intro m;
+ try rewrite (morph0 CRmorph); rsimpl.
+
+ intros i P Hrec M l; case M; simpl; clear M.
+ rewrite (morph0 CRmorph); rsimpl.
+ intros j M.
+ case_eq ((i ?= j) Eq); intros He; simpl.
+ rewrite (Pcompare_Eq_eq _ _ He).
+ generalize (Hrec M (jump j l)); case (MFactor P M);
+ simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+ generalize (Hrec (zmon (j -i) M) (jump i l));
+ case (MFactor P (zmon (j -i) M)); simpl.
+ intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+ rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)).
+ rewrite Mjump_Pplus; auto.
+ rewrite (morph0 CRmorph); rsimpl.
+ intros P2 m; rewrite (morph0 CRmorph); rsimpl.
+
+ intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto.
+ rewrite (morph0 CRmorph); rsimpl.
+ intros j M1.
+ generalize (Hrec1 (zmon j M1) l);
+ case (MFactor P2 (zmon j M1)).
+ intros R1 S1 H1.
+ generalize (Hrec2 (zmon_pred j M1) (tail l));
+ case (MFactor Q2 (zmon_pred j M1)); simpl.
+ intros R2 S2 H2; rewrite H1; rewrite H2.
+ repeat rewrite mkPX_ok; simpl.
+ rsimpl.
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ rewrite zmon_pred_ok;rsimpl.
+ intros j M1.
+ case_eq ((i ?= j) Eq); intros He; simpl.
+ rewrite (Pcompare_Eq_eq _ _ He).
+ generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1));
+ simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+ rewrite H; rewrite mkPX_ok; rsimpl.
+ repeat (rewrite <-(ARadd_assoc ARth)).
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ rewrite mkZmon_ok.
+ apply rmul_ext; rsimpl.
+ rewrite (ARmul_comm ARth); rsimpl.
+ generalize (Hrec1 (vmon (j - i) M1) l);
+ case (MFactor P2 (vmon (j - i) M1));
+ simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+ rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
+ rewrite mkPX_ok; rsimpl.
+ repeat (rewrite <-(ARadd_assoc ARth)).
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ apply rmul_ext; rsimpl.
+ rewrite (ARmul_comm ARth); rsimpl.
+ apply rmul_ext; rsimpl.
+ rewrite <- pow_pos_Pplus.
+ rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
+ generalize (Hrec1 (mkZmon 1 M1) l);
+ case (MFactor P2 (mkZmon 1 M1));
+ simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+ rewrite H; rsimpl.
+ rewrite mkPX_ok; rsimpl.
+ repeat (rewrite <-(ARadd_assoc ARth)).
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ rewrite mkZmon_ok.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ apply rmul_ext; rsimpl.
+ rewrite (ARmul_comm ARth); rsimpl.
+ rewrite mkPX_ok; simpl; rsimpl.
+ rewrite (morph0 CRmorph); rsimpl.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
+ apply rmul_ext; rsimpl.
+ rewrite <- pow_pos_Pplus.
+ rewrite (Pplus_minus _ _ He); rsimpl.
+ Qed.
+
+(* Proof for the symmetric version *)
+
+ Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
+ POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Proof.
+ intros P2 M1 P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
+ intros Q1 R1; case R1.
+ intros c H; rewrite H.
+ generalize (morph_eq CRmorph c cO);
+ case (c ?=! cO); simpl; auto.
+ intros H1 H2; rewrite H1; auto; rsimpl.
+ discriminate.
+ intros _ H1 H2; injection H1; intros; subst.
+ rewrite H2; rsimpl.
+ (* new version *)
+ rewrite Padd_ok; rewrite PmulC_ok; rsimpl.
+ intros i P5 H; rewrite H.
+ intros HH H1; injection HH; intros; subst; rsimpl.
+ rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl.
+ intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+ assert (P4 = Q1 ++ P3 ** PX i P5 P6).
+ injection H2; intros; subst;trivial.
+ rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl.
+Qed.
+(*
+ Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
+ POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+Proof.
+ intros P2 M1 P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
+ intros Q1 R1; case R1.
+ intros c H; rewrite H.
+ generalize (morph_eq CRmorph c cO);
+ case (c ?=! cO); simpl; auto.
+ intros H1 H2; rewrite H1; auto; rsimpl.
+ discriminate.
+ intros _ H1 H2; injection H1; intros; subst.
+ rewrite H2; rsimpl.
+ rewrite Padd_ok; rewrite Pmul_ok; rsimpl.
+ intros i P5 H; rewrite H.
+ intros HH H1; injection HH; intros; subst; rsimpl.
+ rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl.
+ intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+ injection H2; intros; subst; rsimpl.
+ rewrite Padd_ok.
+ rewrite Pmul_ok; rsimpl.
+ Qed.
+*)
+ Lemma PNSubst1_ok: forall n P1 M1 P2 l,
+ Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
+ Proof.
+ intros n; elim n; simpl; auto.
+ intros P2 M1 P3 l H.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+ case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+ intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl.
+ intros n1 Hrec P2 M1 P3 l H.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+ case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+ intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl.
+ Qed.
+
+ Lemma PNSubst_ok: forall n P1 M1 P2 l P3,
+ PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Proof.
+ intros n P2 M1 P3 l P4; unfold PNSubst.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+ case (POneSubst P2 M1 P3); [idtac | intros; discriminate].
+ intros P5 H1; case n; try (intros; discriminate).
+ intros n1 H2; injection H2; intros; subst.
+ rewrite <- PNSubst1_ok; auto.
+ Qed.
+
+ Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) {struct LM1} : Prop :=
+ match LM1 with
+ cons (M1,P2) LM2 => (Mphi l M1 == P2@l) /\ (MPcond LM2 l)
+ | _ => True
+ end.
+
+ Lemma PSubstL1_ok: forall n LM1 P1 l,
+ MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+ intros; rsimpl.
+ intros (M2,P2) LM2 Hrec P3 l [H H1].
+ rewrite <- Hrec; auto.
+ apply PNSubst1_ok; auto.
+ Qed.
+
+ Lemma PSubstL_ok: forall n LM1 P1 P2 l,
+ PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+ intros; discriminate.
+ intros (M2,P2) LM2 Hrec P3 P4 l.
+ generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n).
+ intros P5 H0 H1 [H2 H3]; injection H1; intros; subst.
+ rewrite <- PSubstL1_ok; auto.
+ intros l1 H [H1 H2]; auto.
+ Qed.
+
+ Lemma PNSubstL_ok: forall m n LM1 P1 l,
+ MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l.
+ Proof.
+ intros m; elim m; simpl; auto.
+ intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+ case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ intros m1 Hrec n LM1 P2 l H.
+ generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+ case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ rewrite <- Hrec; auto.
+ Qed.
+
+ (** Definition of polynomial expressions *)
+
+ Inductive PExpr : Type :=
+ | PEc : C -> PExpr
+ | PEX : positive -> PExpr
+ | PEadd : PExpr -> PExpr -> PExpr
+ | PEsub : PExpr -> PExpr -> PExpr
+ | PEmul : PExpr -> PExpr -> PExpr
+ | PEopp : PExpr -> PExpr
+ | PEpow : PExpr -> N -> PExpr.
+
+ (** evaluation of polynomial expressions towards R *)
+ Definition mk_X j := mkPinj_pred j mkX.
+
+ (** evaluation of polynomial expressions towards R *)
+
+ Fixpoint PEeval (l:Env R) (pe:PExpr) {struct pe} : R :=
+ match pe with
+ | PEc c => phi c
+ | PEX j => nth j l
+ | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
+ | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
+ | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
+ | PEopp pe1 => - (PEeval l pe1)
+ | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n)
+ end.
+
+ (** Correctness proofs *)
+
+ Lemma mkX_ok : forall p l, nth p l == (mk_X p) @ l.
+ Proof.
+ destruct p;simpl;intros;Esimpl;trivial.
+ rewrite nth_spec ; auto.
+ unfold hd.
+ rewrite <- nth_Pdouble_minus_one.
+ rewrite (nth_jump (Pdouble_minus_one p) l 1).
+ reflexivity.
+ Qed.
+
+ Ltac Esimpl3 :=
+ repeat match goal with
+ | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l)
+ | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l)
+ end;Esimpl2;try rrefl;try apply (ARadd_comm ARth).
+
+(* Power using the chinise algorithm *)
+(*Section POWER.
+ Variable subst_l : Pol -> Pol.
+ Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol :=
+ match p with
+ | xH => P
+ | xO p => subst_l (Psquare (Ppow_pos P p))
+ | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p)))
+ end.
+
+ Definition Ppow_N P n :=
+ match n with
+ | N0 => P1
+ | Npos p => Ppow_pos P p
+ end.
+
+ Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l.
+ Proof.
+ intros l subst_l_ok P.
+ induction p;simpl;intros;try rrefl;try rewrite subst_l_ok.
+ repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+ repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+ Qed.
+
+ Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+ Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed.
+
+ End POWER. *)
+
+Section POWER.
+ Variable subst_l : Pol -> Pol.
+ Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
+ match p with
+ | xH => subst_l (Pmul res P)
+ | xO p => Ppow_pos (Ppow_pos res P p) P p
+ | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P)
+ end.
+
+ Definition Ppow_N P n :=
+ match n with
+ | N0 => P1
+ | Npos p => Ppow_pos P1 P p
+ end.
+
+ Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
+ Proof.
+ intros l subst_l_ok res P p. generalize res;clear res.
+ induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp.
+ rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl.
+ Qed.
+
+ Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+ Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok. trivial. Esimpl. auto. Qed.
+
+ End POWER.
+
+ (** Normalization and rewriting *)
+
+ Section NORM_SUBST_REC.
+ Variable n : nat.
+ Variable lmp:list (Mon*Pol).
+ Let subst_l P := PNSubstL P lmp n n.
+ Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
+ Let Ppow_subst := Ppow_N subst_l.
+
+ Fixpoint norm_aux (pe:PExpr) : Pol :=
+ match pe with
+ | PEc c => Pc c
+ | PEX j => mk_X j
+ | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1)
+ | PEadd pe1 (PEopp pe2) =>
+ Psub (norm_aux pe1) (norm_aux pe2)
+ | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2)
+ | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2)
+ | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2)
+ | PEopp pe1 => Popp (norm_aux pe1)
+ | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
+ end.
+
+ Definition norm_subst pe := subst_l (norm_aux pe).
+
+ (*
+ Fixpoint norm_subst (pe:PExpr) : Pol :=
+ match pe with
+ | PEc c => Pc c
+ | PEX j => subst_l (mk_X j)
+ | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1)
+ | PEadd pe1 (PEopp pe2) =>
+ Psub (norm_subst pe1) (norm_subst pe2)
+ | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2)
+ | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2)
+ | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2)
+ | PEopp pe1 => Popp (norm_subst pe1)
+ | PEpow pe1 n => Ppow_subst (norm_subst pe1) n
+ end.
+
+ Lemma norm_subst_spec :
+ forall l pe, MPcond lmp l ->
+ PEeval l pe == (norm_subst pe)@l.
+ Proof.
+ intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l).
+ unfold subst_l;intros.
+ rewrite <- PNSubstL_ok;trivial. rrefl.
+ assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l).
+ intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl.
+ induction pe;simpl;Esimpl3.
+ rewrite subst_l_ok;apply mkX_ok.
+ rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
+ rewrite IHpe1;rewrite IHpe2;rrefl.
+ rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl.
+ rewrite IHpe;rrefl.
+ unfold Ppow_subst. rewrite Ppow_N_ok. trivial.
+ rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+ induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
+ repeat rewrite Pmul_ok;rrefl.
+ Qed.
+*)
+ Lemma norm_aux_spec :
+ forall l pe, (*MPcond lmp l ->*)
+ PEeval l pe == (norm_aux pe)@l.
+ Proof.
+ intros.
+ induction pe;simpl;Esimpl3.
+ apply mkX_ok.
+ rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
+ rewrite IHpe1;rewrite IHpe2;rrefl.
+ rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
+ rewrite IHpe;rrefl.
+ rewrite Ppow_N_ok by reflexivity.
+ rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+ induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
+ repeat rewrite Pmul_ok;rrefl.
+ Qed.
+
+
+ End NORM_SUBST_REC.
+
+
+End MakeRingPol.
+
diff --git a/contrib/micromega/LICENSE.sos b/contrib/micromega/LICENSE.sos
new file mode 100644
index 00000000..5aadfa2a
--- /dev/null
+++ b/contrib/micromega/LICENSE.sos
@@ -0,0 +1,29 @@
+ HOL Light copyright notice, licence and disclaimer
+
+ (c) University of Cambridge 1998
+ (c) Copyright, John Harrison 1998-2006
+
+HOL Light version 2.20, hereinafter referred to as "the software", is a
+computer theorem proving system written by John Harrison. Much of the
+software was developed at the University of Cambridge Computer Laboratory,
+New Museums Site, Pembroke Street, Cambridge, CB2 3QG, England. The
+software is copyright, University of Cambridge 1998 and John Harrison
+1998-2006.
+
+Permission to use, copy, modify, and distribute the software and its
+documentation for any purpose and without fee is hereby granted. In the
+case of further distribution of the software the present text, including
+copyright notice, licence and disclaimer of warranty, must be included in
+full and unmodified form in any release. Distribution of derivative
+software obtained by modifying the software, or incorporating it into
+other software, is permitted, provided the inclusion of the software is
+acknowledged and that any changes made to the software are clearly
+documented.
+
+John Harrison and the University of Cambridge disclaim all warranties
+with regard to the software, including all implied warranties of
+merchantability and fitness. In no event shall John Harrison or the
+University of Cambridge be liable for any special, indirect,
+incidental or consequential damages or any damages whatsoever,
+including, but not limited to, those arising from computer failure or
+malfunction, work stoppage, loss of profit or loss of contracts.
diff --git a/contrib/micromega/MExtraction.v b/contrib/micromega/MExtraction.v
new file mode 100644
index 00000000..a5ac92db
--- /dev/null
+++ b/contrib/micromega/MExtraction.v
@@ -0,0 +1,23 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+(* Used to generate micromega.ml *)
+
+Require Import ZMicromega.
+Require Import QMicromega.
+Require Import VarMap.
+Require Import RingMicromega.
+Require Import NArith.
+
+Extraction "micromega.ml" List.map simpl_cone map_cone indexes n_of_Z Nnat.N_of_nat ZTautoChecker QTautoChecker find.
diff --git a/contrib/micromega/Micromegatac.v b/contrib/micromega/Micromegatac.v
new file mode 100644
index 00000000..13c7eace
--- /dev/null
+++ b/contrib/micromega/Micromegatac.v
@@ -0,0 +1,79 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import ZMicromega.
+Require Import QMicromega.
+Require Import RMicromega.
+Require Import QArith.
+Require Export Ring_normalize.
+Require Import ZArith.
+Require Import Raxioms.
+Require Export RingMicromega.
+Require Import VarMap.
+Require Tauto.
+
+Ltac micromegac dom d :=
+ let tac := lazymatch dom with
+ | Z =>
+ micromegap d ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+ apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+ | R =>
+ rmicromegap d ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
+ apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+ | _ => fail "Unsupported domain"
+ end in tac.
+
+Tactic Notation "micromega" constr(dom) int_or_var(n) := micromegac dom n.
+Tactic Notation "micromega" constr(dom) := micromegac dom ltac:-1.
+
+Ltac zfarkas := omicronp ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+ apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
+
+Ltac omicron dom :=
+ let tac := lazymatch dom with
+ | Z =>
+ zomicronp ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+ apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+ | Q =>
+ qomicronp ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
+ apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+ | R =>
+ romicronp ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
+ apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+ | _ => fail "Unsupported domain"
+ end in tac.
+
+Ltac sos dom :=
+ let tac := lazymatch dom with
+ | Z =>
+ sosp ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+ apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+ | _ => fail "Unsupported domain"
+ end in tac.
+
+
diff --git a/contrib/micromega/OrderedRing.v b/contrib/micromega/OrderedRing.v
new file mode 100644
index 00000000..149b7731
--- /dev/null
+++ b/contrib/micromega/OrderedRing.v
@@ -0,0 +1,458 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* Evgeny Makarov, INRIA, 2007 *)
+(************************************************************************)
+
+Require Import Setoid.
+Require Import Ring.
+
+(** Generic properties of ordered rings on a setoid equality *)
+
+Set Implicit Arguments.
+
+Module Import OrderedRingSyntax.
+Export RingSyntax.
+
+Reserved Notation "x ~= y" (at level 70, no associativity).
+Reserved Notation "x [=] y" (at level 70, no associativity).
+Reserved Notation "x [~=] y" (at level 70, no associativity).
+Reserved Notation "x [<] y" (at level 70, no associativity).
+Reserved Notation "x [<=] y" (at level 70, no associativity).
+End OrderedRingSyntax.
+
+Section DEFINITIONS.
+
+Variable R : Type.
+Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
+Variable req rle rlt : R -> R -> Prop.
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+Record SOR : Type := mk_SOR_theory {
+ SORsetoid : Setoid_Theory R req;
+ SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
+ SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2;
+ SORopp_wd : forall x1 x2, x1 == x2 -> -x1 == -x2;
+ SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2);
+ SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2);
+ SORrt : ring_theory rO rI rplus rtimes rminus ropp req;
+ SORle_refl : forall n : R, n <= n;
+ SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m;
+ SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p;
+ SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m;
+ SORlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n;
+ SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m;
+ SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m;
+ SORneq_0_1 : 0 ~= 1
+}.
+
+(* We cannot use Relation_Definitions.order.ord_antisym and
+Relations_1.Antisymmetric because they refer to Leibniz equality *)
+
+End DEFINITIONS.
+
+Section STRICT_ORDERED_RING.
+
+Variable R : Type.
+Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
+Variable req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+
+Add Relation R req
+ reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
+ symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
+ transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+as sor_setoid.
+
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+exact sor.(SORlt_wd).
+Qed.
+
+Add Ring SOR : sor.(SORrt).
+
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+intros x1 x2 H1 y1 y2 H2.
+rewrite (sor.(SORrt).(Rsub_def) x1 y1).
+rewrite (sor.(SORrt).(Rsub_def) x2 y2).
+rewrite H1; now rewrite H2.
+Qed.
+
+Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n.
+Proof.
+intros n m H1 H2; rewrite H2 in H1; now apply H1.
+Qed.
+
+(* Propeties of plus, minus and opp *)
+
+Theorem Rplus_0_l : forall n : R, 0 + n == n.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rplus_0_r : forall n : R, n + 0 == n.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rtimes_0_r : forall n : R, n * 0 == 0.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rplus_comm : forall n m : R, n + m == m + n.
+Proof.
+intros; ring.
+Qed.
+
+Theorem Rtimes_0_l : forall n : R, 0 * n == 0.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rtimes_comm : forall n m : R, n * m == m * n.
+Proof.
+intros; ring.
+Qed.
+
+Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m.
+Proof.
+intros n m.
+split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H.
+now rewrite Rplus_0_l.
+rewrite H; ring.
+Qed.
+
+Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m.
+Proof.
+intros n m p; split; intro H.
+setoid_replace n with (- p + (p + n)) by ring.
+setoid_replace m with (- p + (p + m)) by ring. now rewrite H.
+now rewrite H.
+Qed.
+
+(* Relations *)
+
+Theorem Rle_refl : forall n : R, n <= n.
+Proof sor.(SORle_refl).
+
+Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m.
+Proof sor.(SORle_antisymm).
+
+Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p.
+Proof sor.(SORle_trans).
+
+Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n.
+Proof sor.(SORlt_trichotomy).
+
+Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m.
+Proof sor.(SORlt_le_neq).
+
+Theorem Rneq_0_1 : 0 ~= 1.
+Proof sor.(SORneq_0_1).
+
+Theorem Req_em : forall n m : R, n == m \/ n ~= m.
+Proof.
+intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H.
+right; now destruct H.
+now left.
+right; apply Rneq_symm; now destruct H.
+Qed.
+
+Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m.
+Proof.
+intros n m; destruct (Req_em n m) as [H | H].
+split; auto.
+split. intro H1; false_hyp H H1. auto.
+Qed.
+
+Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m.
+Proof.
+intros n m; rewrite Rlt_le_neq.
+split; [intro H | intros [[H1 H2] | H]].
+destruct (Req_em n m) as [H1 | H1]. now right. left; now split.
+assumption.
+rewrite H; apply Rle_refl.
+Qed.
+
+Ltac le_less := rewrite Rle_lt_eq; left; try assumption.
+Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption.
+Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H].
+
+Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p.
+Proof.
+intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split.
+now apply Rle_trans with m.
+intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4.
+Qed.
+
+Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p.
+Proof.
+intros n m p H1 H2; le_elim H1.
+now apply Rlt_trans with (m := m). now rewrite H1.
+Qed.
+
+Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p.
+Proof.
+intros n m p H1 H2; le_elim H2.
+now apply Rlt_trans with (m := m). now rewrite <- H2.
+Qed.
+
+Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n.
+Proof.
+intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]].
+left; now le_less. left; now le_equal. now right.
+Qed.
+
+Theorem Rlt_neq : forall n m : R, n < m -> n ~= m.
+Proof.
+intros n m; rewrite Rlt_le_neq; now intros [_ H].
+Qed.
+
+Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n.
+Proof.
+intros n m; split.
+intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2).
+intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H.
+Qed.
+
+Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n.
+Proof.
+intros n m; split.
+intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2).
+intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption.
+Qed.
+
+(* Plus, minus and order *)
+
+Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m.
+Proof.
+intros n m p; split.
+apply sor.(SORplus_le_mono_l).
+intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H.
+setoid_replace (- p + (p + n)) with n in H by ring.
+setoid_replace (- p + (p + m)) with m in H by ring. assumption.
+Qed.
+
+Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p.
+Proof.
+intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p).
+apply Rplus_le_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m.
+Proof.
+intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l.
+now rewrite <- Rplus_le_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p.
+Proof.
+intros n m p.
+rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l].
+Qed.
+
+Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l].
+Qed.
+
+Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l].
+Qed.
+
+Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l].
+Qed.
+
+Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono.
+Qed.
+
+Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono.
+Qed.
+
+Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono.
+Qed.
+
+Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono.
+Qed.
+
+Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n.
+Proof.
+intros n m. rewrite (@Rplus_le_mono_r n m (- n)).
+setoid_replace (n + - n) with 0 by ring.
+now setoid_replace (m + - n) with (m - n) by ring.
+Qed.
+
+Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n.
+Proof.
+intros n m. rewrite (@Rplus_lt_mono_r n m (- n)).
+setoid_replace (n + - n) with 0 by ring.
+now setoid_replace (m + - n) with (m - n) by ring.
+Qed.
+
+Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n.
+Proof.
+intros n m. split; intro H.
+apply -> (@Rplus_lt_mono_l n m (- n - m)) in H.
+setoid_replace (- n - m + n) with (- m) in H by ring.
+now setoid_replace (- n - m + m) with (- n) in H by ring.
+apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H.
+setoid_replace (n + m + - m) with n in H by ring.
+now setoid_replace (n + m + - n) with m in H by ring.
+Qed.
+
+Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0.
+Proof.
+intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring.
+Qed.
+
+(* Times and order *)
+
+Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m.
+Proof sor.(SORtimes_pos_pos).
+
+Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m.
+Proof.
+intros n m H1 H2.
+le_elim H1. le_elim H2.
+le_less; now apply Rtimes_pos_pos.
+rewrite <- H2; rewrite Rtimes_0_r; le_equal.
+rewrite <- H1; rewrite Rtimes_0_l; le_equal.
+Qed.
+
+Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0.
+Proof.
+intros n m H1 H2. apply -> Ropp_pos_neg.
+setoid_replace (- (n * m)) with (n * (- m)) by ring.
+apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg.
+Qed.
+
+Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m.
+Proof.
+intros n m H1 H2.
+setoid_replace (n * m) with ((- n) * (- m)) by ring.
+apply Rtimes_pos_pos; now apply <- Ropp_pos_neg.
+Qed.
+
+Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n.
+Proof.
+intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]].
+le_less; now apply Rtimes_pos_pos.
+rewrite <- H, Rtimes_0_l; le_equal.
+le_less; now apply Rtimes_neg_neg.
+Qed.
+
+Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0.
+Proof.
+intros n m [H1 H2].
+destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]];
+destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]];
+try (false_hyp H3 H1); try (false_hyp H4 H2).
+apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg.
+apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg.
+apply Rlt_neq. now apply Rtimes_pos_neg.
+apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos.
+Qed.
+
+(* The following theorems are used to build a morphism from Z to R and
+prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *)
+
+(* Surprisingly, multilication is needed to prove the following theorem *)
+
+Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n.
+Proof.
+intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg.
+now setoid_replace (- - n) with n by ring.
+Qed.
+
+Theorem Rlt_0_1 : 0 < 1.
+Proof.
+apply <- Rlt_le_neq. split.
+setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg.
+apply Rneq_0_1.
+Qed.
+
+Theorem Rlt_succ_r : forall n : R, n < 1 + n.
+Proof.
+intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring.
+apply -> Rplus_lt_mono_r. apply Rlt_0_1.
+Qed.
+
+Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m.
+Proof.
+intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r.
+Qed.
+
+(*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m.
+Proof.
+intros n m p H1 H2. apply <- Rlt_lt_minus.
+setoid_replace (p * m - p * n) with (p * (m - n)) by ring.
+apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus.
+Qed.*)
+
+End STRICT_ORDERED_RING.
+
diff --git a/contrib/micromega/QMicromega.v b/contrib/micromega/QMicromega.v
new file mode 100644
index 00000000..9e95f6c4
--- /dev/null
+++ b/contrib/micromega/QMicromega.v
@@ -0,0 +1,259 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import Refl.
+Require Import QArith.
+Require Import Qring.
+
+(* Qsrt has been removed from the library ? *)
+Definition Qsrt : ring_theory 0 1 Qplus Qmult Qminus Qopp Qeq.
+Proof.
+ constructor.
+ exact Qplus_0_l.
+ exact Qplus_comm.
+ exact Qplus_assoc.
+ exact Qmult_1_l.
+ exact Qmult_comm.
+ exact Qmult_assoc.
+ exact Qmult_plus_distr_l.
+ reflexivity.
+ exact Qplus_opp_r.
+Qed.
+
+
+Add Ring Qring : Qsrt.
+
+Lemma Qmult_neutral : forall x , 0 * x == 0.
+Proof.
+ intros.
+ compute.
+ reflexivity.
+Qed.
+
+(* Is there any qarith database ? *)
+
+Lemma Qsor : SOR 0 1 Qplus Qmult Qminus Qopp Qeq Qle Qlt.
+Proof.
+ constructor; intros ; subst ; try (intuition (subst; auto with qarith)).
+ apply Q_Setoid.
+ rewrite H ; rewrite H0 ; reflexivity.
+ rewrite H ; rewrite H0 ; reflexivity.
+ rewrite H ; auto ; reflexivity.
+ rewrite <- H ; rewrite <- H0 ; auto.
+ rewrite H ; rewrite H0 ; auto.
+ rewrite <- H ; rewrite <- H0 ; auto.
+ rewrite H ; rewrite H0 ; auto.
+ apply Qsrt.
+ apply Qle_refl.
+ apply Qle_antisym ; auto.
+ eapply Qle_trans ; eauto.
+ apply Qlt_le_weak ; auto.
+ apply (Qlt_not_eq n m H H0) ; auto.
+ destruct (Qle_lt_or_eq _ _ H0) ; auto.
+ tauto.
+ destruct(Q_dec n m) as [[H1 |H1] | H1 ] ; tauto.
+ apply (Qplus_le_compat p p n m (Qle_refl p) H).
+ generalize (Qmult_lt_compat_r 0 n m H0 H).
+ rewrite Qmult_neutral.
+ auto.
+ compute in H.
+ discriminate.
+Qed.
+
+Definition Qeq_bool (p q : Q) : bool := Zeq_bool (Qnum p * ' Qden q)%Z (Qnum q * ' Qden p)%Z.
+
+Definition Qle_bool (x y : Q) : bool := Zle_bool (Qnum x * ' Qden y)%Z (Qnum y * ' Qden x)%Z.
+
+Require ZMicromega.
+
+Lemma Qeq_bool_ok : forall x y, Qeq_bool x y = true -> x == y.
+Proof.
+ intros.
+ unfold Qeq_bool in H.
+ unfold Qeq.
+ apply (Zeqb_ok _ _ H).
+Qed.
+
+
+Lemma Qeq_bool_neq : forall x y, Qeq_bool x y = false -> ~ x == y.
+Proof.
+ unfold Qeq_bool,Qeq.
+ red ; intros ; subst.
+ rewrite H0 in H.
+ apply (ZMicromega.Zeq_bool_neq _ _ H).
+ reflexivity.
+Qed.
+
+Lemma Qle_bool_imp_le : forall x y : Q, Qle_bool x y = true -> x <= y.
+Proof.
+ unfold Qle_bool, Qle.
+ intros.
+ apply Zle_bool_imp_le ; auto.
+Qed.
+
+
+
+
+Lemma QSORaddon :
+ SORaddon 0 1 Qplus Qmult Qminus Qopp Qeq Qle (* ring elements *)
+ 0 1 Qplus Qmult Qminus Qopp (* coefficients *)
+ Qeq_bool Qle_bool
+ (fun x => x) (fun x => x) (pow_N 1 Qmult).
+Proof.
+ constructor.
+ constructor ; intros ; try reflexivity.
+ apply Qeq_bool_ok ; auto.
+ constructor.
+ reflexivity.
+ intros x y.
+ apply Qeq_bool_neq ; auto.
+ apply Qle_bool_imp_le.
+Qed.
+
+
+(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*)
+Require Import EnvRing.
+
+Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q :=
+ match e with
+ | PEc c => c
+ | PEX j => env j
+ | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
+ | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
+ | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
+ | PEopp pe1 => - (Qeval_expr env pe1)
+ | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n)
+ end.
+
+Lemma Qeval_expr_simpl : forall env e,
+ Qeval_expr env e =
+ match e with
+ | PEc c => c
+ | PEX j => env j
+ | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
+ | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
+ | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
+ | PEopp pe1 => - (Qeval_expr env pe1)
+ | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n)
+ end.
+Proof.
+ destruct e ; reflexivity.
+Qed.
+
+Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult).
+
+Lemma QNpower : forall r n, r ^ Z_of_N n = pow_N 1 Qmult r n.
+Proof.
+ destruct n ; reflexivity.
+Qed.
+
+
+Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e.
+Proof.
+ induction e ; simpl ; subst ; try congruence.
+ rewrite IHe.
+ apply QNpower.
+Qed.
+
+Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop :=
+match o with
+| OpEq => Qeq
+| OpNEq => fun x y => ~ x == y
+| OpLe => Qle
+| OpGe => Qge
+| OpLt => Qlt
+| OpGt => Qgt
+end.
+
+Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) :=
+ let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs).
+
+Definition Qeval_formula' :=
+ eval_formula Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult).
+
+Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f.
+Proof.
+ intros.
+ unfold Qeval_formula.
+ destruct f.
+ repeat rewrite Qeval_expr_compat.
+ unfold Qeval_formula'.
+ unfold Qeval_expr'.
+ split ; destruct Fop ; simpl; auto.
+Qed.
+
+
+
+Definition Qeval_nformula :=
+ eval_nformula 0 Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult).
+
+Definition Qeval_op1 (o : Op1) : Q -> Prop :=
+match o with
+| Equal => fun x : Q => x == 0
+| NonEqual => fun x : Q => ~ x == 0
+| Strict => fun x : Q => 0 < x
+| NonStrict => fun x : Q => 0 <= x
+end.
+
+Lemma Qeval_nformula_simpl : forall env f, Qeval_nformula env f = (let (p, op) := f in Qeval_op1 op (Qeval_expr env p)).
+Proof.
+ intros.
+ destruct f.
+ rewrite Qeval_expr_compat.
+ reflexivity.
+Qed.
+
+Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d).
+Proof.
+ exact (fun env d =>eval_nformula_dec Qsor (fun x => x) (fun x => x) (pow_N 1 Qmult) env d).
+Qed.
+
+Definition QWitness := ConeMember Q.
+
+Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool.
+
+Require Import List.
+
+Lemma QWeakChecker_sound : forall (l : list (NFormula Q)) (cm : QWitness),
+ QWeakChecker l cm = true ->
+ forall env, make_impl (Qeval_nformula env) l False.
+Proof.
+ intros l cm H.
+ intro.
+ unfold Qeval_nformula.
+ apply (checker_nf_sound Qsor QSORaddon l cm).
+ unfold QWeakChecker in H.
+ exact H.
+Qed.
+
+Require Import Tauto.
+
+Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool :=
+ @tauto_checker (Formula Q) (NFormula Q) (@cnf_normalise Q) (@cnf_negate Q) QWitness QWeakChecker f w.
+
+Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f (Qeval_formula env) f.
+Proof.
+ intros f w.
+ unfold QTautoChecker.
+ apply (tauto_checker_sound Qeval_formula Qeval_nformula).
+ apply Qeval_nformula_dec.
+ intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor).
+ intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor).
+ intros t w0.
+ apply QWeakChecker_sound.
+Qed.
+
+
diff --git a/contrib/micromega/RMicromega.v b/contrib/micromega/RMicromega.v
new file mode 100644
index 00000000..ef28db32
--- /dev/null
+++ b/contrib/micromega/RMicromega.v
@@ -0,0 +1,148 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import Refl.
+Require Import Raxioms RIneq Rpow_def DiscrR.
+Require Setoid.
+
+Definition Rsrt : ring_theory R0 R1 Rplus Rmult Rminus Ropp (@eq R).
+Proof.
+ constructor.
+ exact Rplus_0_l.
+ exact Rplus_comm.
+ intros. rewrite Rplus_assoc. auto.
+ exact Rmult_1_l.
+ exact Rmult_comm.
+ intros ; rewrite Rmult_assoc ; auto.
+ intros. rewrite Rmult_comm. rewrite Rmult_plus_distr_l.
+ rewrite (Rmult_comm z). rewrite (Rmult_comm z). auto.
+ reflexivity.
+ exact Rplus_opp_r.
+Qed.
+
+Add Ring Rring : Rsrt.
+Open Scope R_scope.
+
+Lemma Rmult_neutral : forall x:R , 0 * x = 0.
+Proof.
+ intro ; ring.
+Qed.
+
+
+Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt.
+Proof.
+ constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)).
+ constructor.
+ constructor.
+ unfold RelationClasses.Symmetric. auto.
+ unfold RelationClasses.Transitive. intros. subst. reflexivity.
+ apply Rsrt.
+ eapply Rle_trans ; eauto.
+ apply (Rlt_irrefl m) ; auto.
+ apply Rnot_le_lt. auto with real.
+ destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto.
+ intros.
+ rewrite <- (Rmult_neutral m).
+ apply (Rmult_lt_compat_r) ; auto.
+Qed.
+
+Require ZMicromega.
+
+(* R with coeffs in Z *)
+
+Lemma RZSORaddon :
+ SORaddon R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *)
+ 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
+ Zeq_bool Zle_bool
+ IZR Nnat.nat_of_N pow.
+Proof.
+ constructor.
+ constructor ; intros ; try reflexivity.
+ apply plus_IZR.
+ symmetry. apply Z_R_minus.
+ apply mult_IZR.
+ apply Ropp_Ropp_IZR.
+ apply IZR_eq.
+ apply Zeqb_ok ; auto.
+ apply R_power_theory.
+ intros x y.
+ intro.
+ apply IZR_neq.
+ apply ZMicromega.Zeq_bool_neq ; auto.
+ intros. apply IZR_le. apply Zle_bool_imp_le. auto.
+Qed.
+
+
+Require Import EnvRing.
+
+Definition INZ (n:N) : R :=
+ match n with
+ | N0 => IZR 0%Z
+ | Npos p => IZR (Zpos p)
+ end.
+
+Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp IZR Nnat.nat_of_N pow.
+
+
+Definition Reval_formula :=
+ eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow.
+
+
+Definition Reval_nformula :=
+ eval_nformula 0 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow.
+
+
+Lemma Reval_nformula_dec : forall env d, (Reval_nformula env d) \/ ~ (Reval_nformula env d).
+Proof.
+ exact (fun env d =>eval_nformula_dec Rsor IZR Nnat.nat_of_N pow env d).
+Qed.
+
+Definition RWitness := ConeMember Z.
+
+Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool Zle_bool.
+
+Require Import List.
+
+Lemma RWeakChecker_sound : forall (l : list (NFormula Z)) (cm : RWitness),
+ RWeakChecker l cm = true ->
+ forall env, make_impl (Reval_nformula env) l False.
+Proof.
+ intros l cm H.
+ intro.
+ unfold Reval_nformula.
+ apply (checker_nf_sound Rsor RZSORaddon l cm).
+ unfold RWeakChecker in H.
+ exact H.
+Qed.
+
+Require Import Tauto.
+
+Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness) : bool :=
+ @tauto_checker (Formula Z) (NFormula Z) (@cnf_normalise Z) (@cnf_negate Z) RWitness RWeakChecker f w.
+
+Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f (Reval_formula env) f.
+Proof.
+ intros f w.
+ unfold RTautoChecker.
+ apply (tauto_checker_sound Reval_formula Reval_nformula).
+ apply Reval_nformula_dec.
+ intros. unfold Reval_formula. now apply (cnf_normalise_correct Rsor).
+ intros. unfold Reval_formula. now apply (cnf_negate_correct Rsor).
+ intros t w0.
+ apply RWeakChecker_sound.
+Qed.
+
+
diff --git a/contrib/micromega/Refl.v b/contrib/micromega/Refl.v
new file mode 100644
index 00000000..801d8b21
--- /dev/null
+++ b/contrib/micromega/Refl.v
@@ -0,0 +1,129 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import List.
+Require Setoid.
+
+Set Implicit Arguments.
+
+(* Refl of '->' '/\': basic properties *)
+
+Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {struct l} : Prop :=
+ match l with
+ | nil => goal
+ | cons e l => (eval e) -> (make_impl eval l goal)
+ end.
+
+Theorem make_impl_true :
+ forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True.
+Proof.
+induction l as [| a l IH]; simpl.
+trivial.
+intro; apply IH.
+Qed.
+
+Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop :=
+ match l with
+ | nil => True
+ | cons e nil => (eval e)
+ | cons e l2 => ((eval e) /\ (make_conj eval l2))
+ end.
+
+Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A),
+ make_conj eval (a :: l) <-> eval a /\ make_conj eval l.
+Proof.
+intros; destruct l; simpl; tauto.
+Qed.
+
+
+Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop),
+ (make_conj eval l -> g) <-> make_impl eval l g.
+Proof.
+ induction l.
+ simpl.
+ tauto.
+ simpl.
+ intros.
+ destruct l.
+ simpl.
+ tauto.
+ generalize (IHl g).
+ tauto.
+Qed.
+
+Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A),
+ make_conj eval l -> (forall p, In p l -> eval p).
+Proof.
+ induction l.
+ simpl.
+ tauto.
+ simpl.
+ intros.
+ destruct l.
+ simpl in H0.
+ destruct H0.
+ subst; auto.
+ tauto.
+ destruct H.
+ destruct H0.
+ subst;auto.
+ apply IHl; auto.
+Qed.
+
+
+
+Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2.
+Proof.
+ induction l1.
+ simpl.
+ tauto.
+ intros.
+ change ((a::l1) ++ l2) with (a :: (l1 ++ l2)).
+ rewrite make_conj_cons.
+ rewrite IHl1.
+ rewrite make_conj_cons.
+ tauto.
+Qed.
+
+Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)),
+ ~ make_conj eval (t ::a) -> ~ (eval t) \/ (~ make_conj eval a).
+Proof.
+ intros.
+ simpl in H.
+ destruct a.
+ tauto.
+ tauto.
+Qed.
+
+Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval
+ (no_middle_eval : forall d, eval d \/ ~ eval d) ,
+ ~ make_conj eval (t ++ a) -> (~ make_conj eval t) \/ (~ make_conj eval a).
+Proof.
+ induction t.
+ simpl.
+ tauto.
+ intros.
+ simpl ((a::t)++a0)in H.
+ destruct (@not_make_conj_cons _ _ _ _ (no_middle_eval a) H).
+ left ; red ; intros.
+ apply H0.
+ rewrite make_conj_cons in H1.
+ tauto.
+ destruct (IHt _ _ no_middle_eval H0).
+ left ; red ; intros.
+ apply H1.
+ rewrite make_conj_cons in H2.
+ tauto.
+ right ; auto.
+Qed.
diff --git a/contrib/micromega/RingMicromega.v b/contrib/micromega/RingMicromega.v
new file mode 100644
index 00000000..6885b82c
--- /dev/null
+++ b/contrib/micromega/RingMicromega.v
@@ -0,0 +1,779 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* Evgeny Makarov, INRIA, 2007 *)
+(************************************************************************)
+
+Require Import NArith.
+Require Import Relation_Definitions.
+Require Import Setoid.
+(*****)
+Require Import Env.
+Require Import EnvRing.
+(*****)
+Require Import List.
+Require Import Bool.
+Require Import OrderedRing.
+Require Import Refl.
+
+
+Set Implicit Arguments.
+
+Import OrderedRingSyntax.
+
+Section Micromega.
+
+(* Assume we have a strict(ly?) ordered ring *)
+
+Variable R : Type.
+Variables rO rI : R.
+Variables rplus rtimes rminus: R -> R -> R.
+Variable ropp : R -> R.
+Variables req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+(* Assume we have a type of coefficients C and a morphism from C to R *)
+
+Variable C : Type.
+Variables cO cI : C.
+Variables cplus ctimes cminus: C -> C -> C.
+Variable copp : C -> C.
+Variables ceqb cleb : C -> C -> bool.
+Variable phi : C -> R.
+
+(* Power coefficients *)
+Variable E : Set. (* the type of exponents *)
+Variable pow_phi : N -> E.
+Variable rpow : R -> E -> R.
+
+Notation "[ x ]" := (phi x).
+Notation "x [=] y" := (ceqb x y).
+Notation "x [<=] y" := (cleb x y).
+
+(* Let's collect all hypotheses in addition to the ordered ring axioms into
+one structure *)
+
+Record SORaddon := mk_SOR_addon {
+ SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi;
+ SORpower : power_theory rI rtimes req pow_phi rpow;
+ SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y];
+ SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y]
+}.
+
+Variable addon : SORaddon.
+
+Add Relation R req
+ reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
+ symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
+ transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+as micomega_sor_setoid.
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+ exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+ exact sor.(SORlt_wd).
+Qed.
+
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+ exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *)
+Qed.
+
+Definition cneqb (x y : C) := negb (ceqb x y).
+Definition cltb (x y : C) := (cleb x y) && (cneqb x y).
+
+Notation "x [~=] y" := (cneqb x y).
+Notation "x [<] y" := (cltb x y).
+
+Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
+Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
+Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H].
+
+Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y].
+Proof.
+ exact addon.(SORcleb_morph).
+Qed.
+
+Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y].
+Proof.
+intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1.
+destruct (ceqb x y); now try discriminate.
+Qed.
+
+Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y].
+Proof.
+intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2].
+apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split.
+Qed.
+
+(* Begin Micromega *)
+
+Definition PExprC := PExpr C. (* arbitrary expressions built from +, *, - *)
+Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
+(*****)
+(*Definition Env := Env R. (* For interpreting PExprC *)*)
+Definition PolEnv := Env R. (* For interpreting PolC *)
+(*****)
+(*Definition Env := list R.
+Definition PolEnv := list R.*)
+(*****)
+
+(* What benefit do we get, in the case of EnvRing, from defining eval_pexpr
+explicitely below and not through PEeval, as the following lemma says? The
+function eval_pexpr seems to be a straightforward special case of PEeval
+when the environment (i.e., the second last argument of PEeval) of type
+off_map (which is (option positive * t)) is (None, env). *)
+
+(*****)
+Fixpoint eval_pexpr (l : PolEnv) (pe : PExprC) {struct pe} : R :=
+match pe with
+| PEc c => phi c
+| PEX j => l j
+| PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2)
+| PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2)
+| PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2)
+| PEopp pe1 => - (eval_pexpr l pe1)
+| PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n)
+end.
+
+
+Lemma eval_pexpr_simpl : forall (l : PolEnv) (pe : PExprC),
+ eval_pexpr l pe =
+ match pe with
+ | PEc c => phi c
+ | PEX j => l j
+ | PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2)
+ | PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2)
+ | PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2)
+ | PEopp pe1 => - (eval_pexpr l pe1)
+ | PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n)
+ end.
+Proof.
+ intros ; destruct pe ; reflexivity.
+Qed.
+
+
+
+Lemma eval_pexpr_PEeval : forall (env : PolEnv) (pe : PExprC),
+ eval_pexpr env pe =
+ PEeval rplus rtimes rminus ropp phi pow_phi rpow env pe.
+Proof.
+induction pe; simpl; intros.
+reflexivity.
+reflexivity.
+rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
+rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
+rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
+rewrite <- IHpe; reflexivity.
+rewrite <- IHpe; reflexivity.
+Qed.
+(*****)
+(*Definition eval_pexpr : Env -> PExprC -> R :=
+ PEeval 0 rplus rtimes rminus ropp phi pow_phi rpow.*)
+(*****)
+
+Inductive Op1 : Set := (* relations with 0 *)
+| Equal (* == 0 *)
+| NonEqual (* ~= 0 *)
+| Strict (* > 0 *)
+| NonStrict (* >= 0 *).
+
+Definition NFormula := (PExprC * Op1)%type. (* normalized formula *)
+
+Definition eval_op1 (o : Op1) : R -> Prop :=
+match o with
+| Equal => fun x => x == 0
+| NonEqual => fun x : R => x ~= 0
+| Strict => fun x : R => 0 < x
+| NonStrict => fun x : R => 0 <= x
+end.
+
+Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop :=
+let (p, op) := f in eval_op1 op (eval_pexpr env p).
+
+
+Definition OpMult (o o' : Op1) : Op1 :=
+match o with
+| Equal => Equal
+| NonStrict => NonStrict (* (OpMult NonStrict Equal) could be defined as Equal *)
+| Strict => o'
+| NonEqual => NonEqual (* does not matter what we return here; see the following lemmas *)
+end.
+
+Definition OpAdd (o o': Op1) : Op1 :=
+match o with
+| Equal => o'
+| NonStrict =>
+ match o' with
+ | Strict => Strict
+ | _ => NonStrict
+ end
+| Strict => Strict
+| NonEqual => NonEqual (* does not matter what we return here *)
+end.
+
+Lemma OpMultNonEqual :
+ forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpMult o o' <> NonEqual.
+Proof.
+intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate;
+try (intro H; apply H1; reflexivity);
+try (intro H; apply H2; reflexivity).
+Qed.
+
+Lemma OpAdd_NonEqual :
+ forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpAdd o o' <> NonEqual.
+Proof.
+intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate;
+try (intro H; apply H1; reflexivity);
+try (intro H; apply H2; reflexivity).
+Qed.
+
+Lemma OpMult_sound :
+ forall (o o' : Op1) (x y : R), o <> NonEqual -> o' <> NonEqual ->
+ eval_op1 o x -> eval_op1 o' y -> eval_op1 (OpMult o o') (x * y).
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' x y H1 H2 H3 H4.
+rewrite H3; now rewrite (Rtimes_0_l sor).
+elimtype False; now apply H1.
+destruct o'.
+rewrite H4; now rewrite (Rtimes_0_r sor).
+elimtype False; now apply H2.
+now apply (Rtimes_pos_pos sor).
+apply (Rtimes_nonneg_nonneg sor); [le_less | assumption].
+destruct o'.
+rewrite H4, (Rtimes_0_r sor); le_equal.
+elimtype False; now apply H2.
+apply (Rtimes_nonneg_nonneg sor); [assumption | le_less].
+now apply (Rtimes_nonneg_nonneg sor).
+Qed.
+
+Lemma OpAdd_sound :
+ forall (o o' : Op1) (e e' : R), o <> NonEqual -> o' <> NonEqual ->
+ eval_op1 o e -> eval_op1 o' e' -> eval_op1 (OpAdd o o') (e + e').
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' e e' H1 H2 H3 H4.
+destruct o'.
+now rewrite H3, H4, (Rplus_0_l sor).
+elimtype False; now apply H2.
+now rewrite H3, (Rplus_0_l sor).
+now rewrite H3, (Rplus_0_l sor).
+elimtype False; now apply H1.
+destruct o'.
+now rewrite H4, (Rplus_0_r sor).
+elimtype False; now apply H2.
+now apply (Rplus_pos_pos sor).
+now apply (Rplus_pos_nonneg sor).
+destruct o'.
+now rewrite H4, (Rplus_0_r sor).
+elimtype False; now apply H2.
+now apply (Rplus_nonneg_pos sor).
+now apply (Rplus_nonneg_nonneg sor).
+Qed.
+
+(* We consider a monoid whose generators are polynomials from the
+hypotheses of the form (p ~= 0). Thus it follows from the hypotheses that
+every element of the monoid (i.e., arbitrary product of generators) is ~=
+0. Therefore, the square of every element is > 0. *)
+
+Inductive Monoid (l : list NFormula) : PExprC -> Prop :=
+| M_One : Monoid l (PEc cI)
+| M_In : forall p : PExprC, In (p, NonEqual) l -> Monoid l p
+| M_Mult : forall (e1 e2 : PExprC), Monoid l e1 -> Monoid l e2 -> Monoid l (PEmul e1 e2).
+
+(* Do we really need to rely on the intermediate definition of monoid ?
+ InC why the restriction NonEqual ?
+ Could not we consider the IsIdeal as a IsMult ?
+ The same for IsSquare ?
+*)
+
+Inductive Cone (l : list (NFormula)) : PExprC -> Op1 -> Prop :=
+| InC : forall p op, In (p, op) l -> op <> NonEqual -> Cone l p op
+| IsIdeal : forall p, Cone l p Equal -> forall p', Cone l (PEmul p p') Equal
+| IsSquare : forall p, Cone l (PEmul p p) NonStrict
+| IsMonoid : forall p, Monoid l p -> Cone l (PEmul p p) Strict
+| IsMult : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEmul p q) (OpMult op oq)
+| IsAdd : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEadd p q) (OpAdd op oq)
+| IsPos : forall c : C, cltb cO c = true -> Cone l (PEc c) Strict
+| IsZ : Cone l (PEc cO) Equal.
+
+(* As promised, if all hypotheses are true in some environment, then every
+member of the monoid is nonzero in this environment *)
+
+Lemma monoid_nonzero : forall (l : list NFormula) (env : PolEnv),
+ (forall f : NFormula, In f l -> eval_nformula env f) ->
+ forall p : PExprC, Monoid l p -> eval_pexpr env p ~= 0.
+Proof.
+intros l env H1 p H2. induction H2 as [| f H | e1 e2 H3 IH1 H4 IH2]; simpl.
+rewrite addon.(SORrm).(morph1). apply (Rneq_symm sor). apply (Rneq_0_1 sor).
+apply H1 in H. now simpl in H.
+simpl in IH1, IH2. apply (Rtimes_neq_0 sor). now split.
+Qed.
+
+(* If all members of a cone base are true in some environment, then every
+member of the cone is true as well *)
+
+Lemma cone_true :
+ forall (l : list NFormula) (env : PolEnv),
+ (forall (f : NFormula), In f l -> eval_nformula env f) ->
+ forall (p : PExprC) (op : Op1), Cone l p op ->
+ op <> NonEqual /\ eval_nformula env (p, op).
+Proof.
+intros l env H1 p op H2. induction H2; simpl in *.
+split. assumption. apply H1 in H. now unfold eval_nformula in H.
+split. discriminate. destruct IHCone as [_ H3]. rewrite H3. now rewrite (Rtimes_0_l sor).
+split. discriminate. apply (Rtimes_square_nonneg sor).
+split. discriminate. apply <- (Rlt_le_neq sor). split. apply (Rtimes_square_nonneg sor).
+apply (Rneq_symm sor). apply (Rtimes_neq_0 sor). split; now apply monoid_nonzero with l.
+destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4].
+split. now apply OpMultNonEqual. now apply OpMult_sound.
+destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4].
+split. now apply OpAdd_NonEqual. now apply OpAdd_sound.
+split. discriminate. rewrite <- addon.(SORrm).(morph0). now apply cltb_sound.
+split. discriminate. apply addon.(SORrm).(morph0).
+Qed.
+
+(* Every element of a monoid is a product of some generators; therefore,
+to determine an element we can give a list of generators' indices *)
+
+Definition MonoidMember : Set := list nat.
+
+Inductive ConeMember : Type :=
+| S_In : nat -> ConeMember
+| S_Ideal : PExprC -> ConeMember -> ConeMember
+| S_Square : PExprC -> ConeMember
+| S_Monoid : MonoidMember -> ConeMember
+| S_Mult : ConeMember -> ConeMember -> ConeMember
+| S_Add : ConeMember -> ConeMember -> ConeMember
+| S_Pos : C -> ConeMember
+| S_Z : ConeMember.
+
+Definition nformula_times (f f' : NFormula) : NFormula :=
+let (p, op) := f in
+ let (p', op') := f' in
+ (PEmul p p', OpMult op op').
+
+Definition nformula_plus (f f' : NFormula) : NFormula :=
+let (p, op) := f in
+ let (p', op') := f' in
+ (PEadd p p', OpAdd op op').
+
+Definition nformula_times_0 (p : PExprC) (f : NFormula) : NFormula :=
+let (q, op) := f in
+ match op with
+ | Equal => (PEmul q p, Equal)
+ | _ => f
+ end.
+
+Fixpoint eval_monoid (l : list NFormula) (ns : MonoidMember) {struct ns} : PExprC :=
+match ns with
+| nil => PEc cI
+| n :: ns =>
+ let p := match nth n l (PEc cI, NonEqual) with
+ | (q, NonEqual) => q
+ | _ => PEc cI
+ end in
+ PEmul p (eval_monoid l ns)
+end.
+
+Theorem eval_monoid_in_monoid :
+ forall (l : list NFormula) (ns : MonoidMember), Monoid l (eval_monoid l ns).
+Proof.
+intro l; induction ns; simpl in *.
+constructor.
+apply M_Mult; [| assumption].
+destruct (nth_in_or_default a l (PEc cI, NonEqual)).
+destruct (nth a l (PEc cI, NonEqual)). destruct o; try constructor. assumption.
+rewrite e; simpl. constructor.
+Qed.
+
+(* Provides the cone member from the witness, i.e., ConeMember *)
+Fixpoint eval_cone (l : list NFormula) (cm : ConeMember) {struct cm} : NFormula :=
+match cm with
+| S_In n => match nth n l (PEc cO, Equal) with
+ | (_, NonEqual) => (PEc cO, Equal)
+ | f => f
+ end
+| S_Ideal p cm' => nformula_times_0 p (eval_cone l cm')
+| S_Square p => (PEmul p p, NonStrict)
+| S_Monoid m => let p := eval_monoid l m in (PEmul p p, Strict)
+| S_Mult p q => nformula_times (eval_cone l p) (eval_cone l q)
+| S_Add p q => nformula_plus (eval_cone l p) (eval_cone l q)
+| S_Pos c => if cltb cO c then (PEc c, Strict) else (PEc cO, Equal)
+| S_Z => (PEc cO, Equal)
+end.
+
+Theorem eval_cone_in_cone :
+ forall (l : list NFormula) (cm : ConeMember),
+ let (p, op) := eval_cone l cm in Cone l p op.
+Proof.
+intros l cm; induction cm; simpl.
+destruct (nth_in_or_default n l (PEc cO, Equal)).
+destruct (nth n l (PEc cO, Equal)). destruct o; try (now apply InC). apply IsZ.
+rewrite e. apply IsZ.
+destruct (eval_cone l cm). destruct o; simpl; try assumption. now apply IsIdeal.
+apply IsSquare.
+apply IsMonoid. apply eval_monoid_in_monoid.
+destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_times. now apply IsMult.
+destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_plus. now apply IsAdd.
+case_eq (cO [<] c) ; intros ; [apply IsPos ; auto| apply IsZ].
+apply IsZ.
+Qed.
+
+(* (inconsistent_cone_member l p) means (p, op) is in the cone for some op
+(> 0, >= 0, == 0, or ~= 0) and this formula is inconsistent. This fact
+implies that l is inconsistent, as shown by the next lemma. Inconsistency
+of a formula (p, op) can be established by normalizing p and showing that
+it is a constant c for which (c, op) is false. (This is only a sufficient,
+not necessary, condition, of course.) Membership in the cone can be
+verified if we have a certificate. *)
+
+Definition inconsistent_cone_member (l : list NFormula) (p : PExprC) :=
+ exists op : Op1, Cone l p op /\
+ forall env : PolEnv, ~ eval_op1 op (eval_pexpr env p).
+
+(* If some element of a cone is inconsistent, then the base of the cone
+is also inconsistent *)
+
+Lemma prove_inconsistent :
+ forall (l : list NFormula) (p : PExprC),
+ inconsistent_cone_member l p -> forall env, make_impl (eval_nformula env) l False.
+Proof.
+intros l p H env.
+destruct H as [o [wit H]].
+apply -> make_conj_impl.
+intro H1. apply H with env.
+pose proof (@cone_true l env) as H2.
+cut (forall f : NFormula, In f l -> eval_nformula env f). intro H3.
+apply (proj2 (H2 H3 p o wit)). intro. now apply make_conj_in.
+Qed.
+
+Definition normalise_pexpr : PExprC -> PolC :=
+ norm_aux cO cI cplus ctimes cminus copp ceqb.
+
+(* The following definition we don't really need, hence it is commented *)
+(*Definition eval_pol : PolEnv -> PolC -> R := Pphi 0 rplus rtimes phi.*)
+
+(* roughly speaking, normalise_pexpr_correct is a proof of
+ forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *)
+
+(*****)
+Definition normalise_pexpr_correct :=
+let Rops_wd := mk_reqe rplus rtimes ropp req
+ sor.(SORplus_wd)
+ sor.(SORtimes_wd)
+ sor.(SORopp_wd) in
+ norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
+ addon.(SORrm) addon.(SORpower).
+(*****)
+(*Definition normalise_pexpr_correct :=
+let Rops_wd := mk_reqe rplus rtimes ropp req
+ sor.(SORplus_wd)
+ sor.(SORtimes_wd)
+ sor.(SORopp_wd) in
+ norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth sor.(SORsetoid) Rops_wd sor.(SORrt))
+ addon.(SORrm) addon.(SORpower) nil.*)
+(*****)
+
+(* Check that a formula f is inconsistent by normalizing and comparing the
+resulting constant with 0 *)
+
+Definition check_inconsistent (f : NFormula) : bool :=
+let (e, op) := f in
+ match normalise_pexpr e with
+ | Pc c =>
+ match op with
+ | Equal => cneqb c cO
+ | NonStrict => c [<] cO
+ | Strict => c [<=] cO
+ | NonEqual => false (* eval_cone never returns (p, NonEqual) *)
+ end
+ | _ => false (* not a constant *)
+ end.
+
+Lemma check_inconsistent_sound :
+ forall (p : PExprC) (op : Op1),
+ check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pexpr env p).
+Proof.
+intros p op H1 env. unfold check_inconsistent, normalise_pexpr in H1.
+destruct op; simpl;
+(*****)
+rewrite eval_pexpr_PEeval;
+(*****)
+(*unfold eval_pexpr;*)
+(*****)
+rewrite normalise_pexpr_correct;
+destruct (norm_aux cO cI cplus ctimes cminus copp ceqb p); simpl; try discriminate H1;
+try rewrite <- addon.(SORrm).(morph0); trivial.
+now apply cneqb_sound.
+apply cleb_sound in H1. now apply -> (Rle_ngt sor).
+apply cltb_sound in H1. now apply -> (Rlt_nge sor).
+Qed.
+
+Definition check_normalised_formulas : list NFormula -> ConeMember -> bool :=
+ fun l cm => check_inconsistent (eval_cone l cm).
+
+Lemma checker_nf_sound :
+ forall (l : list NFormula) (cm : ConeMember),
+ check_normalised_formulas l cm = true ->
+ forall env : PolEnv, make_impl (eval_nformula env) l False.
+Proof.
+intros l cm H env.
+unfold check_normalised_formulas in H.
+case_eq (eval_cone l cm). intros p op H1.
+apply prove_inconsistent with p. unfold inconsistent_cone_member. exists op. split.
+pose proof (eval_cone_in_cone l cm) as H2. now rewrite H1 in H2.
+apply check_inconsistent_sound. now rewrite <- H1.
+Qed.
+
+(** Normalisation of formulae **)
+
+Inductive Op2 : Set := (* binary relations *)
+| OpEq
+| OpNEq
+| OpLe
+| OpGe
+| OpLt
+| OpGt.
+
+Definition eval_op2 (o : Op2) : R -> R -> Prop :=
+match o with
+| OpEq => req
+| OpNEq => fun x y : R => x ~= y
+| OpLe => rle
+| OpGe => fun x y : R => y <= x
+| OpLt => fun x y : R => x < y
+| OpGt => fun x y : R => y < x
+end.
+
+Record Formula : Type := {
+ Flhs : PExprC;
+ Fop : Op2;
+ Frhs : PExprC
+}.
+
+Definition eval_formula (env : PolEnv) (f : Formula) : Prop :=
+ let (lhs, op, rhs) := f in
+ (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs).
+
+(* We normalize Formulas by moving terms to one side *)
+
+Definition normalise (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+ match op with
+ | OpEq => (PEsub lhs rhs, Equal)
+ | OpNEq => (PEsub lhs rhs, NonEqual)
+ | OpLe => (PEsub rhs lhs, NonStrict)
+ | OpGe => (PEsub lhs rhs, NonStrict)
+ | OpGt => (PEsub lhs rhs, Strict)
+ | OpLt => (PEsub rhs lhs, Strict)
+ end.
+
+Definition negate (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+ match op with
+ | OpEq => (PEsub rhs lhs, NonEqual)
+ | OpNEq => (PEsub rhs lhs, Equal)
+ | OpLe => (PEsub lhs rhs, Strict) (* e <= e' == ~ e > e' *)
+ | OpGe => (PEsub rhs lhs, Strict)
+ | OpGt => (PEsub rhs lhs, NonStrict)
+ | OpLt => (PEsub lhs rhs, NonStrict)
+end.
+
+Theorem normalise_sound :
+ forall (env : PolEnv) (f : Formula),
+ eval_formula env f -> eval_nformula env (normalise f).
+Proof.
+intros env f H; destruct f as [lhs op rhs]; simpl in *.
+destruct op; simpl in *.
+now apply <- (Rminus_eq_0 sor).
+intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H.
+now apply -> (Rle_le_minus sor).
+now apply -> (Rle_le_minus sor).
+now apply -> (Rlt_lt_minus sor).
+now apply -> (Rlt_lt_minus sor).
+Qed.
+
+Theorem negate_correct :
+ forall (env : PolEnv) (f : Formula),
+ eval_formula env f <-> ~ (eval_nformula env (negate f)).
+Proof.
+intros env f; destruct f as [lhs op rhs]; simpl.
+destruct op; simpl.
+symmetry. rewrite (Rminus_eq_0 sor).
+split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)].
+rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor).
+rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
+rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
+rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
+rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
+Qed.
+
+(** Another normalistion - this is used for cnf conversion **)
+
+Definition xnormalise (t:Formula) : list (NFormula) :=
+ let (lhs,o,rhs) := t in
+ match o with
+ | OpEq =>
+ (PEsub lhs rhs, Strict)::(PEsub rhs lhs , Strict)::nil
+ | OpNEq => (PEsub lhs rhs,Equal) :: nil
+ | OpGt => (PEsub rhs lhs,NonStrict) :: nil
+ | OpLt => (PEsub lhs rhs,NonStrict) :: nil
+ | OpGe => (PEsub rhs lhs , Strict) :: nil
+ | OpLe => (PEsub lhs rhs ,Strict) :: nil
+ end.
+
+Require Import Tauto.
+
+Definition cnf_normalise (t:Formula) : cnf (NFormula) :=
+ List.map (fun x => x::nil) (xnormalise t).
+
+
+Add Ring SORRing : sor.(SORrt).
+
+Lemma cnf_normalise_correct : forall env t, eval_cnf (eval_nformula env) (cnf_normalise t) -> eval_formula env t.
+Proof.
+ unfold cnf_normalise, xnormalise ; simpl ; intros env t.
+ unfold eval_cnf.
+ destruct t as [lhs o rhs]; case_eq o ; simpl;
+ generalize (eval_pexpr env lhs);
+ generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros.
+ (**)
+ apply sor.(SORle_antisymm).
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+ now rewrite <- (Rminus_eq_0 sor).
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto.
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto.
+ rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto.
+ rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto.
+Qed.
+
+Definition xnegate (t:Formula) : list (NFormula) :=
+ let (lhs,o,rhs) := t in
+ match o with
+ | OpEq => (PEsub lhs rhs,Equal) :: nil
+ | OpNEq => (PEsub lhs rhs ,Strict)::(PEsub rhs lhs,Strict)::nil
+ | OpGt => (PEsub lhs rhs,Strict) :: nil
+ | OpLt => (PEsub rhs lhs,Strict) :: nil
+ | OpGe => (PEsub lhs rhs,NonStrict) :: nil
+ | OpLe => (PEsub rhs lhs,NonStrict) :: nil
+ end.
+
+Definition cnf_negate (t:Formula) : cnf (NFormula) :=
+ List.map (fun x => x::nil) (xnegate t).
+
+Lemma cnf_negate_correct : forall env t, eval_cnf (eval_nformula env) (cnf_negate t) -> ~ eval_formula env t.
+Proof.
+ unfold cnf_negate, xnegate ; simpl ; intros env t.
+ unfold eval_cnf.
+ destruct t as [lhs o rhs]; case_eq o ; simpl ;
+ generalize (eval_pexpr env lhs);
+ generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ;
+ intuition.
+ (**)
+ apply H0.
+ rewrite H1 ; ring.
+ (**)
+ apply H1.
+ apply sor.(SORle_antisymm).
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+ (**)
+ apply H0. now rewrite (Rle_le_minus sor) in H1.
+ apply H0. now rewrite (Rle_le_minus sor) in H1.
+ apply H0. now rewrite (Rlt_lt_minus sor) in H1.
+ apply H0. now rewrite (Rlt_lt_minus sor) in H1.
+Qed.
+
+
+Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d).
+Proof.
+ intros.
+ destruct d ; simpl.
+ generalize (eval_pexpr env p); intros.
+ destruct o ; simpl.
+ apply (Req_em sor r 0).
+ destruct (Req_em sor r 0) ; tauto.
+ rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto.
+ rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto.
+Qed.
+
+(** Some syntactic simplifications of expressions and cone elements *)
+
+
+Fixpoint simpl_expr (e:PExprC) : PExprC :=
+ match e with
+ | PEmul y z => let y' := simpl_expr y in let z' := simpl_expr z in
+ match y' , z' with
+ | PEc c , z' => if ceqb c cI then z' else PEmul y' z'
+ | _ , _ => PEmul y' z'
+ end
+ | PEadd x y => PEadd (simpl_expr x) (simpl_expr y)
+ | _ => e
+ end.
+
+
+Definition simpl_cone (e:ConeMember) : ConeMember :=
+ match e with
+ | S_Square t => match simpl_expr t with
+ | PEc c => if ceqb cO c then S_Z else S_Pos (ctimes c c)
+ | x => S_Square x
+ end
+ | S_Mult t1 t2 =>
+ match t1 , t2 with
+ | S_Z , x => S_Z
+ | x , S_Z => S_Z
+ | S_Pos c , S_Pos c' => S_Pos (ctimes c c')
+ | S_Pos p1 , S_Mult (S_Pos p2) x => S_Mult (S_Pos (ctimes p1 p2)) x
+ | S_Pos p1 , S_Mult x (S_Pos p2) => S_Mult (S_Pos (ctimes p1 p2)) x
+ | S_Mult (S_Pos p2) x , S_Pos p1 => S_Mult (S_Pos (ctimes p1 p2)) x
+ | S_Mult x (S_Pos p2) , S_Pos p1 => S_Mult (S_Pos (ctimes p1 p2)) x
+ | S_Pos x , S_Add y z => S_Add (S_Mult (S_Pos x) y) (S_Mult (S_Pos x) z)
+ | S_Pos c , _ => if ceqb cI c then t2 else S_Mult t1 t2
+ | _ , S_Pos c => if ceqb cI c then t1 else S_Mult t1 t2
+ | _ , _ => e
+ end
+ | S_Add t1 t2 =>
+ match t1 , t2 with
+ | S_Z , x => x
+ | x , S_Z => x
+ | x , y => S_Add x y
+ end
+ | _ => e
+ end.
+
+
+
+End Micromega.
+
diff --git a/contrib/micromega/Tauto.v b/contrib/micromega/Tauto.v
new file mode 100644
index 00000000..ef48efa6
--- /dev/null
+++ b/contrib/micromega/Tauto.v
@@ -0,0 +1,324 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import List.
+Require Import Refl.
+Require Import Bool.
+
+Set Implicit Arguments.
+
+
+ Inductive BFormula (A:Type) : Type :=
+ | TT : BFormula A
+ | FF : BFormula A
+ | X : Prop -> BFormula A
+ | A : A -> BFormula A
+ | Cj : BFormula A -> BFormula A -> BFormula A
+ | D : BFormula A-> BFormula A -> BFormula A
+ | N : BFormula A -> BFormula A
+ | I : BFormula A-> BFormula A-> BFormula A.
+
+ Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop :=
+ match f with
+ | TT => True
+ | FF => False
+ | A a => ev a
+ | X p => p
+ | Cj e1 e2 => (eval_f ev e1) /\ (eval_f ev e2)
+ | D e1 e2 => (eval_f ev e1) \/ (eval_f ev e2)
+ | N e => ~ (eval_f ev e)
+ | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2)
+ end.
+
+
+ Lemma map_simpl : forall A B f l, @map A B f l = match l with
+ | nil => nil
+ | a :: l=> (f a) :: (@map A B f l)
+ end.
+ Proof.
+ destruct l ; reflexivity.
+ Qed.
+
+
+
+ Section S.
+
+ Variable Env : Type.
+ Variable Term : Type.
+ Variable eval : Env -> Term -> Prop.
+ Variable Term' : Type.
+ Variable eval' : Env -> Term' -> Prop.
+
+
+
+ Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d).
+
+
+ Definition clause := list Term'.
+ Definition cnf := list clause.
+
+ Variable normalise : Term -> cnf.
+ Variable negate : Term -> cnf.
+
+
+ Definition tt : cnf := @nil clause.
+ Definition ff : cnf := cons (@nil Term') nil.
+
+
+ Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
+ List.map (fun x => (t++x)) f.
+
+ Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf :=
+ match f with
+ | nil => tt
+ | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f')
+ end.
+
+
+ Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf :=
+ f1 ++ f2.
+
+ Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf :=
+ match f with
+ | TT => if pol then tt else ff
+ | FF => if pol then ff else tt
+ | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *)
+ | A x => if pol then normalise x else negate x
+ | N e => xcnf (negb pol) e
+ | Cj e1 e2 =>
+ (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2)
+ | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2)
+ | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2)
+ end.
+
+ Definition eval_cnf (env : Term' -> Prop) (f:cnf) := make_conj (fun cl => ~ make_conj env cl) f.
+
+
+ Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y.
+ Proof.
+ unfold eval_cnf.
+ intros.
+ rewrite make_conj_app in H ; auto.
+ Qed.
+
+
+ Lemma or_clause_correct : forall env t f, eval_cnf (eval' env) (or_clause_cnf t f) -> (~ make_conj (eval' env) t) \/ (eval_cnf (eval' env) f).
+ Proof.
+ unfold eval_cnf.
+ unfold or_clause_cnf.
+ induction f.
+ simpl.
+ intros ; right;auto.
+ (**)
+ rewrite map_simpl.
+ intros.
+ rewrite make_conj_cons in H.
+ destruct H as [HH1 HH2].
+ generalize (IHf HH2) ; clear IHf ; intro.
+ destruct H.
+ left ; auto.
+ rewrite make_conj_cons.
+ destruct (not_make_conj_app _ _ _ (no_middle_eval' env) HH1).
+ tauto.
+ tauto.
+ Qed.
+
+ Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf (eval' env) f -> eval_cnf (eval' env) (a::f).
+ Proof.
+ intros.
+ unfold eval_cnf in *.
+ rewrite make_conj_cons ; eauto.
+ Qed.
+
+ Lemma or_cnf_correct : forall env f f', eval_cnf (eval' env) (or_cnf f f') -> (eval_cnf (eval' env) f) \/ (eval_cnf (eval' env) f').
+ Proof.
+ induction f.
+ unfold eval_cnf.
+ simpl.
+ tauto.
+ (**)
+ intros.
+ simpl in H.
+ destruct (eval_cnf_app _ _ _ H).
+ clear H.
+ destruct (IHf _ H0).
+ destruct (or_clause_correct _ _ _ H1).
+ left.
+ apply eval_cnf_cons ; auto.
+ right ; auto.
+ right ; auto.
+ Qed.
+
+ Variable normalise_correct : forall env t, eval_cnf (eval' env) (normalise t) -> eval env t.
+
+ Variable negate_correct : forall env t, eval_cnf (eval' env) (negate t) -> ~ eval env t.
+
+
+ Lemma xcnf_correct : forall f pol env, eval_cnf (eval' env) (xcnf pol f) -> eval_f (eval env) (if pol then f else N f).
+ Proof.
+ induction f.
+ (* TT *)
+ unfold eval_cnf.
+ simpl.
+ destruct pol ; simpl ; auto.
+ (* FF *)
+ unfold eval_cnf.
+ destruct pol; simpl ; auto.
+ (* P *)
+ simpl.
+ destruct pol ; intros ;simpl.
+ unfold eval_cnf in H.
+ (* Here I have to drop the proposition *)
+ simpl in H.
+ tauto.
+ (* Here, I could store P in the clause *)
+ unfold eval_cnf in H;simpl in H.
+ tauto.
+ (* A *)
+ simpl.
+ destruct pol ; simpl.
+ intros.
+ apply normalise_correct ; auto.
+ (* A 2 *)
+ intros.
+ apply negate_correct ; auto.
+ auto.
+ (* Cj *)
+ destruct pol ; simpl.
+ (* pol = true *)
+ intros.
+ unfold and_cnf in H.
+ destruct (eval_cnf_app _ _ _ H).
+ clear H.
+ split.
+ apply (IHf1 _ _ H0).
+ apply (IHf2 _ _ H1).
+ (* pol = false *)
+ intros.
+ destruct (or_cnf_correct _ _ _ H).
+ generalize (IHf1 false env H0).
+ simpl.
+ tauto.
+ generalize (IHf2 false env H0).
+ simpl.
+ tauto.
+ (* D *)
+ simpl.
+ destruct pol.
+ (* pol = true *)
+ intros.
+ destruct (or_cnf_correct _ _ _ H).
+ generalize (IHf1 _ env H0).
+ simpl.
+ tauto.
+ generalize (IHf2 _ env H0).
+ simpl.
+ tauto.
+ (* pol = true *)
+ unfold and_cnf.
+ intros.
+ destruct (eval_cnf_app _ _ _ H).
+ clear H.
+ simpl.
+ generalize (IHf1 _ _ H0).
+ generalize (IHf2 _ _ H1).
+ simpl.
+ tauto.
+ (**)
+ simpl.
+ destruct pol ; simpl.
+ intros.
+ apply (IHf false) ; auto.
+ intros.
+ generalize (IHf _ _ H).
+ tauto.
+ (* I *)
+ simpl; intros.
+ destruct pol.
+ simpl.
+ intro.
+ destruct (or_cnf_correct _ _ _ H).
+ generalize (IHf1 _ _ H1).
+ simpl in *.
+ tauto.
+ generalize (IHf2 _ _ H1).
+ auto.
+ (* pol = false *)
+ unfold and_cnf in H.
+ simpl in H.
+ destruct (eval_cnf_app _ _ _ H).
+ generalize (IHf1 _ _ H0).
+ generalize (IHf2 _ _ H1).
+ simpl.
+ tauto.
+ Qed.
+
+
+ Variable Witness : Type.
+ Variable checker : list Term' -> Witness -> bool.
+
+ Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False.
+
+ Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool :=
+ match f with
+ | nil => true
+ | e::f => match l with
+ | nil => false
+ | c::l => match checker e c with
+ | true => cnf_checker f l
+ | _ => false
+ end
+ end
+ end.
+
+ Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf (eval' env) t.
+ Proof.
+ unfold eval_cnf.
+ induction t.
+ (* bc *)
+ simpl.
+ auto.
+ (* ic *)
+ simpl.
+ destruct w.
+ intros ; discriminate.
+ case_eq (checker a w) ; intros ; try discriminate.
+ generalize (@checker_sound _ _ H env).
+ generalize (IHt _ H0 env) ; intros.
+ destruct t.
+ red ; intro.
+ rewrite <- make_conj_impl in H2.
+ tauto.
+ rewrite <- make_conj_impl in H2.
+ tauto.
+ Qed.
+
+
+ Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool :=
+ cnf_checker (xcnf true f) w.
+
+ Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (eval env) t.
+ Proof.
+ unfold tauto_checker.
+ intros.
+ change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)).
+ apply (xcnf_correct t true).
+ eapply cnf_checker_sound ; eauto.
+ Qed.
+
+
+
+
+End S.
+
diff --git a/contrib/micromega/VarMap.v b/contrib/micromega/VarMap.v
new file mode 100644
index 00000000..240c0fb7
--- /dev/null
+++ b/contrib/micromega/VarMap.v
@@ -0,0 +1,258 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import ZArith.
+Require Import Coq.Arith.Max.
+Require Import List.
+Set Implicit Arguments.
+
+(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v)
+ -- this is harmless and spares a lot of Empty.
+ This means smaller proof-terms.
+ BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up.
+*)
+
+Section MakeVarMap.
+ Variable A : Type.
+ Variable default : A.
+
+ Inductive t : Type :=
+ | Empty : t
+ | Leaf : A -> t
+ | Node : t -> A -> t -> t .
+
+ Fixpoint find (vm : t ) (p:positive) {struct vm} : A :=
+ match vm with
+ | Empty => default
+ | Leaf i => i
+ | Node l e r => match p with
+ | xH => e
+ | xO p => find l p
+ | xI p => find r p
+ end
+ end.
+
+ (* an off_map (a map with offset) offers the same functionalites as /contrib/setoid_ring/BinList.v - it is used in EnvRing.v *)
+(*
+ Definition off_map := (option positive *t )%type.
+
+
+
+ Definition jump (j:positive) (l:off_map ) :=
+ let (o,m) := l in
+ match o with
+ | None => (Some j,m)
+ | Some j0 => (Some (j+j0)%positive,m)
+ end.
+
+ Definition nth (n:positive) (l: off_map ) :=
+ let (o,m) := l in
+ let idx := match o with
+ | None => n
+ | Some i => i + n
+ end%positive in
+ find idx m.
+
+
+ Definition hd (l:off_map) := nth xH l.
+
+
+ Definition tail (l:off_map ) := jump xH l.
+
+
+ Lemma psucc : forall p, (match p with
+ | xI y' => xO (Psucc y')
+ | xO y' => xI y'
+ | 1%positive => 2%positive
+ end) = (p+1)%positive.
+ Proof.
+ destruct p.
+ auto with zarith.
+ rewrite xI_succ_xO.
+ auto with zarith.
+ reflexivity.
+ Qed.
+
+ Lemma jump_Pplus : forall i j l,
+ (jump (i + j) l) = (jump i (jump j l)).
+ Proof.
+ unfold jump.
+ destruct l.
+ destruct o.
+ rewrite Pplus_assoc.
+ reflexivity.
+ reflexivity.
+ Qed.
+
+ Lemma jump_simpl : forall p l,
+ jump p l =
+ match p with
+ | xH => tail l
+ | xO p => jump p (jump p l)
+ | xI p => jump p (jump p (tail l))
+ end.
+ Proof.
+ destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus.
+ (* xI p = p + p + 1 *)
+ rewrite xI_succ_xO.
+ rewrite Pplus_diag.
+ rewrite <- Pplus_one_succ_r.
+ reflexivity.
+ (* xO p = p + p *)
+ rewrite Pplus_diag.
+ reflexivity.
+ reflexivity.
+ Qed.
+
+ Ltac jump_s :=
+ repeat
+ match goal with
+ | |- context [jump xH ?e] => rewrite (jump_simpl xH)
+ | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
+ | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
+ end.
+
+ Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
+ Proof.
+ unfold tail.
+ intros.
+ repeat rewrite <- jump_Pplus.
+ rewrite Pplus_comm.
+ reflexivity.
+ Qed.
+
+ Lemma jump_Psucc : forall j l,
+ (jump (Psucc j) l) = (jump 1 (jump j l)).
+ Proof.
+ intros.
+ rewrite <- jump_Pplus.
+ rewrite Pplus_one_succ_r.
+ rewrite Pplus_comm.
+ reflexivity.
+ Qed.
+
+ Lemma jump_Pdouble_minus_one : forall i l,
+ (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
+ Proof.
+ unfold tail.
+ intros.
+ repeat rewrite <- jump_Pplus.
+ rewrite <- Pplus_one_succ_r.
+ rewrite Psucc_o_double_minus_one_eq_xO.
+ rewrite Pplus_diag.
+ reflexivity.
+ Qed.
+
+ Lemma jump_x0_tail : forall p l, jump (xO p) (tail l) = jump (xI p) l.
+ Proof.
+ intros.
+ jump_s.
+ repeat rewrite <- jump_Pplus.
+ reflexivity.
+ Qed.
+
+
+ Lemma nth_spec : forall p l,
+ nth p l =
+ match p with
+ | xH => hd l
+ | xO p => nth p (jump p l)
+ | xI p => nth p (jump p (tail l))
+ end.
+ Proof.
+ unfold nth.
+ destruct l.
+ destruct o.
+ simpl.
+ rewrite psucc.
+ destruct p.
+ replace (p0 + xI p)%positive with ((p + (p0 + 1) + p))%positive.
+ reflexivity.
+ rewrite xI_succ_xO.
+ rewrite Pplus_one_succ_r.
+ rewrite <- Pplus_diag.
+ rewrite Pplus_comm.
+ symmetry.
+ rewrite (Pplus_comm p0).
+ rewrite <- Pplus_assoc.
+ rewrite (Pplus_comm 1)%positive.
+ rewrite <- Pplus_assoc.
+ reflexivity.
+ (**)
+ replace ((p0 + xO p))%positive with (p + p0 + p)%positive.
+ reflexivity.
+ rewrite <- Pplus_diag.
+ rewrite <- Pplus_assoc.
+ rewrite Pplus_comm.
+ rewrite Pplus_assoc.
+ reflexivity.
+ reflexivity.
+ simpl.
+ destruct p.
+ rewrite xI_succ_xO.
+ rewrite Pplus_one_succ_r.
+ rewrite <- Pplus_diag.
+ symmetry.
+ rewrite Pplus_comm.
+ rewrite Pplus_assoc.
+ reflexivity.
+ rewrite Pplus_diag.
+ reflexivity.
+ reflexivity.
+ Qed.
+
+
+ Lemma nth_jump : forall p l, nth p (tail l) = hd (jump p l).
+ Proof.
+ destruct l.
+ unfold tail.
+ unfold hd.
+ unfold jump.
+ unfold nth.
+ destruct o.
+ symmetry.
+ rewrite Pplus_comm.
+ rewrite <- Pplus_assoc.
+ rewrite (Pplus_comm p0).
+ reflexivity.
+ rewrite Pplus_comm.
+ reflexivity.
+ Qed.
+
+ Lemma nth_Pdouble_minus_one :
+ forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
+ Proof.
+ destruct l.
+ unfold tail.
+ unfold nth, jump.
+ destruct o.
+ rewrite ((Pplus_comm p)).
+ rewrite <- (Pplus_assoc p0).
+ rewrite Pplus_diag.
+ rewrite <- Psucc_o_double_minus_one_eq_xO.
+ rewrite Pplus_one_succ_r.
+ rewrite (Pplus_comm (Pdouble_minus_one p)).
+ rewrite Pplus_assoc.
+ rewrite (Pplus_comm p0).
+ reflexivity.
+ rewrite <- Pplus_one_succ_l.
+ rewrite Psucc_o_double_minus_one_eq_xO.
+ rewrite Pplus_diag.
+ reflexivity.
+ Qed.
+
+*)
+
+End MakeVarMap.
+
diff --git a/contrib/micromega/ZCoeff.v b/contrib/micromega/ZCoeff.v
new file mode 100644
index 00000000..ced67e39
--- /dev/null
+++ b/contrib/micromega/ZCoeff.v
@@ -0,0 +1,173 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* Evgeny Makarov, INRIA, 2007 *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import ZArith.
+Require Import InitialRing.
+Require Import Setoid.
+
+Import OrderedRingSyntax.
+
+Set Implicit Arguments.
+
+Section InitialMorphism.
+
+Variable R : Type.
+Variables rO rI : R.
+Variables rplus rtimes rminus: R -> R -> R.
+Variable ropp : R -> R.
+Variables req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+Lemma req_refl : forall x, req x x.
+Proof.
+ destruct sor.(SORsetoid).
+ apply Equivalence_Reflexive.
+Qed.
+
+Lemma req_sym : forall x y, req x y -> req y x.
+Proof.
+ destruct sor.(SORsetoid).
+ apply Equivalence_Symmetric.
+Qed.
+
+Lemma req_trans : forall x y z, req x y -> req y z -> req x z.
+Proof.
+ destruct sor.(SORsetoid).
+ apply Equivalence_Transitive.
+Qed.
+
+
+Add Relation R req
+ reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
+ symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
+ transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
+as sor_setoid.
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+exact sor.(SORlt_wd).
+Qed.
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+ exact (rminus_morph sor).
+Qed.
+
+Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
+Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
+
+Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp.
+
+Notation phi_pos := (gen_phiPOS 1 rplus rtimes).
+Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes).
+
+Notation "[ x ]" := (gen_order_phi_Z x).
+
+Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req.
+Proof.
+constructor.
+exact rplus_morph.
+exact rtimes_morph.
+exact ropp_morph.
+Qed.
+
+Lemma Zring_morph :
+ ring_morph 0 1 rplus rtimes rminus ropp req
+ 0%Z 1%Z Zplus Zmult Zminus Zopp
+ Zeq_bool gen_order_phi_Z.
+Proof.
+exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)).
+Qed.
+
+Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x.
+Proof.
+induction x as [x IH | x IH |]; simpl;
+try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor);
+try apply (Rlt_0_1 sor); assumption.
+Qed.
+
+Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Psucc x) == 1 + phi_pos1 x.
+Proof.
+exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd
+ (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))).
+Qed.
+
+Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y.
+Proof.
+intros x y H. pattern y; apply Plt_ind with x.
+rewrite phi_pos1_succ; apply (Rlt_succ_r sor).
+clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor).
+assumption.
+Qed.
+
+Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y].
+Proof.
+unfold Zlt; intros x y H;
+do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt));
+destruct x; destruct y; simpl in *; try discriminate.
+apply phi_pos1_pos.
+now apply clt_pos_morph.
+apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
+apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
+apply phi_pos1_pos.
+rewrite Pcompare_antisym in H; simpl in H. apply -> (Ropp_lt_mono sor).
+now apply clt_pos_morph.
+Qed.
+
+Lemma Zcleb_morph : forall x y : Z, Zle_bool x y = true -> [x] <= [y].
+Proof.
+unfold Zle_bool; intros x y H.
+case_eq (x ?= y)%Z; intro H1; rewrite H1 in H.
+le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1.
+le_less. now apply clt_morph.
+discriminate.
+Qed.
+
+Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y].
+Proof.
+intros x y H. unfold Zeq_bool in H.
+case_eq (Zcompare x y); intro H1; rewrite H1 in *; (discriminate || clear H).
+apply (Rlt_neq sor). now apply clt_morph.
+fold (x > y)%Z in H1. rewrite Zgt_iff_lt in H1.
+apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph.
+Qed.
+
+End InitialMorphism.
+
+
diff --git a/contrib/micromega/ZMicromega.v b/contrib/micromega/ZMicromega.v
new file mode 100644
index 00000000..94c83f73
--- /dev/null
+++ b/contrib/micromega/ZMicromega.v
@@ -0,0 +1,714 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import ZCoeff.
+Require Import Refl.
+Require Import ZArith.
+Require Import List.
+Require Import Bool.
+
+Ltac flatten_bool :=
+ repeat match goal with
+ [ id : (_ && _)%bool = true |- _ ] => destruct (andb_prop _ _ id); clear id
+ | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id
+ end.
+
+Require Import EnvRing.
+
+Open Scope Z_scope.
+
+Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt.
+Proof.
+ constructor ; intros ; subst ; try (intuition (auto with zarith)).
+ apply Zsth.
+ apply Zth.
+ destruct (Ztrichotomy n m) ; intuition (auto with zarith).
+ apply Zmult_lt_0_compat ; auto.
+Qed.
+
+Lemma Zeq_bool_neq : forall x y, Zeq_bool x y = false -> x <> y.
+Proof.
+ red ; intros.
+ subst.
+ unfold Zeq_bool in H.
+ rewrite Zcompare_refl in H.
+ discriminate.
+Qed.
+
+Lemma ZSORaddon :
+ SORaddon 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle (* ring elements *)
+ 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
+ Zeq_bool Zle_bool
+ (fun x => x) (fun x => x) (pow_N 1 Zmult).
+Proof.
+ constructor.
+ constructor ; intros ; try reflexivity.
+ apply Zeqb_ok ; auto.
+ constructor.
+ reflexivity.
+ intros x y.
+ apply Zeq_bool_neq ; auto.
+ apply Zle_bool_imp_le.
+Qed.
+
+
+(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*)
+
+Fixpoint Zeval_expr (env: PolEnv Z) (e: PExpr Z) : Z :=
+ match e with
+ | PEc c => c
+ | PEX j => env j
+ | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2)
+ | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2)
+ | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2)
+ | PEopp pe1 => - (Zeval_expr env pe1)
+ | PEpow pe1 n => Zpower (Zeval_expr env pe1) (Z_of_N n)
+ end.
+
+Lemma Zeval_expr_simpl : forall env e,
+ Zeval_expr env e =
+ match e with
+ | PEc c => c
+ | PEX j => env j
+ | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2)
+ | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2)
+ | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2)
+ | PEopp pe1 => - (Zeval_expr env pe1)
+ | PEpow pe1 n => Zpower (Zeval_expr env pe1) (Z_of_N n)
+ end.
+Proof.
+ destruct e ; reflexivity.
+Qed.
+
+
+Definition Zeval_expr' := eval_pexpr Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult).
+
+Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n.
+Proof.
+ destruct n.
+ reflexivity.
+ simpl.
+ unfold Zpower_pos.
+ replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring.
+ generalize 1.
+ induction p; simpl ; intros ; repeat rewrite IHp ; ring.
+Qed.
+
+
+
+Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = Zeval_expr' env e.
+Proof.
+ induction e ; simpl ; subst ; try congruence.
+ rewrite IHe.
+ apply ZNpower.
+Qed.
+
+Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop :=
+match o with
+| OpEq => @eq Z
+| OpNEq => fun x y => ~ x = y
+| OpLe => Zle
+| OpGe => Zge
+| OpLt => Zlt
+| OpGt => Zgt
+end.
+
+Definition Zeval_formula (e: PolEnv Z) (ff : Formula Z) :=
+ let (lhs,o,rhs) := ff in Zeval_op2 o (Zeval_expr e lhs) (Zeval_expr e rhs).
+
+Definition Zeval_formula' :=
+ eval_formula Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
+
+Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f.
+Proof.
+ intros.
+ unfold Zeval_formula.
+ destruct f.
+ repeat rewrite Zeval_expr_compat.
+ unfold Zeval_formula'.
+ unfold Zeval_expr'.
+ split ; destruct Fop ; simpl; auto with zarith.
+Qed.
+
+
+
+Definition Zeval_nformula :=
+ eval_nformula 0 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
+
+Definition Zeval_op1 (o : Op1) : Z -> Prop :=
+match o with
+| Equal => fun x : Z => x = 0
+| NonEqual => fun x : Z => x <> 0
+| Strict => fun x : Z => 0 < x
+| NonStrict => fun x : Z => 0 <= x
+end.
+
+Lemma Zeval_nformula_simpl : forall env f, Zeval_nformula env f = (let (p, op) := f in Zeval_op1 op (Zeval_expr env p)).
+Proof.
+ intros.
+ destruct f.
+ rewrite Zeval_expr_compat.
+ reflexivity.
+Qed.
+
+Lemma Zeval_nformula_dec : forall env d, (Zeval_nformula env d) \/ ~ (Zeval_nformula env d).
+Proof.
+ exact (fun env d =>eval_nformula_dec Zsor (fun x => x) (fun x => x) (pow_N 1%Z Zmult) env d).
+Qed.
+
+Definition ZWitness := ConeMember Z.
+
+Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zminus Zopp Zeq_bool Zle_bool.
+
+Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness),
+ ZWeakChecker l cm = true ->
+ forall env, make_impl (Zeval_nformula env) l False.
+Proof.
+ intros l cm H.
+ intro.
+ unfold Zeval_nformula.
+ apply (checker_nf_sound Zsor ZSORaddon l cm).
+ unfold ZWeakChecker in H.
+ exact H.
+Qed.
+
+Definition xnormalise (t:Formula Z) : list (NFormula Z) :=
+ let (lhs,o,rhs) := t in
+ match o with
+ | OpEq =>
+ ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil
+ | OpNEq => (PEsub lhs rhs,Equal) :: nil
+ | OpGt => (PEsub rhs lhs,NonStrict) :: nil
+ | OpLt => (PEsub lhs rhs,NonStrict) :: nil
+ | OpGe => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil
+ | OpLe => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil
+ end.
+
+Require Import Tauto.
+
+Definition normalise (t:Formula Z) : cnf (NFormula Z) :=
+ List.map (fun x => x::nil) (xnormalise t).
+
+
+Lemma normalise_correct : forall env t, eval_cnf (Zeval_nformula env) (normalise t) <-> Zeval_formula env t.
+Proof.
+ unfold normalise, xnormalise ; simpl ; intros env t.
+ rewrite Zeval_formula_compat.
+ unfold eval_cnf.
+ destruct t as [lhs o rhs]; case_eq o ; simpl;
+ generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+ (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
+ generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+ (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
+ intuition (auto with zarith).
+Qed.
+
+Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) :=
+ let (lhs,o,rhs) := t in
+ match o with
+ | OpEq => (PEsub lhs rhs,Equal) :: nil
+ | OpNEq => ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil
+ | OpGt => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil
+ | OpLt => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil
+ | OpGe => (PEsub lhs rhs,NonStrict) :: nil
+ | OpLe => (PEsub rhs lhs,NonStrict) :: nil
+ end.
+
+Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) :=
+ List.map (fun x => x::nil) (xnegate t).
+
+Lemma negate_correct : forall env t, eval_cnf (Zeval_nformula env) (negate t) <-> ~ Zeval_formula env t.
+Proof.
+ unfold negate, xnegate ; simpl ; intros env t.
+ rewrite Zeval_formula_compat.
+ unfold eval_cnf.
+ destruct t as [lhs o rhs]; case_eq o ; simpl ;
+ generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+ (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
+ generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+ (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ;
+ intuition (auto with zarith).
+Qed.
+
+
+Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool :=
+ @tauto_checker (Formula Z) (NFormula Z) normalise negate ZWitness ZWeakChecker f w.
+
+(* To get a complete checker, the proof format has to be enriched *)
+
+Require Import Zdiv.
+Open Scope Z_scope.
+
+Definition ceiling (a b:Z) : Z :=
+ let (q,r) := Zdiv_eucl a b in
+ match r with
+ | Z0 => q
+ | _ => q + 1
+ end.
+
+Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x >= b -> x >= ceiling b a.
+Proof.
+ unfold ceiling.
+ intros.
+ generalize (Z_div_mod b a H).
+ destruct (Zdiv_eucl b a).
+ intros.
+ destruct H1.
+ destruct H2.
+ subst.
+ destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate.
+ assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith).
+ destruct HH ;auto.
+ generalize (Zmult_lt_compat_l _ _ _ H3 H1).
+ auto with zarith.
+ clear H2.
+ assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
+ destruct HH ;auto.
+ assert (0 < a) by auto with zarith.
+ generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1).
+ intros.
+ rewrite Zmult_comm in H4.
+ rewrite (Zmult_comm z) in H4.
+ auto with zarith.
+Qed.
+
+Lemma narrow_interval_upper_bound : forall a b x, a > 0 -> a * x <= b -> x <= Zdiv b a.
+Proof.
+ unfold Zdiv.
+ intros.
+ generalize (Z_div_mod b a H).
+ destruct (Zdiv_eucl b a).
+ intros.
+ destruct H1.
+ destruct H2.
+ subst.
+ assert (HH :x <= z \/ z <= x -1) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
+ destruct HH ;auto.
+ assert (0 < a) by auto with zarith.
+ generalize (Zmult_lt_0_le_compat_r _ _ _ H4 H1).
+ intros.
+ ring_simplify in H5.
+ rewrite Zmult_comm in H5.
+ auto with zarith.
+Qed.
+
+
+(* In this case, a certificate is made of a pair of inequations, in 1 variable,
+ that do not have an integer solution.
+ => modify the fourier elimination
+ *)
+Require Import QArith.
+
+
+Inductive ProofTerm : Type :=
+| RatProof : ZWitness -> ProofTerm
+| CutProof : PExprC Z -> Q -> ZWitness -> ProofTerm -> ProofTerm
+| EnumProof : Q -> PExprC Z -> Q -> ZWitness -> ZWitness -> list ProofTerm -> ProofTerm.
+
+(* n/d <= x -> d*x - n >= 0 *)
+
+Definition makeLb (v:PExpr Z) (q:Q) : NFormula Z :=
+ let (n,d) := q in (PEsub (PEmul (PEc (Zpos d)) v) (PEc n),NonStrict).
+
+(* x <= n/d -> d * x <= d *)
+Definition makeUb (v:PExpr Z) (q:Q) : NFormula Z :=
+ let (n,d) := q in
+ (PEsub (PEc n) (PEmul (PEc (Zpos d)) v), NonStrict).
+
+Definition qceiling (q:Q) : Z :=
+ let (n,d) := q in ceiling n (Zpos d).
+
+Definition qfloor (q:Q) : Z :=
+ let (n,d) := q in Zdiv n (Zpos d).
+
+Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z :=
+ (PEsub v (PEc (qceiling q)), NonStrict).
+
+Definition neg_nformula (f : NFormula Z) :=
+ let (e,o) := f in
+ (PEopp (PEadd e (PEc 1%Z)), o).
+
+Lemma neg_nformula_sound : forall env f, snd f = NonStrict ->( ~ (Zeval_nformula env (neg_nformula f)) <-> Zeval_nformula env f).
+Proof.
+ unfold neg_nformula.
+ destruct f.
+ simpl.
+ intros ; subst ; simpl in *.
+ split; auto with zarith.
+Qed.
+
+
+Definition cutChecker (l:list (NFormula Z)) (e: PExpr Z) (lb:Q) (pf : ZWitness) : option (NFormula Z) :=
+ let (lb,lc) := (makeLb e lb,makeLbCut e lb) in
+ if ZWeakChecker (neg_nformula lb::l) pf then Some lc else None.
+
+
+Fixpoint ZChecker (l:list (NFormula Z)) (pf : ProofTerm) {struct pf} : bool :=
+ match pf with
+ | RatProof pf => ZWeakChecker l pf
+ | CutProof e q pf rst =>
+ match cutChecker l e q pf with
+ | None => false
+ | Some c => ZChecker (c::l) rst
+ end
+ | EnumProof lb e ub pf1 pf2 rst =>
+ match cutChecker l e lb pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with
+ | None , _ | _ , None => false
+ | Some _ , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in
+ (fix label (pfs:list ProofTerm) :=
+ fun lb ub =>
+ match pfs with
+ | nil => if Z_gt_dec lb ub then true else false
+ | pf::rsr => andb (ZChecker ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub)
+ end)
+ rst lb' ub'
+ end
+ end.
+
+
+Lemma ZChecker_simpl : forall (pf : ProofTerm) (l:list (NFormula Z)),
+ ZChecker l pf =
+ match pf with
+ | RatProof pf => ZWeakChecker l pf
+ | CutProof e q pf rst =>
+ match cutChecker l e q pf with
+ | None => false
+ | Some c => ZChecker (c::l) rst
+ end
+ | EnumProof lb e ub pf1 pf2 rst =>
+ match cutChecker l e lb pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with
+ | None , _ | _ , None => false
+ | Some _ , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in
+ (fix label (pfs:list ProofTerm) :=
+ fun lb ub =>
+ match pfs with
+ | nil => if Z_gt_dec lb ub then true else false
+ | pf::rsr => andb (ZChecker ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub)
+ end)
+ rst lb' ub'
+ end
+ end.
+Proof.
+ destruct pf ; reflexivity.
+Qed.
+
+(*
+Fixpoint depth (n:nat) : ProofTerm -> option nat :=
+ match n with
+ | O => fun pf => None
+ | S n =>
+ fun pf =>
+ match pf with
+ | RatProof _ => Some O
+ | CutProof _ _ _ p => option_map S (depth n p)
+ | EnumProof _ _ _ _ _ l =>
+ let f := fun pf x =>
+ match x , depth n pf with
+ | None , _ | _ , None => None
+ | Some n1 , Some n2 => Some (Max.max n1 n2)
+ end in
+ List.fold_right f (Some O) l
+ end
+ end.
+*)
+Fixpoint bdepth (pf : ProofTerm) : nat :=
+ match pf with
+ | RatProof _ => O
+ | CutProof _ _ _ p => S (bdepth p)
+ | EnumProof _ _ _ _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x) O l)
+ end.
+
+Require Import Wf_nat.
+
+Lemma in_bdepth : forall l a b p c c0 y, In y l -> ltof ProofTerm bdepth y (EnumProof a b p c c0 l).
+Proof.
+ induction l.
+ simpl.
+ tauto.
+ simpl.
+ intros.
+ destruct H.
+ subst.
+ unfold ltof.
+ simpl.
+ generalize ( (fold_right
+ (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat l)).
+ intros.
+ generalize (bdepth y) ; intros.
+ generalize (Max.max_l n0 n) (Max.max_r n0 n).
+ omega.
+ generalize (IHl a0 b p c c0 y H).
+ unfold ltof.
+ simpl.
+ generalize ( (fold_right (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat
+ l)).
+ intros.
+ generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n).
+ omega.
+Qed.
+
+Lemma lb_lbcut : forall env e q, Zeval_nformula env (makeLb e q) -> Zeval_nformula env (makeLbCut e q).
+Proof.
+ unfold makeLb, makeLbCut.
+ destruct q.
+ rewrite Zeval_nformula_simpl.
+ rewrite Zeval_nformula_simpl.
+ unfold Zeval_op1.
+ rewrite Zeval_expr_simpl.
+ rewrite Zeval_expr_simpl.
+ rewrite Zeval_expr_simpl.
+ intro.
+ rewrite Zeval_expr_simpl.
+ revert H.
+ generalize (Zeval_expr env e).
+ rewrite Zeval_expr_simpl.
+ rewrite Zeval_expr_simpl.
+ unfold qceiling.
+ intros.
+ assert ( z >= ceiling Qnum (' Qden))%Z.
+ apply narrow_interval_lower_bound.
+ compute.
+ reflexivity.
+ destruct z ; auto with zarith.
+ auto with zarith.
+Qed.
+
+Lemma cutChecker_sound : forall e lb pf l res, cutChecker l e lb pf = Some res ->
+ forall env, make_impl (Zeval_nformula env) l (Zeval_nformula env res).
+Proof.
+ unfold cutChecker.
+ intros.
+ revert H.
+ case_eq (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf); intros ; [idtac | discriminate].
+ generalize (ZWeakChecker_sound _ _ H env).
+ intros.
+ inversion H0 ; subst ; clear H0.
+ apply -> make_conj_impl.
+ simpl in H1.
+ rewrite <- make_conj_impl in H1.
+ intros.
+ apply -> neg_nformula_sound ; auto.
+ red ; intros.
+ apply H1 ; auto.
+ clear H H1 H0.
+ generalize (lb_lbcut env e lb).
+ intros.
+ destruct (Zeval_nformula_dec env ((neg_nformula (makeLb e lb)))).
+ auto.
+ rewrite -> neg_nformula_sound in H0.
+ assert (HH := H H0).
+ rewrite <- neg_nformula_sound in HH.
+ tauto.
+ reflexivity.
+ unfold makeLb.
+ destruct lb.
+ reflexivity.
+Qed.
+
+
+Lemma cutChecker_sound_bound : forall e lb pf l res, cutChecker l e lb pf = Some res ->
+ forall env, make_conj (Zeval_nformula env) l -> (Zeval_expr env e >= qceiling lb)%Z.
+Proof.
+ intros.
+ generalize (cutChecker_sound _ _ _ _ _ H env).
+ intros.
+ rewrite <- (make_conj_impl) in H1.
+ generalize (H1 H0).
+ unfold cutChecker in H.
+ destruct (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf).
+ unfold makeLbCut in H.
+ inversion H ; subst.
+ clear H.
+ simpl.
+ rewrite Zeval_expr_compat.
+ unfold Zeval_expr'.
+ auto with zarith.
+ discriminate.
+Qed.
+
+
+Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (Zeval_nformula env) l False.
+Proof.
+ induction w using (well_founded_ind (well_founded_ltof _ bdepth)).
+ destruct w.
+ (* RatProof *)
+ simpl.
+ intros.
+ eapply ZWeakChecker_sound.
+ apply H0.
+ (* CutProof *)
+ simpl.
+ intro.
+ case_eq (cutChecker l p q z) ; intros.
+ generalize (cutChecker_sound _ _ _ _ _ H0 env).
+ intro.
+ assert (make_impl (Zeval_nformula env) (n::l) False).
+ eapply (H w) ; auto.
+ unfold ltof.
+ simpl.
+ auto with arith.
+ simpl in H3.
+ rewrite <- make_conj_impl in H2.
+ rewrite <- make_conj_impl in H3.
+ rewrite <- make_conj_impl.
+ tauto.
+ discriminate.
+ (* EnumProof *)
+ intro.
+ rewrite ZChecker_simpl.
+ case_eq (cutChecker l0 p q z).
+ rename q into llb.
+ case_eq (cutChecker l0 (PEopp p) (- q0) z0).
+ intros.
+ rename q0 into uub.
+ (* get the bounds of the enum *)
+ rewrite <- make_conj_impl.
+ intro.
+ assert (qceiling llb <= Zeval_expr env p <= - qceiling ( - uub))%Z.
+ generalize (cutChecker_sound_bound _ _ _ _ _ H0 env H3).
+ generalize (cutChecker_sound_bound _ _ _ _ _ H1 env H3).
+ intros.
+ rewrite Zeval_expr_simpl in H5.
+ auto with zarith.
+ clear H0 H1.
+ revert H2 H3 H4.
+ generalize (qceiling llb) (- qceiling (- uub))%Z.
+ set (FF := (fix label (pfs : list ProofTerm) (lb ub : Z) {struct pfs} : bool :=
+ match pfs with
+ | nil => if Z_gt_dec lb ub then true else false
+ | pf :: rsr =>
+ (ZChecker ((PEsub p (PEc lb), Equal) :: l0) pf &&
+ label rsr (lb + 1)%Z ub)%bool
+ end)).
+ intros z1 z2.
+ intros.
+ assert (forall x, z1 <= x <= z2 -> exists pr,
+ (In pr l /\
+ ZChecker ((PEsub p (PEc x),Equal) :: l0) pr = true))%Z.
+ clear H.
+ revert H2.
+ clear H4.
+ revert z1 z2.
+ induction l;simpl ;intros.
+ destruct (Z_gt_dec z1 z2).
+ intros.
+ apply False_ind ; omega.
+ discriminate.
+ intros.
+ simpl in H2.
+ flatten_bool.
+ assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega.
+ destruct HH.
+ subst.
+ exists a ; auto.
+ assert (z1 + 1 <= x <= z2)%Z by omega.
+ destruct (IHl _ _ H1 _ H4).
+ destruct H5.
+ exists x0 ; split;auto.
+ (*/asser *)
+ destruct (H0 _ H4) as [pr [Hin Hcheker]].
+ assert (make_impl (Zeval_nformula env) ((PEsub p (PEc (Zeval_expr env p)),Equal) :: l0) False).
+ apply (H pr);auto.
+ apply in_bdepth ; auto.
+ rewrite <- make_conj_impl in H1.
+ apply H1.
+ rewrite make_conj_cons.
+ split ;auto.
+ rewrite Zeval_nformula_simpl;
+ unfold Zeval_op1;
+ rewrite Zeval_expr_simpl.
+ generalize (Zeval_expr env p).
+ intros.
+ rewrite Zeval_expr_simpl.
+ auto with zarith.
+ intros ; discriminate.
+ intros ; discriminate.
+Qed.
+
+Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ProofTerm): bool :=
+ @tauto_checker (Formula Z) (NFormula Z) normalise negate ProofTerm ZChecker f w.
+
+Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (Zeval_formula env) f.
+Proof.
+ intros f w.
+ unfold ZTautoChecker.
+ apply (tauto_checker_sound Zeval_formula Zeval_nformula).
+ apply Zeval_nformula_dec.
+ intros env t.
+ rewrite normalise_correct ; auto.
+ intros env t.
+ rewrite negate_correct ; auto.
+ intros t w0.
+ apply ZChecker_sound.
+Qed.
+
+
+Open Scope Z_scope.
+
+
+Fixpoint map_cone (f: nat -> nat) (e:ZWitness) : ZWitness :=
+ match e with
+ | S_In n => S_In _ (f n)
+ | S_Ideal e cm => S_Ideal e (map_cone f cm)
+ | S_Square _ => e
+ | S_Monoid l => S_Monoid _ (List.map f l)
+ | S_Mult cm1 cm2 => S_Mult (map_cone f cm1) (map_cone f cm2)
+ | S_Add cm1 cm2 => S_Add (map_cone f cm1) (map_cone f cm2)
+ | _ => e
+ end.
+
+Fixpoint indexes (e:ZWitness) : list nat :=
+ match e with
+ | S_In n => n::nil
+ | S_Ideal e cm => indexes cm
+ | S_Square e => nil
+ | S_Monoid l => l
+ | S_Mult cm1 cm2 => (indexes cm1)++ (indexes cm2)
+ | S_Add cm1 cm2 => (indexes cm1)++ (indexes cm2)
+ | _ => nil
+ end.
+
+(** To ease bindings from ml code **)
+(*Definition varmap := Quote.varmap.*)
+Definition make_impl := Refl.make_impl.
+Definition make_conj := Refl.make_conj.
+
+Require VarMap.
+
+(*Definition varmap_type := VarMap.t Z. *)
+Definition env := PolEnv Z.
+Definition node := @VarMap.Node Z.
+Definition empty := @VarMap.Empty Z.
+Definition leaf := @VarMap.Leaf Z.
+
+Definition coneMember := ZWitness.
+
+Definition eval := Zeval_formula.
+
+Definition prod_pos_nat := prod positive nat.
+
+Require Import Int.
+
+
+Definition n_of_Z (z:Z) : BinNat.N :=
+ match z with
+ | Z0 => N0
+ | Zpos p => Npos p
+ | Zneg p => N0
+ end.
+
+
+
diff --git a/contrib/micromega/certificate.ml b/contrib/micromega/certificate.ml
new file mode 100644
index 00000000..88e882e6
--- /dev/null
+++ b/contrib/micromega/certificate.ml
@@ -0,0 +1,618 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+(* We take as input a list of polynomials [p1...pn] and return an unfeasibility
+ certificate polynomial. *)
+
+(*open Micromega.Polynomial*)
+open Big_int
+open Num
+
+module Mc = Micromega
+module Ml2C = Mutils.CamlToCoq
+module C2Ml = Mutils.CoqToCaml
+
+let (<+>) = add_num
+let (<->) = minus_num
+let (<*>) = mult_num
+
+type var = Mc.positive
+
+module Monomial :
+sig
+ type t
+ val const : t
+ val var : var -> t
+ val find : var -> t -> int
+ val mult : var -> t -> t
+ val prod : t -> t -> t
+ val compare : t -> t -> int
+ val pp : out_channel -> t -> unit
+ val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a
+end
+ =
+struct
+ (* A monomial is represented by a multiset of variables *)
+ module Map = Map.Make(struct type t = var let compare = Pervasives.compare end)
+ open Map
+
+ type t = int Map.t
+
+ (* The monomial that corresponds to a constant *)
+ let const = Map.empty
+
+ (* The monomial 'x' *)
+ let var x = Map.add x 1 Map.empty
+
+ (* Get the degre of a variable in a monomial *)
+ let find x m = try find x m with Not_found -> 0
+
+ (* Multiply a monomial by a variable *)
+ let mult x m = add x ( (find x m) + 1) m
+
+ (* Product of monomials *)
+ let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2
+
+ (* Total ordering of monomials *)
+ let compare m1 m2 = Map.compare Pervasives.compare m1 m2
+
+ let pp o m = Map.iter (fun k v ->
+ if v = 1 then Printf.fprintf o "x%i." (C2Ml.index k)
+ else Printf.fprintf o "x%i^%i." (C2Ml.index k) v) m
+
+ let fold = fold
+
+end
+
+
+module Poly :
+ (* A polynomial is a map of monomials *)
+ (*
+ This is probably a naive implementation
+ (expected to be fast enough - Coq is probably the bottleneck)
+ *The new ring contribution is using a sparse Horner representation.
+ *)
+sig
+ type t
+ val get : Monomial.t -> t -> num
+ val variable : var -> t
+ val add : Monomial.t -> num -> t -> t
+ val constant : num -> t
+ val mult : Monomial.t -> num -> t -> t
+ val product : t -> t -> t
+ val addition : t -> t -> t
+ val uminus : t -> t
+ val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a
+ val pp : out_channel -> t -> unit
+ val compare : t -> t -> int
+end =
+struct
+ (*normalisation bug : 0*x ... *)
+ module P = Map.Make(Monomial)
+ open P
+
+ type t = num P.t
+
+ let pp o p = P.iter (fun k v ->
+ if compare_num v (Int 0) <> 0
+ then
+ if Monomial.compare Monomial.const k = 0
+ then Printf.fprintf o "%s " (string_of_num v)
+ else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p
+
+ (* Get the coefficient of monomial mn *)
+ let get : Monomial.t -> t -> num =
+ fun mn p -> try find mn p with Not_found -> (Int 0)
+
+
+ (* The polynomial 1.x *)
+ let variable : var -> t =
+ fun x -> add (Monomial.var x) (Int 1) empty
+
+ (*The constant polynomial *)
+ let constant : num -> t =
+ fun c -> add (Monomial.const) c empty
+
+ (* The addition of a monomial *)
+
+ let add : Monomial.t -> num -> t -> t =
+ fun mn v p ->
+ let vl = (get mn p) <+> v in
+ add mn vl p
+
+
+ (** Design choice: empty is not a polynomial
+ I do not remember why ....
+ **)
+
+ (* The product by a monomial *)
+ let mult : Monomial.t -> num -> t -> t =
+ fun mn v p ->
+ fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty
+
+
+ let addition : t -> t -> t =
+ fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2
+
+
+ let product : t -> t -> t =
+ fun p1 p2 ->
+ fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty
+
+
+ let uminus : t -> t =
+ fun p -> map (fun v -> minus_num v) p
+
+ let fold = P.fold
+
+ let compare = compare compare_num
+end
+
+open Mutils
+type 'a number_spec = {
+ bigint_to_number : big_int -> 'a;
+ number_to_num : 'a -> num;
+ zero : 'a;
+ unit : 'a;
+ mult : 'a -> 'a -> 'a;
+ eqb : 'a -> 'a -> Mc.bool
+}
+
+let z_spec = {
+ bigint_to_number = Ml2C.bigint ;
+ number_to_num = (fun x -> Big_int (C2Ml.z_big_int x));
+ zero = Mc.Z0;
+ unit = Mc.Zpos Mc.XH;
+ mult = Mc.zmult;
+ eqb = Mc.zeq_bool
+}
+
+
+let q_spec = {
+ bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH});
+ number_to_num = C2Ml.q_to_num;
+ zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH};
+ unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH};
+ mult = Mc.qmult;
+ eqb = Mc.qeq_bool
+}
+
+let r_spec = z_spec
+
+
+
+
+let dev_form n_spec p =
+ let rec dev_form p =
+ match p with
+ | Mc.PEc z -> Poly.constant (n_spec.number_to_num z)
+ | Mc.PEX v -> Poly.variable v
+ | Mc.PEmul(p1,p2) ->
+ let p1 = dev_form p1 in
+ let p2 = dev_form p2 in
+ Poly.product p1 p2
+ | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2)
+ | Mc.PEopp p -> Poly.uminus (dev_form p)
+ | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2))
+ | Mc.PEpow(p,n) ->
+ let p = dev_form p in
+ let n = C2Ml.n n in
+ let rec pow n =
+ if n = 0
+ then Poly.constant (n_spec.number_to_num n_spec.unit)
+ else Poly.product p (pow (n-1)) in
+ pow n in
+ dev_form p
+
+
+let monomial_to_polynomial mn =
+ Monomial.fold
+ (fun v i acc ->
+ let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
+ if acc = Mc.PEc (Mc.Zpos Mc.XH)
+ then mn
+ else Mc.PEmul(mn,acc))
+ mn
+ (Mc.PEc (Mc.Zpos Mc.XH))
+
+let list_to_polynomial vars l =
+ assert (List.for_all (fun x -> ceiling_num x =/ x) l);
+ let var x = monomial_to_polynomial (List.nth vars x) in
+ let rec xtopoly p i = function
+ | [] -> p
+ | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l
+ else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
+ let mn =
+ if c = Mc.PEc (Mc.Zpos Mc.XH)
+ then var i
+ else Mc.PEmul (c,var i) in
+ let p' = if p = Mc.PEc Mc.Z0 then mn else
+ Mc.PEadd (mn, p) in
+ xtopoly p' (i+1) l in
+
+ xtopoly (Mc.PEc Mc.Z0) 0 l
+
+let rec fixpoint f x =
+ let y' = f x in
+ if y' = x then y'
+ else fixpoint f y'
+
+
+
+
+
+
+
+
+let rec_simpl_cone n_spec e =
+ let simpl_cone =
+ Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in
+
+ let rec rec_simpl_cone = function
+ | Mc.S_Mult(t1, t2) ->
+ simpl_cone (Mc.S_Mult (rec_simpl_cone t1, rec_simpl_cone t2))
+ | Mc.S_Add(t1,t2) ->
+ simpl_cone (Mc.S_Add (rec_simpl_cone t1, rec_simpl_cone t2))
+ | x -> simpl_cone x in
+ rec_simpl_cone e
+
+
+let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c
+
+type cone_prod =
+ Const of cone
+ | Ideal of cone *cone
+ | Mult of cone * cone
+ | Other of cone
+and cone = Mc.zWitness
+
+
+
+let factorise_linear_cone c =
+
+ let rec cone_list c l =
+ match c with
+ | Mc.S_Add (x,r) -> cone_list r (x::l)
+ | _ -> c :: l in
+
+ let factorise c1 c2 =
+ match c1 , c2 with
+ | Mc.S_Ideal(x,y) , Mc.S_Ideal(x',y') ->
+ if x = x' then Some (Mc.S_Ideal(x, Mc.S_Add(y,y'))) else None
+ | Mc.S_Mult(x,y) , Mc.S_Mult(x',y') ->
+ if x = x' then Some (Mc.S_Mult(x, Mc.S_Add(y,y'))) else None
+ | _ -> None in
+
+ let rec rebuild_cone l pending =
+ match l with
+ | [] -> (match pending with
+ | None -> Mc.S_Z
+ | Some p -> p
+ )
+ | e::l ->
+ (match pending with
+ | None -> rebuild_cone l (Some e)
+ | Some p -> (match factorise p e with
+ | None -> Mc.S_Add(p, rebuild_cone l (Some e))
+ | Some f -> rebuild_cone l (Some f) )
+ ) in
+
+ (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None)
+
+
+
+(* The binding with Fourier might be a bit obsolete
+ -- how does it handle equalities ? *)
+
+(* Certificates are elements of the cone such that P = 0 *)
+
+(* To begin with, we search for certificates of the form:
+ a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0
+ where pi >= 0 qi > 0
+ ai >= 0
+ bi >= 0
+ Sum bi + c >= 1
+ This is a linear problem: each monomial is considered as a variable.
+ Hence, we can use fourier.
+
+ The variable c is at index 0
+*)
+
+open Mfourier
+ (*module Fourier = Fourier(Vector.VList)(SysSet(Vector.VList))*)
+ (*module Fourier = Fourier(Vector.VSparse)(SysSetAlt(Vector.VSparse))*)
+module Fourier = Mfourier.Fourier(Vector.VSparse)(*(SysSetAlt(Vector.VMap))*)
+
+module Vect = Fourier.Vect
+open Fourier.Cstr
+
+(* fold_left followed by a rev ! *)
+
+let constrain_monomial mn l =
+ let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in
+ if mn = Monomial.const
+ then
+ { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ;
+ op = Eq ;
+ cst = Big_int zero_big_int }
+ else
+ { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ;
+ op = Eq ;
+ cst = Big_int zero_big_int }
+
+
+let positivity l =
+ let rec xpositivity i l =
+ match l with
+ | [] -> []
+ | (_,Mc.Equal)::l -> xpositivity (i+1) l
+ | (_,_)::l ->
+ {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ;
+ op = Ge ;
+ cst = Int 0 } :: (xpositivity (i+1) l)
+ in
+ xpositivity 0 l
+
+
+let string_of_op = function
+ | Mc.Strict -> "> 0"
+ | Mc.NonStrict -> ">= 0"
+ | Mc.Equal -> "= 0"
+ | Mc.NonEqual -> "<> 0"
+
+
+
+(* If the certificate includes at least one strict inequality,
+ the obtained polynomial can also be 0 *)
+let build_linear_system l =
+
+ (* Gather the monomials: HINT add up of the polynomials *)
+ let l' = List.map fst l in
+ let monomials =
+ List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l'
+ in (* For each monomial, compute a constraint *)
+ let s0 =
+ Poly.fold (fun mn _ res -> (constrain_monomial mn l')::res) monomials [] in
+ (* I need at least something strictly positive *)
+ let strict = {
+ coeffs = Vect.from_list ((Big_int unit_big_int)::
+ (List.map (fun (x,y) ->
+ match y with Mc.Strict ->
+ Big_int unit_big_int
+ | _ -> Big_int zero_big_int) l));
+ op = Ge ; cst = Big_int unit_big_int } in
+ (* Add the positivity constraint *)
+ {coeffs = Vect.from_list ([Big_int unit_big_int]) ;
+ op = Ge ;
+ cst = Big_int zero_big_int}::(strict::(positivity l)@s0)
+
+
+let big_int_to_z = Ml2C.bigint
+
+(* For Q, this is a pity that the certificate has been scaled
+ -- at a lower layer, certificates are using nums... *)
+let make_certificate n_spec cert li =
+ let bint_to_cst = n_spec.bigint_to_number in
+ match cert with
+ | [] -> None
+ | e::cert' ->
+ let cst = match compare_big_int e zero_big_int with
+ | 0 -> Mc.S_Z
+ | 1 -> Mc.S_Pos (bint_to_cst e)
+ | _ -> failwith "positivity error"
+ in
+ let rec scalar_product cert l =
+ match cert with
+ | [] -> Mc.S_Z
+ | c::cert -> match l with
+ | [] -> failwith "make_certificate(1)"
+ | i::l ->
+ let r = scalar_product cert l in
+ match compare_big_int c zero_big_int with
+ | -1 -> Mc.S_Add (
+ Mc.S_Ideal (Mc.PEc ( bint_to_cst c), Mc.S_In (Ml2C.nat i)),
+ r)
+ | 0 -> r
+ | _ -> Mc.S_Add (
+ Mc.S_Mult (Mc.S_Pos (bint_to_cst c), Mc.S_In (Ml2C.nat i)),
+ r) in
+
+ Some ((factorise_linear_cone
+ (simplify_cone n_spec (Mc.S_Add (cst, scalar_product cert' li)))))
+
+
+exception Found of Monomial.t
+
+let raw_certificate l =
+ let sys = build_linear_system l in
+ try
+ match Fourier.find_point sys with
+ | None -> None
+ | Some cert -> Some (rats_to_ints (Vect.to_list cert))
+ (* should not use rats_to_ints *)
+ with x ->
+ if debug
+ then (Printf.printf "raw certificate %s" (Printexc.to_string x);
+ flush stdout) ;
+ None
+
+
+let simple_linear_prover to_constant l =
+ let (lc,li) = List.split l in
+ match raw_certificate lc with
+ | None -> None (* No certificate *)
+ | Some cert -> make_certificate to_constant cert li
+
+
+
+let linear_prover n_spec l =
+ let li = List.combine l (interval 0 (List.length l -1)) in
+ let (l1,l') = List.partition
+ (fun (x,_) -> if snd' x = Mc.NonEqual then true else false) li in
+ let l' = List.map
+ (fun (c,i) -> let (Mc.Pair(x,y)) = c in
+ match y with
+ Mc.NonEqual -> failwith "cannot happen"
+ | y -> ((dev_form n_spec x, y),i)) l' in
+
+ simple_linear_prover n_spec l'
+
+
+let linear_prover n_spec l =
+ try linear_prover n_spec l with
+ x -> (print_string (Printexc.to_string x); None)
+
+(* zprover.... *)
+
+(* I need to gather the set of variables --->
+ Then go for fold
+ Once I have an interval, I need a certificate : 2 other fourier elims.
+ (I could probably get the certificate directly
+ as it is done in the fourier contrib.)
+*)
+
+let make_linear_system l =
+ let l' = List.map fst l in
+ let monomials = List.fold_left (fun acc p -> Poly.addition p acc)
+ (Poly.constant (Int 0)) l' in
+ let monomials = Poly.fold
+ (fun mn _ l -> if mn = Monomial.const then l else mn::l) monomials [] in
+ (List.map (fun (c,op) ->
+ {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ;
+ op = op ;
+ cst = minus_num ( (Poly.get Monomial.const c))}) l
+ ,monomials)
+
+
+open Interval
+let pplus x y = Mc.PEadd(x,y)
+let pmult x y = Mc.PEmul(x,y)
+let pconst x = Mc.PEc x
+let popp x = Mc.PEopp x
+
+let debug = false
+
+(* keep track of enumerated vectors *)
+let rec mem p x l =
+ match l with [] -> false | e::l -> if p x e then true else mem p x l
+
+let rec remove_assoc p x l =
+ match l with [] -> [] | e::l -> if p x (fst e) then
+ remove_assoc p x l else e::(remove_assoc p x l)
+
+let eq x y = Vect.compare x y = 0
+
+(* Beurk... this code is a shame *)
+
+let rec zlinear_prover sys = xzlinear_prover [] sys
+
+and xzlinear_prover enum l : (Mc.proofTerm option) =
+ match linear_prover z_spec l with
+ | Some prf -> Some (Mc.RatProof prf)
+ | None ->
+ let ll = List.fold_right (fun (Mc.Pair(e,k)) r -> match k with
+ Mc.NonEqual -> r
+ | k -> (dev_form z_spec e ,
+ match k with
+ | Mc.Strict | Mc.NonStrict -> Ge
+ (* Loss of precision -- weakness of fourier*)
+ | Mc.Equal -> Eq
+ | Mc.NonEqual -> failwith "Cannot happen") :: r) l [] in
+
+ let (sys,var) = make_linear_system ll in
+ let res =
+ match Fourier.find_Q_interval sys with
+ | Some(i,x,j) -> if i =/ j
+ then Some(i,Vect.set x (Int 1) Vect.null,i) else None
+ | None -> None in
+ let res = match res with
+ | None ->
+ begin
+ let candidates = List.fold_right
+ (fun cstr acc ->
+ let gcd = Big_int (Vect.gcd cstr.coeffs) in
+ let vect = Vect.mul (Int 1 // gcd) cstr.coeffs in
+ if mem eq vect enum then acc
+ else ((vect,Fourier.optimise vect sys)::acc)) sys [] in
+ let candidates = List.fold_left (fun l (x,i) ->
+ match i with
+ None -> (x,Empty)::l
+ | Some i -> (x,i)::l) [] (candidates) in
+ match List.fold_left (fun (x1,i1) (x2,i2) ->
+ if smaller_itv i1 i2
+ then (x1,i1) else (x2,i2)) (Vect.null,Itv(None,None)) candidates
+ with
+ | (i,Empty) -> None
+ | (x,Itv(Some i, Some j)) -> Some(i,x,j)
+ | (x,Point n) -> Some(n,x,n)
+ | x -> match Fourier.find_Q_interval sys with
+ | None -> None
+ | Some(i,x,j) ->
+ if i =/ j
+ then Some(i,Vect.set x (Int 1) Vect.null,i)
+ else None
+ end
+ | _ -> res in
+
+ match res with
+ | Some (lb,e,ub) ->
+ let (lbn,lbd) =
+ (Ml2C.bigint (sub_big_int (numerator lb) unit_big_int),
+ Ml2C.bigint (denominator lb)) in
+ let (ubn,ubd) =
+ (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) ,
+ Ml2C.bigint (denominator ub)) in
+ let expr = list_to_polynomial var (Vect.to_list e) in
+ (match
+ (*x <= ub -> x > ub *)
+ linear_prover z_spec
+ (Mc.Pair(pplus (pmult (pconst ubd) expr) (popp (pconst ubn)),
+ Mc.NonStrict) :: l),
+ (* lb <= x -> lb > x *)
+ linear_prover z_spec
+ (Mc.Pair( pplus (popp (pmult (pconst lbd) expr)) (pconst lbn) ,
+ Mc.NonStrict)::l)
+ with
+ | Some cub , Some clb ->
+ (match zlinear_enum (e::enum) expr
+ (ceiling_num lb) (floor_num ub) l
+ with
+ | None -> None
+ | Some prf ->
+ Some (Mc.EnumProof(Ml2C.q lb,expr,Ml2C.q ub,clb,cub,prf)))
+ | _ -> None
+ )
+ | _ -> None
+and xzlinear_enum enum expr clb cub l =
+ if clb >/ cub
+ then Some Mc.Nil
+ else
+ let pexpr = pplus (popp (pconst (Ml2C.bigint (numerator clb)))) expr in
+ let sys' = (Mc.Pair(pexpr, Mc.Equal))::l in
+ match xzlinear_prover enum sys' with
+ | None -> if debug then print_string "zlp?"; None
+ | Some prf -> if debug then print_string "zlp!";
+ match zlinear_enum enum expr (clb +/ (Int 1)) cub l with
+ | None -> None
+ | Some prfl -> Some (Mc.Cons(prf,prfl))
+
+and zlinear_enum enum expr clb cub l =
+ let res = xzlinear_enum enum expr clb cub l in
+ if debug then Printf.printf "zlinear_enum %s %s -> %s\n"
+ (string_of_num clb)
+ (string_of_num cub)
+ (match res with
+ | None -> "None"
+ | Some r -> "Some") ; res
+
diff --git a/contrib/micromega/coq_micromega.ml b/contrib/micromega/coq_micromega.ml
new file mode 100644
index 00000000..29e2a183
--- /dev/null
+++ b/contrib/micromega/coq_micromega.ml
@@ -0,0 +1,1290 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+open Mutils
+let debug = false
+
+let time str f x =
+ let t0 = (Unix.times()).Unix.tms_utime in
+ let res = f x in
+ let t1 = (Unix.times()).Unix.tms_utime in
+ (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ;
+ flush stdout);
+ res
+
+type ('a,'b) formula =
+ | TT
+ | FF
+ | X of 'b
+ | A of 'a * Names.name
+ | C of ('a,'b) formula * ('a,'b) formula * Names.name
+ | D of ('a,'b) formula * ('a,'b) formula * Names.name
+ | N of ('a,'b) formula * Names.name
+ | I of ('a,'b) formula * ('a,'b) formula * Names.name
+
+let none = Names.Anonymous
+
+let tag_formula t f =
+ match f with
+ | A(x,_) -> A(x,t)
+ | C(x,y,_) -> C(x,y,t)
+ | D(x,y,_) -> D(x,y,t)
+ | N(x,_) -> N(x,t)
+ | I(x,y,_) -> I(x,y,t)
+ | _ -> f
+
+let tt = []
+let ff = [ [] ]
+
+
+type ('constant,'contr) sentence =
+ ('constant Micromega.formula, 'contr) formula
+
+let cnf negate normalise f =
+ let negate a =
+ CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (negate a) in
+
+ let normalise a =
+ CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (normalise a) in
+
+ let and_cnf x y = x @ y in
+ let or_clause_cnf t f = List.map (fun x -> t@x ) f in
+
+ let rec or_cnf f f' =
+ match f with
+ | [] -> tt
+ | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in
+
+ let rec xcnf (pol : bool) f =
+ match f with
+ | TT -> if pol then tt else ff (* ?? *)
+ | FF -> if pol then ff else tt (* ?? *)
+ | X p -> if pol then ff else ff (* ?? *)
+ | A(x,t) -> if pol then normalise x else negate x
+ | N(e,t) -> xcnf (not pol) e
+ | C(e1,e2,t) ->
+ (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2)
+ | D(e1,e2,t) ->
+ (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2)
+ | I(e1,e2,t) ->
+ (if pol then or_cnf else and_cnf) (xcnf (not pol) e1) (xcnf pol e2) in
+
+ xcnf true f
+
+
+
+module M =
+struct
+ open Coqlib
+ open Term
+ (* let constant = gen_constant_in_modules "Omicron" coq_modules*)
+
+
+ let logic_dir = ["Coq";"Logic";"Decidable"]
+ let coq_modules =
+ init_modules @
+ [logic_dir] @ arith_modules @ zarith_base_modules @
+ [ ["Coq";"Lists";"List"];
+ ["ZMicromega"];
+ ["Tauto"];
+ ["RingMicromega"];
+ ["EnvRing"];
+ ["Coq"; "micromega"; "ZMicromega"];
+ ["Coq" ; "micromega" ; "Tauto"];
+ ["Coq" ; "micromega" ; "RingMicromega"];
+ ["Coq" ; "micromega" ; "EnvRing"];
+ ["Coq";"QArith"; "QArith_base"];
+ ["Coq";"Reals" ; "Rdefinitions"];
+ ["LRing_normalise"]]
+
+ let constant = gen_constant_in_modules "ZMicromega" coq_modules
+
+ let coq_and = lazy (constant "and")
+ let coq_or = lazy (constant "or")
+ let coq_not = lazy (constant "not")
+ let coq_iff = lazy (constant "iff")
+ let coq_True = lazy (constant "True")
+ let coq_False = lazy (constant "False")
+
+ let coq_cons = lazy (constant "cons")
+ let coq_nil = lazy (constant "nil")
+ let coq_list = lazy (constant "list")
+
+ let coq_O = lazy (constant "O")
+ let coq_S = lazy (constant "S")
+ let coq_nat = lazy (constant "nat")
+
+ let coq_NO = lazy
+ (gen_constant_in_modules "N" [ ["Coq";"NArith";"BinNat" ]] "N0")
+ let coq_Npos = lazy
+ (gen_constant_in_modules "N" [ ["Coq";"NArith"; "BinNat"]] "Npos")
+ (* let coq_n = lazy (constant "N")*)
+
+ let coq_pair = lazy (constant "pair")
+ let coq_None = lazy (constant "None")
+ let coq_option = lazy (constant "option")
+ let coq_positive = lazy (constant "positive")
+ let coq_xH = lazy (constant "xH")
+ let coq_xO = lazy (constant "xO")
+ let coq_xI = lazy (constant "xI")
+
+ let coq_N0 = lazy (constant "N0")
+ let coq_N0 = lazy (constant "Npos")
+
+
+ let coq_Z = lazy (constant "Z")
+ let coq_Q = lazy (constant "Q")
+ let coq_R = lazy (constant "R")
+
+ let coq_ZERO = lazy (constant "Z0")
+ let coq_POS = lazy (constant "Zpos")
+ let coq_NEG = lazy (constant "Zneg")
+
+ let coq_QWitness = lazy
+ (gen_constant_in_modules "QMicromega"
+ [["Coq"; "micromega"; "QMicromega"]] "QWitness")
+ let coq_ZWitness = lazy
+ (gen_constant_in_modules "QMicromega"
+ [["Coq"; "micromega"; "ZMicromega"]] "ZWitness")
+
+
+ let coq_Build_Witness = lazy (constant "Build_Witness")
+
+
+ let coq_Qmake = lazy (constant "Qmake")
+
+ let coq_proofTerm = lazy (constant "ProofTerm")
+ let coq_ratProof = lazy (constant "RatProof")
+ let coq_cutProof = lazy (constant "CutProof")
+ let coq_enumProof = lazy (constant "EnumProof")
+
+ let coq_Zgt = lazy (constant "Zgt")
+ let coq_Zge = lazy (constant "Zge")
+ let coq_Zle = lazy (constant "Zle")
+ let coq_Zlt = lazy (constant "Zlt")
+ let coq_Eq = lazy (constant "eq")
+
+ let coq_Zplus = lazy (constant "Zplus")
+ let coq_Zminus = lazy (constant "Zminus")
+ let coq_Zopp = lazy (constant "Zopp")
+ let coq_Zmult = lazy (constant "Zmult")
+ let coq_N_of_Z = lazy
+ (gen_constant_in_modules "ZArithRing"
+ [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z")
+
+
+ let coq_PEX = lazy (constant "PEX" )
+ let coq_PEc = lazy (constant"PEc")
+ let coq_PEadd = lazy (constant "PEadd")
+ let coq_PEopp = lazy (constant "PEopp")
+ let coq_PEmul = lazy (constant "PEmul")
+ let coq_PEsub = lazy (constant "PEsub")
+ let coq_PEpow = lazy (constant "PEpow")
+
+
+ let coq_OpEq = lazy (constant "OpEq")
+ let coq_OpNEq = lazy (constant "OpNEq")
+ let coq_OpLe = lazy (constant "OpLe")
+ let coq_OpLt = lazy (constant "OpLt")
+ let coq_OpGe = lazy (constant "OpGe")
+ let coq_OpGt = lazy (constant "OpGt")
+
+
+ let coq_S_In = lazy (constant "S_In")
+ let coq_S_Square = lazy (constant "S_Square")
+ let coq_S_Monoid = lazy (constant "S_Monoid")
+ let coq_S_Ideal = lazy (constant "S_Ideal")
+ let coq_S_Mult = lazy (constant "S_Mult")
+ let coq_S_Add = lazy (constant "S_Add")
+ let coq_S_Pos = lazy (constant "S_Pos")
+ let coq_S_Z = lazy (constant "S_Z")
+ let coq_coneMember = lazy (constant "coneMember")
+
+
+ let coq_make_impl = lazy
+ (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl")
+ let coq_make_conj = lazy
+ (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj")
+
+ let coq_Build = lazy
+ (gen_constant_in_modules "RingMicromega"
+ [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ]
+ "Build_Formula")
+ let coq_Cstr = lazy
+ (gen_constant_in_modules "RingMicromega"
+ [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula")
+
+ type parse_error =
+ | Ukn
+ | BadStr of string
+ | BadNum of int
+ | BadTerm of Term.constr
+ | Msg of string
+ | Goal of (Term.constr list ) * Term.constr * parse_error
+
+ let string_of_error = function
+ | Ukn -> "ukn"
+ | BadStr s -> s
+ | BadNum i -> string_of_int i
+ | BadTerm _ -> "BadTerm"
+ | Msg s -> s
+ | Goal _ -> "Goal"
+
+
+ exception ParseError
+
+
+
+
+ let get_left_construct term =
+ match Term.kind_of_term term with
+ | Term.Construct(_,i) -> (i,[| |])
+ | Term.App(l,rst) ->
+ (match Term.kind_of_term l with
+ | Term.Construct(_,i) -> (i,rst)
+ | _ -> raise ParseError
+ )
+ | _ -> raise ParseError
+
+ module Mc = Micromega
+
+ let rec parse_nat term =
+ let (i,c) = get_left_construct term in
+ match i with
+ | 1 -> Mc.O
+ | 2 -> Mc.S (parse_nat (c.(0)))
+ | i -> raise ParseError
+
+
+ let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n)
+
+
+ let rec dump_nat x =
+ match x with
+ | Mc.O -> Lazy.force coq_O
+ | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |])
+
+
+ let rec parse_positive term =
+ let (i,c) = get_left_construct term in
+ match i with
+ | 1 -> Mc.XI (parse_positive c.(0))
+ | 2 -> Mc.XO (parse_positive c.(0))
+ | 3 -> Mc.XH
+ | i -> raise ParseError
+
+
+ let rec dump_positive x =
+ match x with
+ | Mc.XH -> Lazy.force coq_xH
+ | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |])
+ | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |])
+
+ let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x)
+
+
+ let rec dump_n x =
+ match x with
+ | Mc.N0 -> Lazy.force coq_N0
+ | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|])
+
+ let rec dump_index x =
+ match x with
+ | Mc.XH -> Lazy.force coq_xH
+ | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |])
+ | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |])
+
+
+ let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x)
+
+ let rec dump_n x =
+ match x with
+ | Mc.N0 -> Lazy.force coq_NO
+ | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p |])
+
+ let rec pp_n o x = output_string o (string_of_int (CoqToCaml.n x))
+
+ let dump_pair t1 t2 dump_t1 dump_t2 (Mc.Pair (x,y)) =
+ Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|])
+
+
+ let rec parse_z term =
+ let (i,c) = get_left_construct term in
+ match i with
+ | 1 -> Mc.Z0
+ | 2 -> Mc.Zpos (parse_positive c.(0))
+ | 3 -> Mc.Zneg (parse_positive c.(0))
+ | i -> raise ParseError
+
+ let dump_z x =
+ match x with
+ | Mc.Z0 ->Lazy.force coq_ZERO
+ | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|])
+ | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|])
+
+ let pp_z o x = Printf.fprintf o "%i" (CoqToCaml.z x)
+
+let dump_num bd1 =
+ Term.mkApp(Lazy.force coq_Qmake,
+ [|dump_z (CamlToCoq.bigint (numerator bd1)) ;
+ dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |])
+
+
+let dump_q q =
+ Term.mkApp(Lazy.force coq_Qmake,
+ [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|])
+
+let parse_q term =
+ match Term.kind_of_term term with
+ | Term.App(c, args) ->
+ (
+ match Term.kind_of_term c with
+ Term.Construct((n,j),i) ->
+ if Names.string_of_kn n = "Coq.QArith.QArith_base#<>#Q"
+ then {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) }
+ else raise ParseError
+ | _ -> raise ParseError
+ )
+ | _ -> raise ParseError
+
+ let rec parse_list parse_elt term =
+ let (i,c) = get_left_construct term in
+ match i with
+ | 1 -> Mc.Nil
+ | 2 -> Mc.Cons(parse_elt c.(1), parse_list parse_elt c.(2))
+ | i -> raise ParseError
+
+
+ let rec dump_list typ dump_elt l =
+ match l with
+ | Mc.Nil -> Term.mkApp(Lazy.force coq_nil,[| typ |])
+ | Mc.Cons(e,l) -> Term.mkApp(Lazy.force coq_cons,
+ [| typ; dump_elt e;dump_list typ dump_elt l|])
+
+ let rec dump_ml_list typ dump_elt l =
+ match l with
+ | [] -> Term.mkApp(Lazy.force coq_nil,[| typ |])
+ | e::l -> Term.mkApp(Lazy.force coq_cons,
+ [| typ; dump_elt e;dump_ml_list typ dump_elt l|])
+
+
+
+ let pp_list op cl elt o l =
+ let rec _pp o l =
+ match l with
+ | Mc.Nil -> ()
+ | Mc.Cons(e,Mc.Nil) -> Printf.fprintf o "%a" elt e
+ | Mc.Cons(e,l) -> Printf.fprintf o "%a ,%a" elt e _pp l in
+ Printf.fprintf o "%s%a%s" op _pp l cl
+
+
+
+ let pp_var = pp_positive
+ let dump_var = dump_positive
+
+ let rec pp_expr o e =
+ match e with
+ | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n
+ | Mc.PEc z -> pp_z o z
+ | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2
+ | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2
+ | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e
+ | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2
+ | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n n
+
+
+ let dump_expr typ dump_z e =
+ let rec dump_expr e =
+ match e with
+ | Mc.PEX n -> mkApp(Lazy.force coq_PEX,[| typ; dump_var n |])
+ | Mc.PEc z -> mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |])
+ | Mc.PEadd(e1,e2) -> mkApp(Lazy.force coq_PEadd,
+ [| typ; dump_expr e1;dump_expr e2|])
+ | Mc.PEsub(e1,e2) -> mkApp(Lazy.force coq_PEsub,
+ [| typ; dump_expr e1;dump_expr e2|])
+ | Mc.PEopp e -> mkApp(Lazy.force coq_PEopp,
+ [| typ; dump_expr e|])
+ | Mc.PEmul(e1,e2) -> mkApp(Lazy.force coq_PEmul,
+ [| typ; dump_expr e1;dump_expr e2|])
+ | Mc.PEpow(e,n) -> mkApp(Lazy.force coq_PEpow,
+ [| typ; dump_expr e; dump_n n|])
+ in
+ dump_expr e
+
+ let rec dump_monoid l = dump_list (Lazy.force coq_nat) dump_nat l
+
+ let rec dump_cone typ dump_z e =
+ let z = Lazy.force typ in
+ let rec dump_cone e =
+ match e with
+ | Mc.S_In n -> mkApp(Lazy.force coq_S_In,[| z; dump_nat n |])
+ | Mc.S_Ideal(e,c) -> mkApp(Lazy.force coq_S_Ideal,
+ [| z; dump_expr z dump_z e ; dump_cone c |])
+ | Mc.S_Square e -> mkApp(Lazy.force coq_S_Square,
+ [| z;dump_expr z dump_z e|])
+ | Mc.S_Monoid l -> mkApp (Lazy.force coq_S_Monoid,
+ [|z; dump_monoid l|])
+ | Mc.S_Add(e1,e2) -> mkApp(Lazy.force coq_S_Add,
+ [| z; dump_cone e1; dump_cone e2|])
+ | Mc.S_Mult(e1,e2) -> mkApp(Lazy.force coq_S_Mult,
+ [| z; dump_cone e1; dump_cone e2|])
+ | Mc.S_Pos p -> mkApp(Lazy.force coq_S_Pos,[| z; dump_z p|])
+ | Mc.S_Z -> mkApp( Lazy.force coq_S_Z,[| z|]) in
+ dump_cone e
+
+
+ let pp_cone pp_z o e =
+ let rec pp_cone o e =
+ match e with
+ | Mc.S_In n ->
+ Printf.fprintf o "(S_In %a)%%nat" pp_nat n
+ | Mc.S_Ideal(e,c) ->
+ Printf.fprintf o "(S_Ideal %a %a)" pp_expr e pp_cone c
+ | Mc.S_Square e ->
+ Printf.fprintf o "(S_Square %a)" pp_expr e
+ | Mc.S_Monoid l ->
+ Printf.fprintf o "(S_Monoid %a)" (pp_list "[" "]" pp_nat) l
+ | Mc.S_Add(e1,e2) ->
+ Printf.fprintf o "(S_Add %a %a)" pp_cone e1 pp_cone e2
+ | Mc.S_Mult(e1,e2) ->
+ Printf.fprintf o "(S_Mult %a %a)" pp_cone e1 pp_cone e2
+ | Mc.S_Pos p ->
+ Printf.fprintf o "(S_Pos %a)%%positive" pp_z p
+ | Mc.S_Z ->
+ Printf.fprintf o "S_Z" in
+ pp_cone o e
+
+
+
+
+ let rec parse_op term =
+ let (i,c) = get_left_construct term in
+ match i with
+ | 1 -> Mc.OpEq
+ | 2 -> Mc.OpLe
+ | 3 -> Mc.OpGe
+ | 4 -> Mc.OpGt
+ | 5 -> Mc.OpLt
+ | i -> raise ParseError
+
+
+ let rec dump_op = function
+ | Mc.OpEq-> Lazy.force coq_OpEq
+ | Mc.OpNEq-> Lazy.force coq_OpNEq
+ | Mc.OpLe -> Lazy.force coq_OpLe
+ | Mc.OpGe -> Lazy.force coq_OpGe
+ | Mc.OpGt-> Lazy.force coq_OpGt
+ | Mc.OpLt-> Lazy.force coq_OpLt
+
+
+
+ let pp_op o e=
+ match e with
+ | Mc.OpEq-> Printf.fprintf o "="
+ | Mc.OpNEq-> Printf.fprintf o "<>"
+ | Mc.OpLe -> Printf.fprintf o "=<"
+ | Mc.OpGe -> Printf.fprintf o ">="
+ | Mc.OpGt-> Printf.fprintf o ">"
+ | Mc.OpLt-> Printf.fprintf o "<"
+
+
+
+
+ let pp_cstr o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } =
+ Printf.fprintf o"(%a %a %a)" pp_expr l pp_op op pp_expr r
+
+ let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} =
+ Term.mkApp(Lazy.force coq_Build,
+ [| typ; dump_expr typ dump_constant e1 ;
+ dump_op o ;
+ dump_expr typ dump_constant e2|])
+
+
+
+ let parse_zop (op,args) =
+ match kind_of_term op with
+ | Const x ->
+ (match Names.string_of_con x with
+ | "Coq.ZArith.BinInt#<>#Zgt" -> (Mc.OpGt, args.(0), args.(1))
+ | "Coq.ZArith.BinInt#<>#Zge" -> (Mc.OpGe, args.(0), args.(1))
+ | "Coq.ZArith.BinInt#<>#Zlt" -> (Mc.OpLt, args.(0), args.(1))
+ | "Coq.ZArith.BinInt#<>#Zle" -> (Mc.OpLe, args.(0), args.(1))
+ (*| "Coq.Init.Logic#<>#not" -> Mc.OpNEq (* for backward compat *)*)
+ | s -> raise ParseError
+ )
+ | Ind(n,0) ->
+ (match Names.string_of_kn n with
+ | "Coq.Init.Logic#<>#eq" ->
+ if args.(0) <> Lazy.force coq_Z
+ then raise ParseError
+ else (Mc.OpEq, args.(1), args.(2))
+ | _ -> raise ParseError)
+ | _ -> failwith "parse_zop"
+
+
+ let parse_rop (op,args) =
+ try
+ match kind_of_term op with
+ | Const x ->
+ (match Names.string_of_con x with
+ | "Coq.Reals.Rdefinitions#<>#Rgt" -> (Mc.OpGt, args.(0), args.(1))
+ | "Coq.Reals.Rdefinitions#<>#Rge" -> (Mc.OpGe, args.(0), args.(1))
+ | "Coq.Reals.Rdefinitions#<>#Rlt" -> (Mc.OpLt, args.(0), args.(1))
+ | "Coq.Reals.Rdefinitions#<>#Rle" -> (Mc.OpLe, args.(0), args.(1))
+ (*| "Coq.Init.Logic#<>#not"-> Mc.OpNEq (* for backward compat *)*)
+ | s -> raise ParseError
+ )
+ | Ind(n,0) ->
+ (match Names.string_of_kn n with
+ | "Coq.Init.Logic#<>#eq" ->
+ (* if args.(0) <> Lazy.force coq_R
+ then raise ParseError
+ else*) (Mc.OpEq, args.(1), args.(2))
+ | _ -> raise ParseError)
+ | _ -> failwith "parse_rop"
+ with x ->
+ (Pp.pp (Pp.str "parse_rop failure ") ;
+ Pp.pp (Printer.prterm op) ; Pp.pp_flush ())
+ ; raise x
+
+
+ let parse_qop (op,args) =
+ (
+ (match kind_of_term op with
+ | Const x ->
+ (match Names.string_of_con x with
+ | "Coq.QArith.QArith_base#<>#Qgt" -> Mc.OpGt
+ | "Coq.QArith.QArith_base#<>#Qge" -> Mc.OpGe
+ | "Coq.QArith.QArith_base#<>#Qlt" -> Mc.OpLt
+ | "Coq.QArith.QArith_base#<>#Qle" -> Mc.OpLe
+ | "Coq.QArith.QArith_base#<>#Qeq" -> Mc.OpEq
+ | s -> raise ParseError
+ )
+ | _ -> failwith "parse_zop") , args.(0) , args.(1))
+
+
+ module Env =
+ struct
+ type t = constr list
+
+ let compute_rank_add env v =
+ let rec _add env n v =
+ match env with
+ | [] -> ([v],n)
+ | e::l ->
+ if eq_constr e v
+ then (env,n)
+ else
+ let (env,n) = _add l ( n+1) v in
+ (e::env,n) in
+ let (env, n) = _add env 1 v in
+ (env, CamlToCoq.idx n)
+
+
+ let empty = []
+
+ let elements env = env
+
+ end
+
+
+ let is_constant t = (* This is an approx *)
+ match kind_of_term t with
+ | Construct(i,_) -> true
+ | _ -> false
+
+
+ type 'a op =
+ | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr)
+ | Opp
+ | Power
+ | Ukn of string
+
+
+ let parse_expr parse_constant parse_exp ops_spec env term =
+ if debug
+ then (Pp.pp (Pp.str "parse_expr: ");
+ Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ());
+
+ let constant_or_variable env term =
+ try
+ ( Mc.PEc (parse_constant term) , env)
+ with ParseError ->
+ let (env,n) = Env.compute_rank_add env term in
+ (Mc.PEX n , env) in
+
+ let rec parse_expr env term =
+ let combine env op (t1,t2) =
+ let (expr1,env) = parse_expr env t1 in
+ let (expr2,env) = parse_expr env t2 in
+ (op expr1 expr2,env) in
+ match kind_of_term term with
+ | App(t,args) ->
+ (
+ match kind_of_term t with
+ | Const c ->
+ ( match ops_spec (Names.string_of_con c) with
+ | Binop f -> combine env f (args.(0),args.(1))
+ | Opp -> let (expr,env) = parse_expr env args.(0) in
+ (Mc.PEopp expr, env)
+ | Power ->
+ let (expr,env) = parse_expr env args.(0) in
+ let exp = (parse_exp args.(1)) in
+ (Mc.PEpow(expr, exp) , env)
+ | Ukn s ->
+ if debug
+ then (Printf.printf "unknown op: %s\n" s; flush stdout;);
+ let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
+ )
+ | _ -> constant_or_variable env term
+ )
+ | _ -> constant_or_variable env term in
+ parse_expr env term
+
+
+let zop_spec = function
+ | "Coq.ZArith.BinInt#<>#Zplus" -> Binop (fun x y -> Mc.PEadd(x,y))
+ | "Coq.ZArith.BinInt#<>#Zminus" -> Binop (fun x y -> Mc.PEsub(x,y))
+ | "Coq.ZArith.BinInt#<>#Zmult" -> Binop (fun x y -> Mc.PEmul (x,y))
+ | "Coq.ZArith.BinInt#<>#Zopp" -> Opp
+ | "Coq.ZArith.Zpow_def#<>#Zpower" -> Power
+ | s -> Ukn s
+
+let qop_spec = function
+ | "Coq.QArith.QArith_base#<>#Qplus" -> Binop (fun x y -> Mc.PEadd(x,y))
+ | "Coq.QArith.QArith_base#<>#Qminus" -> Binop (fun x y -> Mc.PEsub(x,y))
+ | "Coq.QArith.QArith_base#<>#Qmult" -> Binop (fun x y -> Mc.PEmul (x,y))
+ | "Coq.QArith.QArith_base#<>#Qopp" -> Opp
+ | "Coq.QArith.QArith_base#<>#Qpower" -> Power
+ | s -> Ukn s
+
+let rop_spec = function
+ | "Coq.Reals.Rdefinitions#<>#Rplus" -> Binop (fun x y -> Mc.PEadd(x,y))
+ | "Coq.Reals.Rdefinitions#<>#Rminus" -> Binop (fun x y -> Mc.PEsub(x,y))
+ | "Coq.Reals.Rdefinitions#<>#Rmult" -> Binop (fun x y -> Mc.PEmul (x,y))
+ | "Coq.Reals.Rdefinitions#<>#Ropp" -> Opp
+ | "Coq.Reals.Rpow_def#<>#pow" -> Power
+ | s -> Ukn s
+
+
+
+
+
+let zconstant = parse_z
+let qconstant = parse_q
+
+
+let rconstant term =
+ if debug
+ then (Pp.pp_flush ();
+ Pp.pp (Pp.str "rconstant: ");
+ Pp.pp (Printer.prterm term); Pp.pp_flush ());
+ match Term.kind_of_term term with
+ | Const x ->
+ (match Names.string_of_con x with
+ | "Coq.Reals.Rdefinitions#<>#R0" -> Mc.Z0
+ | "Coq.Reals.Rdefinitions#<>#R1" -> Mc.Zpos Mc.XH
+ | _ -> raise ParseError
+ )
+ | _ -> raise ParseError
+
+
+let parse_zexpr =
+ parse_expr zconstant (fun x -> Mc.n_of_Z (parse_z x)) zop_spec
+let parse_qexpr =
+ parse_expr qconstant (fun x -> Mc.n_of_Z (parse_z x)) qop_spec
+let parse_rexpr =
+ parse_expr rconstant (fun x -> Mc.n_of_nat (parse_nat x)) rop_spec
+
+
+ let parse_arith parse_op parse_expr env cstr =
+ if debug
+ then (Pp.pp_flush ();
+ Pp.pp (Pp.str "parse_arith: ");
+ Pp.pp (Printer.prterm cstr);
+ Pp.pp_flush ());
+ match kind_of_term cstr with
+ | App(op,args) ->
+ let (op,lhs,rhs) = parse_op (op,args) in
+ let (e1,env) = parse_expr env lhs in
+ let (e2,env) = parse_expr env rhs in
+ ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env)
+ | _ -> failwith "error : parse_arith(2)"
+
+ let parse_zarith = parse_arith parse_zop parse_zexpr
+
+ let parse_qarith = parse_arith parse_qop parse_qexpr
+
+ let parse_rarith = parse_arith parse_rop parse_rexpr
+
+
+ (* generic parsing of arithmetic expressions *)
+
+ let rec parse_conj parse_arith env term =
+ match kind_of_term term with
+ | App(l,rst) ->
+ (match kind_of_term l with
+ | Ind (n,_) ->
+ ( match Names.string_of_kn n with
+ | "Coq.Init.Logic#<>#and" ->
+ let (e1,env) = parse_arith env rst.(0) in
+ let (e2,env) = parse_conj parse_arith env rst.(1) in
+ (Mc.Cons(e1,e2),env)
+ | _ -> (* This might be an equality *)
+ let (e,env) = parse_arith env term in
+ (Mc.Cons(e,Mc.Nil),env))
+ | _ -> (* This is an arithmetic expression *)
+ let (e,env) = parse_arith env term in
+ (Mc.Cons(e,Mc.Nil),env))
+ | _ -> failwith "parse_conj(2)"
+
+
+
+ let rec f2f = function
+ | TT -> Mc.TT
+ | FF -> Mc.FF
+ | X _ -> Mc.X
+ | A (x,_) -> Mc.A x
+ | C (a,b,_) -> Mc.Cj(f2f a,f2f b)
+ | D (a,b,_) -> Mc.D(f2f a,f2f b)
+ | N (a,_) -> Mc.N(f2f a)
+ | I(a,b,_) -> Mc.I(f2f a,f2f b)
+
+ let is_prop t =
+ match t with
+ | Names.Anonymous -> true (* Not quite right *)
+ | Names.Name x -> false
+
+ let mkC f1 f2 = C(f1,f2,none)
+ let mkD f1 f2 = D(f1,f2,none)
+ let mkIff f1 f2 = C(I(f1,f2,none),I(f2,f2,none),none)
+ let mkI f1 f2 = I(f1,f2,none)
+
+ let mkformula_binary g term f1 f2 =
+ match f1 , f2 with
+ | X _ , X _ -> X(term)
+ | _ -> g f1 f2
+
+ let parse_formula parse_atom env term =
+ let parse_atom env t = try let (at,env) = parse_atom env t in (A(at,none), env) with _ -> (X(t),env) in
+
+ let rec xparse_formula env term =
+ match kind_of_term term with
+ | App(l,rst) ->
+ (match rst with
+ | [|a;b|] when l = Lazy.force coq_and ->
+ let f,env = xparse_formula env a in
+ let g,env = xparse_formula env b in
+ mkformula_binary mkC term f g,env
+ | [|a;b|] when l = Lazy.force coq_or ->
+ let f,env = xparse_formula env a in
+ let g,env = xparse_formula env b in
+ mkformula_binary mkD term f g,env
+ | [|a|] when l = Lazy.force coq_not ->
+ let (f,env) = xparse_formula env a in (N(f,none), env)
+ | [|a;b|] when l = Lazy.force coq_iff ->
+ let f,env = xparse_formula env a in
+ let g,env = xparse_formula env b in
+ mkformula_binary mkIff term f g,env
+ | _ -> parse_atom env term)
+ | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) ->
+ let f,env = xparse_formula env a in
+ let g,env = xparse_formula env b in
+ mkformula_binary mkI term f g,env
+ | _ when term = Lazy.force coq_True -> (TT,env)
+ | _ when term = Lazy.force coq_False -> (FF,env)
+ | _ -> X(term),env in
+ xparse_formula env term
+
+ let coq_TT = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT")
+ let coq_FF = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF")
+ let coq_And = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj")
+ let coq_Or = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D")
+ let coq_Neg = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N")
+ let coq_Atom = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A")
+ let coq_X = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X")
+ let coq_Impl = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I")
+ let coq_Formula = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula")
+
+ let dump_formula typ dump_atom f =
+ let rec xdump f =
+ match f with
+ | TT -> mkApp(Lazy.force coq_TT,[| typ|])
+ | FF -> mkApp(Lazy.force coq_FF,[| typ|])
+ | C(x,y,_) -> mkApp(Lazy.force coq_And,[| typ ; xdump x ; xdump y|])
+ | D(x,y,_) -> mkApp(Lazy.force coq_Or,[| typ ; xdump x ; xdump y|])
+ | I(x,y,_) -> mkApp(Lazy.force coq_Impl,[| typ ; xdump x ; xdump y|])
+ | N(x,_) -> mkApp(Lazy.force coq_Neg,[| typ ; xdump x|])
+ | A(x,_) -> mkApp(Lazy.force coq_Atom,[| typ ; dump_atom x|])
+ | X(t) -> mkApp(Lazy.force coq_X,[| typ ; t|]) in
+
+ xdump f
+
+
+ (* Backward compat *)
+
+ let rec parse_concl parse_arith env term =
+ match kind_of_term term with
+ | Prod(_,expr,rst) -> (* a -> b *)
+ let (lhs,rhs,env) = parse_concl parse_arith env rst in
+ let (e,env) = parse_arith env expr in
+ (Mc.Cons(e,lhs),rhs,env)
+ | App(_,_) ->
+ let (conj, env) = parse_conj parse_arith env term in
+ (Mc.Nil,conj,env)
+ | Ind(n,_) ->
+ (match (Names.string_of_kn n) with
+ | "Coq.Init.Logic#<>#False" -> (Mc.Nil,Mc.Nil,env)
+ | s ->
+ print_string s ; flush stdout;
+ failwith "parse_concl")
+ | _ -> failwith "parse_concl"
+
+
+ let rec parse_hyps parse_arith env goal_hyps hyps =
+ match hyps with
+ | [] -> ([],goal_hyps,env)
+ | (i,t)::l ->
+ let (li,lt,env) = parse_hyps parse_arith env goal_hyps l in
+ try
+ let (c,env) = parse_arith env t in
+ (i::li, Mc.Cons(c,lt), env)
+ with x ->
+ (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
+ (li,lt,env)
+
+
+ let parse_goal parse_arith env hyps term =
+ try
+ let (lhs,rhs,env) = parse_concl parse_arith env term in
+ let (li,lt,env) = parse_hyps parse_arith env lhs hyps in
+ (li,lt,rhs,env)
+ with Failure x -> raise ParseError
+ (* backward compat *)
+
+
+ (* ! reverse the list of bindings *)
+ let set l concl =
+ let rec _set acc = function
+ | [] -> acc
+ | (e::l) ->
+ let (name,expr,typ) = e in
+ _set (Term.mkNamedLetIn
+ (Names.id_of_string name)
+ expr typ acc) l in
+ _set concl l
+
+
+end
+
+open M
+
+
+let rec sig_of_cone = function
+ | Mc.S_In n -> [CoqToCaml.nat n]
+ | Mc.S_Ideal(e,w) -> sig_of_cone w
+ | Mc.S_Mult(w1,w2) ->
+ (sig_of_cone w1)@(sig_of_cone w2)
+ | Mc.S_Add(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2)
+ | _ -> []
+
+let same_proof sg cl1 cl2 =
+ let cl1 = CoqToCaml.list (fun x -> x) cl1 in
+ let cl2 = CoqToCaml.list (fun x -> x) cl2 in
+ let rec xsame_proof sg =
+ match sg with
+ | [] -> true
+ | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false)
+ && (xsame_proof sg ) in
+ xsame_proof sg
+
+
+
+
+let tags_of_clause tgs wit clause =
+ let rec xtags tgs = function
+ | Mc.S_In n -> Names.Idset.union tgs
+ (snd (List.nth clause (CoqToCaml.nat n) ))
+ | Mc.S_Ideal(e,w) -> xtags tgs w
+ | Mc.S_Mult (w1,w2) | Mc.S_Add(w1,w2) -> xtags (xtags tgs w1) w2
+ | _ -> tgs in
+ xtags tgs wit
+
+let tags_of_cnf wits cnf =
+ List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl)
+ Names.Idset.empty wits cnf
+
+
+let find_witness prover polys1 =
+ let l = CoqToCaml.list (fun x -> x) polys1 in
+ try_any prover l
+
+let rec witness prover l1 l2 =
+ match l2 with
+ | Micromega.Nil -> Some (Micromega.Nil)
+ | Micromega.Cons(e,l2) ->
+ match find_witness prover (Micromega.Cons( e,l1)) with
+ | None -> None
+ | Some w ->
+ (match witness prover l1 l2 with
+ | None -> None
+ | Some l -> Some (Micromega.Cons (w,l))
+ )
+
+
+let rec apply_ids t ids =
+ match ids with
+ | [] -> t
+ | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids
+
+
+let coq_Node = lazy
+ (Coqlib.gen_constant_in_modules "VarMap"
+ [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node")
+let coq_Leaf = lazy
+ (Coqlib.gen_constant_in_modules "VarMap"
+ [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf")
+let coq_Empty = lazy
+ (Coqlib.gen_constant_in_modules "VarMap"
+ [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty")
+
+
+let btree_of_array typ a =
+ let size_of_a = Array.length a in
+ let semi_size_of_a = size_of_a lsr 1 in
+ let node = Lazy.force coq_Node
+ and leaf = Lazy.force coq_Leaf
+ and empty = Term.mkApp (Lazy.force coq_Empty, [| typ |]) in
+ let rec aux n =
+ if n > size_of_a
+ then empty
+ else if n > semi_size_of_a
+ then Term.mkApp (leaf, [| typ; a.(n-1) |])
+ else Term.mkApp (node, [| typ; aux (2*n); a.(n-1); aux (2*n+1) |])
+ in
+ aux 1
+
+let btree_of_array typ a =
+ try
+ btree_of_array typ a
+ with x ->
+ failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x))
+
+let dump_varmap typ env =
+ btree_of_array typ (Array.of_list env)
+
+
+let rec pp_varmap o vm =
+ match vm with
+ | Mc.Empty -> output_string o "[]"
+ | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z
+ | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l pp_z z pp_varmap r
+
+
+
+let rec dump_proof_term = function
+ | Micromega.RatProof cone ->
+ Term.mkApp(Lazy.force coq_ratProof, [|dump_cone coq_Z dump_z cone|])
+ | Micromega.CutProof(e,q,cone,prf) ->
+ Term.mkApp(Lazy.force coq_cutProof,
+ [| dump_expr (Lazy.force coq_Z) dump_z e ;
+ dump_q q ;
+ dump_cone coq_Z dump_z cone ;
+ dump_proof_term prf|])
+ | Micromega.EnumProof( q1,e1,q2,c1,c2,prfs) ->
+ Term.mkApp (Lazy.force coq_enumProof,
+ [| dump_q q1 ; dump_expr (Lazy.force coq_Z) dump_z e1 ; dump_q q2;
+ dump_cone coq_Z dump_z c1 ; dump_cone coq_Z dump_z c2 ;
+ dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |])
+
+let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden
+
+
+let rec pp_proof_term o = function
+ | Micromega.RatProof cone -> Printf.fprintf o "R[%a]" (pp_cone pp_z) cone
+ | Micromega.CutProof(e,q,_,p) -> failwith "not implemented"
+ | Micromega.EnumProof(q1,e1,q2,c1,c2,rst) ->
+ Printf.fprintf o "EP[%a,%a,%a,%a,%a,%a]"
+ pp_q q1 pp_expr e1 pp_q q2 (pp_cone pp_z) c1 (pp_cone pp_z) c2
+ (pp_list "[" "]" pp_proof_term) rst
+
+let rec parse_hyps parse_arith env hyps =
+ match hyps with
+ | [] -> ([],env)
+ | (i,t)::l ->
+ let (lhyps,env) = parse_hyps parse_arith env l in
+ try
+ let (c,env) = parse_formula parse_arith env t in
+ ((i,c)::lhyps, env)
+ with _ -> (lhyps,env)
+ (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
+
+
+exception ParseError
+
+let parse_goal parse_arith env hyps term =
+ (* try*)
+ let (f,env) = parse_formula parse_arith env term in
+ let (lhyps,env) = parse_hyps parse_arith env hyps in
+ (lhyps,f,env)
+ (* with Failure x -> raise ParseError*)
+
+
+type ('a, 'b) domain_spec = {
+ typ : Term.constr; (* Z, Q , R *)
+ coeff : Term.constr ; (* Z, Q *)
+ dump_coeff : 'a -> Term.constr ;
+ proof_typ : Term.constr ;
+ dump_proof : 'b -> Term.constr
+}
+
+let zz_domain_spec = lazy {
+ typ = Lazy.force coq_Z;
+ coeff = Lazy.force coq_Z;
+ dump_coeff = dump_z ;
+ proof_typ = Lazy.force coq_proofTerm ;
+ dump_proof = dump_proof_term
+}
+
+let qq_domain_spec = lazy {
+ typ = Lazy.force coq_Q;
+ coeff = Lazy.force coq_Q;
+ dump_coeff = dump_q ;
+ proof_typ = Lazy.force coq_QWitness ;
+ dump_proof = dump_cone coq_Q dump_q
+}
+
+let rz_domain_spec = lazy {
+ typ = Lazy.force coq_R;
+ coeff = Lazy.force coq_Z;
+ dump_coeff = dump_z;
+ proof_typ = Lazy.force coq_ZWitness ;
+ dump_proof = dump_cone coq_Z dump_z
+}
+
+
+
+
+let micromega_order_change spec cert cert_typ env ff gl =
+ let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in
+
+ let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in
+ let vm = dump_varmap ( spec.typ) env in
+ Tactics.change_in_concl None
+ (set
+ [
+ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula ,[| formula_typ |]));
+ ("__varmap", vm , Term.mkApp
+ (Coqlib.gen_constant_in_modules "VarMap"
+ [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "t", [| spec.typ|]));
+ ("__wit", cert,cert_typ)
+ ]
+ (Tacmach.pf_concl gl )
+
+ )
+ gl
+
+
+let detect_duplicates cnf wit =
+ let cnf = CoqToCaml.list (fun x -> x) cnf in
+ let wit = CoqToCaml.list (fun x -> x) wit in
+
+ let rec xdup cnf wit =
+ match wit with
+ | [] -> []
+ | w :: wit ->
+ let sg = sig_of_cone w in
+ match cnf with
+ | [] -> []
+ | e::cnf ->
+ let (dups,cnf) = (List.partition (fun x -> same_proof sg e x) cnf) in
+ dups@(xdup cnf wit) in
+ xdup cnf wit
+
+let find_witness prover polys1 =
+ try_any prover polys1
+
+
+let witness_list_with_tags prover l =
+
+ let rec xwitness_list l =
+ match l with
+ | [] -> Some([])
+ | e::l ->
+ match find_witness prover (List.map fst e) with
+ | None -> None
+ | Some w ->
+ (match xwitness_list l with
+ | None -> None
+ | Some l -> Some (w::l)
+ ) in
+ xwitness_list l
+
+let witness_list_without_tags prover l =
+
+ let rec xwitness_list l =
+ match l with
+ | [] -> Some([])
+ | e::l ->
+ match find_witness prover e with
+ | None -> None
+ | Some w ->
+ (match xwitness_list l with
+ | None -> None
+ | Some l -> Some (w::l)
+ ) in
+ xwitness_list l
+
+let witness_list prover l =
+ let rec xwitness_list l =
+ match l with
+ | Micromega.Nil -> Some(Micromega.Nil)
+ | Micromega.Cons(e,l) ->
+ match find_witness prover e with
+ | None -> None
+ | Some w ->
+ (match xwitness_list l with
+ | None -> None
+ | Some l -> Some (Micromega.Cons(w,l))
+ ) in
+ xwitness_list l
+
+
+
+
+let is_singleton = function [] -> true | [e] -> true | _ -> false
+
+
+let micromega_tauto negate normalise spec prover env polys1 polys2 gl =
+ let spec = Lazy.force spec in
+ let (ff,ids) =
+ List.fold_right
+ (fun (id,f) (cc,ids) ->
+ match f with
+ X _ -> (cc,ids)
+ | _ -> (I(tag_formula (Names.Name id) f,cc,none), id::ids))
+ polys1 (polys2,[]) in
+
+ let cnf_ff = cnf negate normalise ff in
+
+ if debug then
+ (Pp.pp (Pp.str "Formula....\n") ;
+ let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in
+ let ff = dump_formula formula_typ
+ (dump_cstr spec.typ spec.dump_coeff) ff in
+ Pp.pp (Printer.prterm ff) ; Pp.pp_flush ()) ;
+
+ match witness_list_without_tags prover cnf_ff with
+ | None -> Tacticals.tclFAIL 0 (Pp.str "Cannot find witness") gl
+ | Some res -> (*Printf.printf "\nList %i" (List.length res); *)
+ let (ff,res,ids) = (ff,res,List.map Term.mkVar ids) in
+ let res' = dump_ml_list (spec.proof_typ) spec.dump_proof res in
+ (Tacticals.tclTHENSEQ
+ [
+ Tactics.generalize ids;
+ micromega_order_change spec res'
+ (Term.mkApp(Lazy.force coq_list,[| spec.proof_typ|])) env ff ;
+ ]) gl
+
+
+let micromega_gen parse_arith negate normalise spec prover gl =
+ let concl = Tacmach.pf_concl gl in
+ let hyps = Tacmach.pf_hyps_types gl in
+ try
+ let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in
+ let env = Env.elements env in
+ micromega_tauto negate normalise spec prover env hyps concl gl
+ with
+ | Failure x -> flush stdout ; Pp.pp_flush () ;
+ Tacticals.tclFAIL 0 (Pp.str x) gl
+ | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
+
+
+let lift_ratproof prover l =
+ match prover l with
+ | None -> None
+ | Some c -> Some (Mc.RatProof c)
+
+
+type csdpcert = Certificate.Mc.z Certificate.Mc.coneMember option
+type micromega_polys = (Micromega.z Mc.pExpr, Mc.op1) Micromega.prod list
+type provername = string * int option
+
+let call_csdpcert provername poly =
+ let tmp_to,ch_to = Filename.open_temp_file "csdpcert" ".in" in
+ let tmp_from = Filename.temp_file "csdpcert" ".out" in
+ output_value ch_to (provername,poly : provername * micromega_polys);
+ close_out ch_to;
+ let cmdname =
+ Filename.concat Coq_config.bindir
+ ("csdpcert" ^ Coq_config.exec_extension) in
+ let c = Sys.command (cmdname ^" "^ tmp_to ^" "^ tmp_from) in
+ (try Sys.remove tmp_to with _ -> ());
+ if c <> 0 then Util.error ("Failed to call csdp certificate generator");
+ let ch_from = open_in tmp_from in
+ let cert = (input_value ch_from : csdpcert) in
+ close_in ch_from; Sys.remove tmp_from;
+ cert
+
+let omicron gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
+ [lift_ratproof
+ (Certificate.linear_prover Certificate.z_spec), "fourier refutation" ] gl
+
+
+let qomicron gl =
+ micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec
+ [ Certificate.linear_prover Certificate.q_spec, "fourier refutation" ] gl
+
+let romicron gl =
+ micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec
+ [ Certificate.linear_prover Certificate.z_spec, "fourier refutation" ] gl
+
+
+let rmicromega i gl =
+ micromega_gen parse_rarith Mc.negate Mc.normalise rz_domain_spec
+ [ call_csdpcert ("real_nonlinear_prover", Some i), "fourier refutation" ] gl
+
+
+let micromega i gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
+ [lift_ratproof (call_csdpcert ("real_nonlinear_prover",Some i)),
+ "fourier refutation" ] gl
+
+
+let sos gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
+ [lift_ratproof (call_csdpcert ("pure_sos", None)), "pure sos refutation"] gl
+
+let zomicron gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
+ [Certificate.zlinear_prover, "zprover"] gl
diff --git a/contrib/micromega/csdpcert.ml b/contrib/micromega/csdpcert.ml
new file mode 100644
index 00000000..cfaf6ae1
--- /dev/null
+++ b/contrib/micromega/csdpcert.ml
@@ -0,0 +1,333 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+open Big_int
+open Num
+open Sos
+
+module Mc = Micromega
+module Ml2C = Mutils.CamlToCoq
+module C2Ml = Mutils.CoqToCaml
+
+let debug = false
+
+module M =
+struct
+ open Mc
+
+ let rec expr_to_term = function
+ | PEc z -> Const (Big_int (C2Ml.z_big_int z))
+ | PEX v -> Var ("x"^(string_of_int (C2Ml.index v)))
+ | PEmul(p1,p2) ->
+ let p1 = expr_to_term p1 in
+ let p2 = expr_to_term p2 in
+ let res = Mul(p1,p2) in res
+
+ | PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2)
+ | PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2)
+ | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n)
+ | PEopp p -> Opp (expr_to_term p)
+
+
+ let rec term_to_expr = function
+ | Const n -> PEc (Ml2C.bigint (big_int_of_num n))
+ | Zero -> PEc ( Z0)
+ | Var s -> PEX (Ml2C.index
+ (int_of_string (String.sub s 1 (String.length s - 1))))
+ | Mul(p1,p2) -> PEmul(term_to_expr p1, term_to_expr p2)
+ | Add(p1,p2) -> PEadd(term_to_expr p1, term_to_expr p2)
+ | Opp p -> PEopp (term_to_expr p)
+ | Pow(t,n) -> PEpow (term_to_expr t,Ml2C.n n)
+ | Sub(t1,t2) -> PEsub (term_to_expr t1, term_to_expr t2)
+ | _ -> failwith "term_to_expr: not implemented"
+
+ let term_to_expr e =
+ let e' = term_to_expr e in
+ if debug
+ then Printf.printf "term_to_expr : %s - %s\n"
+ (string_of_poly (poly_of_term e))
+ (string_of_poly (poly_of_term (expr_to_term e')));
+ e'
+
+end
+open M
+
+open List
+open Mutils
+
+let rec scale_term t =
+ match t with
+ | Zero -> unit_big_int , Zero
+ | Const n -> (denominator n) , Const (Big_int (numerator n))
+ | Var n -> unit_big_int , Var n
+ | Inv _ -> failwith "scale_term : not implemented"
+ | Opp t -> let s, t = scale_term t in s, Opp t
+ | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in
+ let g = gcd_big_int s1 s2 in
+ let s1' = div_big_int s1 g in
+ let s2' = div_big_int s2 g in
+ let e = mult_big_int g (mult_big_int s1' s2') in
+ if (compare_big_int e unit_big_int) = 0
+ then (unit_big_int, Add (y1,y2))
+ else e, Add (Mul(Const (Big_int s2'), y1),
+ Mul (Const (Big_int s1'), y2))
+ | Sub _ -> failwith "scale term: not implemented"
+ | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in
+ mult_big_int s1 s2 , Mul (y1, y2)
+ | Pow(t,n) -> let s,t = scale_term t in
+ power_big_int_positive_int s n , Pow(t,n)
+ | _ -> failwith "scale_term : not implemented"
+
+let scale_term t =
+ let (s,t') = scale_term t in
+ s,t'
+
+
+
+
+let rec scale_certificate pos = match pos with
+ | Axiom_eq i -> unit_big_int , Axiom_eq i
+ | Axiom_le i -> unit_big_int , Axiom_le i
+ | Axiom_lt i -> unit_big_int , Axiom_lt i
+ | Monoid l -> unit_big_int , Monoid l
+ | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n))
+ | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n))
+ | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n))
+ | Square t -> let s,t' = scale_term t in
+ mult_big_int s s , Square t'
+ | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in
+ mult_big_int s1 s2 , Eqmul (y1,y2)
+ | Sum (y, z) -> let s1,y1 = scale_certificate y
+ and s2,y2 = scale_certificate z in
+ let g = gcd_big_int s1 s2 in
+ let s1' = div_big_int s1 g in
+ let s2' = div_big_int s2 g in
+ mult_big_int g (mult_big_int s1' s2'),
+ Sum (Product(Rational_le (Big_int s2'), y1),
+ Product (Rational_le (Big_int s1'), y2))
+ | Product (y, z) ->
+ let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in
+ mult_big_int s1 s2 , Product (y1,y2)
+
+
+let is_eq = function Mc.Equal -> true | _ -> false
+let is_le = function Mc.NonStrict -> true | _ -> false
+let is_lt = function Mc.Strict -> true | _ -> false
+
+let get_index_of_ith_match f i l =
+ let rec get j res l =
+ match l with
+ | [] -> failwith "bad index"
+ | e::l -> if f e
+ then
+ (if j = i then res else get (j+1) (res+1) l )
+ else get j (res+1) l in
+ get 0 0 l
+
+
+let cert_of_pos eq le lt ll l pos =
+ let s,pos = (scale_certificate pos) in
+ let rec _cert_of_pos = function
+ Axiom_eq i -> let idx = get_index_of_ith_match is_eq i l in
+ Mc.S_In (Ml2C.nat idx)
+ | Axiom_le i -> let idx = get_index_of_ith_match is_le i l in
+ Mc.S_In (Ml2C.nat idx)
+ | Axiom_lt i -> let idx = get_index_of_ith_match is_lt i l in
+ Mc.S_In (Ml2C.nat idx)
+ | Monoid l -> Mc.S_Monoid (Ml2C.list Ml2C.nat l)
+ | Rational_eq n | Rational_le n | Rational_lt n ->
+ if compare_num n (Int 0) = 0 then Mc.S_Z else
+ Mc.S_Pos (Ml2C.bigint (big_int_of_num n))
+ | Square t -> Mc.S_Square (term_to_expr t)
+ | Eqmul (t, y) -> Mc.S_Ideal(term_to_expr t, _cert_of_pos y)
+ | Sum (y, z) -> Mc.S_Add (_cert_of_pos y, _cert_of_pos z)
+ | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in
+ s, Certificate.simplify_cone Certificate.z_spec (_cert_of_pos pos)
+
+
+let term_of_cert l pos =
+ let l = List.map fst' l in
+ let rec _cert_of_pos = function
+ | Mc.S_In i -> expr_to_term (List.nth l (C2Ml.nat i))
+ | Mc.S_Pos p -> Const (C2Ml.num p)
+ | Mc.S_Z -> Const (Int 0)
+ | Mc.S_Square t -> Mul(expr_to_term t, expr_to_term t)
+ | Mc.S_Monoid m -> List.fold_right
+ (fun x m -> Mul (expr_to_term (List.nth l (C2Ml.nat x)),m))
+ (C2Ml.list (fun x -> x) m) (Const (Int 1))
+ | Mc.S_Ideal (t, y) -> Mul(expr_to_term t, _cert_of_pos y)
+ | Mc.S_Add (y, z) -> Add (_cert_of_pos y, _cert_of_pos z)
+ | Mc.S_Mult (y, z) -> Mul (_cert_of_pos y, _cert_of_pos z) in
+ (_cert_of_pos pos)
+
+let rec canonical_sum_to_string = function s -> failwith "not implemented"
+
+let print_canonical_sum m = Format.print_string (canonical_sum_to_string m)
+
+let print_list_term l =
+ print_string "print_list_term\n";
+ List.iter (fun (Mc.Pair(e,k)) -> Printf.printf "q: %s %s ;"
+ (string_of_poly (poly_of_term (expr_to_term e)))
+ (match k with
+ Mc.Equal -> "= "
+ | Mc.Strict -> "> "
+ | Mc.NonStrict -> ">= "
+ | _ -> failwith "not_implemented")) l ;
+ print_string "\n"
+
+
+let partition_expr l =
+ let rec f i = function
+ | [] -> ([],[],[])
+ | Mc.Pair(e,k)::l ->
+ let (eq,ge,neq) = f (i+1) l in
+ match k with
+ | Mc.Equal -> ((e,i)::eq,ge,neq)
+ | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq)
+ | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *)
+ (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq)
+ | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq)
+ (* Not quite sure -- Coq interface has changed *)
+ in f 0 l
+
+
+let rec sets_of_list l =
+ match l with
+ | [] -> [[]]
+ | e::l -> let s = sets_of_list l in
+ s@(List.map (fun s0 -> e::s0) s)
+
+let cert_of_pos pos =
+ let s,pos = (scale_certificate pos) in
+ let rec _cert_of_pos = function
+ Axiom_eq i -> Mc.S_In (Ml2C.nat i)
+ | Axiom_le i -> Mc.S_In (Ml2C.nat i)
+ | Axiom_lt i -> Mc.S_In (Ml2C.nat i)
+ | Monoid l -> Mc.S_Monoid (Ml2C.list Ml2C.nat l)
+ | Rational_eq n | Rational_le n | Rational_lt n ->
+ if compare_num n (Int 0) = 0 then Mc.S_Z else
+ Mc.S_Pos (Ml2C.bigint (big_int_of_num n))
+ | Square t -> Mc.S_Square (term_to_expr t)
+ | Eqmul (t, y) -> Mc.S_Ideal(term_to_expr t, _cert_of_pos y)
+ | Sum (y, z) -> Mc.S_Add (_cert_of_pos y, _cert_of_pos z)
+ | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in
+ s, Certificate.simplify_cone Certificate.z_spec (_cert_of_pos pos)
+
+(* The exploration is probably not complete - for simple cases, it works... *)
+let real_nonlinear_prover d l =
+ try
+ let (eq,ge,neq) = partition_expr l in
+
+ let rec elim_const = function
+ [] -> []
+ | (x,y)::l -> let p = poly_of_term (expr_to_term x) in
+ if poly_isconst p
+ then elim_const l
+ else (p,y)::(elim_const l) in
+
+ let eq = elim_const eq in
+ let peq = List.map fst eq in
+
+ let pge = List.map
+ (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in
+
+ let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y ->
+ let p = poly_of_term (expr_to_term p) in
+ match kd with
+ | Axiom_lt i -> poly_mul p y
+ | Axiom_eq i -> poly_mul (poly_pow p 2) y
+ | _ -> failwith "monoids") m (poly_const (Int 1)) , map snd m))
+ (sets_of_list neq) in
+
+ let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d ->
+ list_try_find (fun m -> let (ci,cc) =
+ real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in
+ (ci,cc,snd m)) monoids) 0 in
+
+ let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i))
+ cert_ideal (List.map snd eq) in
+
+ let proofs_cone = map term_of_sos cert_cone in
+
+ let proof_ne =
+ let (neq , lt) = List.partition
+ (function Axiom_eq _ -> true | _ -> false ) monoid in
+ let sq = match
+ (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq)
+ with
+ | [] -> Rational_lt (Int 1)
+ | l -> Monoid l in
+ List.fold_right (fun x y -> Product(x,y)) lt sq in
+
+ let proof = list_fold_right_elements
+ (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in
+
+ let s,proof' = scale_certificate proof in
+ let cert = snd (cert_of_pos proof') in
+ if debug
+ then Printf.printf "cert poly : %s\n"
+ (string_of_poly (poly_of_term (term_of_cert l cert)));
+ match Mc.zWeakChecker (Ml2C.list (fun x -> x) l) cert with
+ | Mc.True -> Some cert
+ | Mc.False -> (print_string "buggy certificate" ; flush stdout) ;None
+ with
+ | Sos.TooDeep -> None
+
+
+(* This is somewhat buggy, over Z, strict inequality vanish... *)
+let pure_sos l =
+ (* If there is no strict inequality,
+ I should nonetheless be able to try something - over Z > is equivalent to -1 >= *)
+ try
+ let l = List.combine l (interval 0 (length l -1)) in
+ let (lt,i) = try (List.find (fun (x,_) -> snd' x = Mc.Strict) l)
+ with Not_found -> List.hd l in
+ let plt = poly_neg (poly_of_term (expr_to_term (fst' lt))) in
+ let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *)
+ let pos = Product (Rational_lt n,
+ List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square
+ (term_of_poly p)), rst))
+ polys (Rational_lt (Int 0))) in
+ let proof = Sum(Axiom_lt i, pos) in
+ let s,proof' = scale_certificate proof in
+ let cert = snd (cert_of_pos proof') in
+ Some cert
+ with
+ | Not_found -> (* This is no strict inequality *) None
+ | x -> None
+
+
+type micromega_polys = (Micromega.z Mc.pExpr, Mc.op1) Micromega.prod list
+type csdp_certificate = Certificate.Mc.z Certificate.Mc.coneMember option
+type provername = string * int option
+
+let main () =
+ if Array.length Sys.argv <> 3 then
+ (Printf.printf "Usage: csdpcert inputfile outputfile\n"; exit 1);
+ let input_file = Sys.argv.(1) in
+ let output_file = Sys.argv.(2) in
+ let inch = open_in input_file in
+ let (prover,poly) = (input_value inch : provername * micromega_polys) in
+ close_in inch;
+ let cert =
+ match prover with
+ | "real_nonlinear_prover", Some d -> real_nonlinear_prover d poly
+ | "pure_sos", None -> pure_sos poly
+ | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) in
+ let outch = open_out output_file in
+ output_value outch (cert:csdp_certificate);
+ close_out outch;
+ exit 0;;
+
+let _ = main () in ()
diff --git a/contrib/micromega/g_micromega.ml4 b/contrib/micromega/g_micromega.ml4
new file mode 100644
index 00000000..259b5d4b
--- /dev/null
+++ b/contrib/micromega/g_micromega.ml4
@@ -0,0 +1,59 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: g_micromega.ml4 10947 2008-05-19 19:10:40Z herbelin $ *)
+
+open Quote
+open Ring
+open Mutils
+open Rawterm
+open Util
+
+let out_arg = function
+ | ArgVar _ -> anomaly "Unevaluated or_var variable"
+ | ArgArg x -> x
+
+TACTIC EXTEND Micromega
+| [ "micromegap" int_or_var(i) ] -> [ Coq_micromega.micromega (out_arg i) ]
+| [ "micromegap" ] -> [ Coq_micromega.micromega (-1) ]
+END
+
+TACTIC EXTEND Sos
+[ "sosp" ] -> [ Coq_micromega.sos]
+END
+
+
+TACTIC EXTEND Omicron
+[ "omicronp" ] -> [ Coq_micromega.omicron]
+END
+
+TACTIC EXTEND QOmicron
+[ "qomicronp" ] -> [ Coq_micromega.qomicron]
+END
+
+
+TACTIC EXTEND ZOmicron
+[ "zomicronp" ] -> [ Coq_micromega.zomicron]
+END
+
+TACTIC EXTEND ROmicron
+[ "romicronp" ] -> [ Coq_micromega.romicron]
+END
+
+TACTIC EXTEND RMicromega
+| [ "rmicromegap" int_or_var(i) ] -> [ Coq_micromega.rmicromega (out_arg i) ]
+| [ "rmicromegap" ] -> [ Coq_micromega.rmicromega (-1) ]
+END
diff --git a/contrib/micromega/mfourier.ml b/contrib/micromega/mfourier.ml
new file mode 100644
index 00000000..415d3a3e
--- /dev/null
+++ b/contrib/micromega/mfourier.ml
@@ -0,0 +1,667 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+(* Yet another implementation of Fourier *)
+open Num
+
+module Cmp =
+ (* How to compare pairs, lists ... *)
+struct
+ let rec compare_lexical l =
+ match l with
+ | [] -> 0 (* Equal *)
+ | f::l ->
+ let cmp = f () in
+ if cmp = 0 then compare_lexical l else cmp
+
+ let rec compare_list cmp l1 l2 =
+ match l1 , l2 with
+ | [] , [] -> 0
+ | [] , _ -> -1
+ | _ , [] -> 1
+ | e1::l1 , e2::l2 ->
+ let c = cmp e1 e2 in
+ if c = 0 then compare_list cmp l1 l2 else c
+
+ let hash_list hash l =
+ let rec xhash res l =
+ match l with
+ | [] -> res
+ | e::l -> xhash ((hash e) lxor res) l in
+ xhash (Hashtbl.hash []) l
+
+end
+
+module Interval =
+struct
+ (** The type of intervals. **)
+ type intrvl = Empty | Point of num | Itv of num option * num option
+
+ (**
+ Different intervals can denote the same set of variables e.g.,
+ Point n && Itv (Some n, Some n)
+ Itv (Some x) (Some y) && Empty if x > y
+ see the 'belongs_to' function.
+ **)
+
+ (* The set of numerics that belong to an interval *)
+ let belongs_to n = function
+ | Empty -> false
+ | Point x -> n =/ x
+ | Itv(Some x, Some y) -> x <=/ n && n <=/ y
+ | Itv(None,Some y) -> n <=/ y
+ | Itv(Some x,None) -> x <=/ n
+ | Itv(None,None) -> true
+
+ let string_of_bound = function
+ | None -> "oo"
+ | Some n -> Printf.sprintf "Bd(%s)" (string_of_num n)
+
+ let string_of_intrvl = function
+ | Empty -> "[]"
+ | Point n -> Printf.sprintf "[%s]" (string_of_num n)
+ | Itv(bd1,bd2) ->
+ Printf.sprintf "[%s,%s]" (string_of_bound bd1) (string_of_bound bd2)
+
+ let pick_closed_to_zero = function
+ | Empty -> None
+ | Point n -> Some n
+ | Itv(None,None) -> Some (Int 0)
+ | Itv(None,Some i) ->
+ Some (if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i)
+ | Itv(Some i,None) ->
+ Some (if i <=/ (Int 0) then Int 0 else ceiling_num i)
+ | Itv(Some i,Some j) ->
+ Some (
+ if i <=/ Int 0 && Int 0 <=/ j
+ then Int 0
+ else if ceiling_num i <=/ floor_num j
+ then ceiling_num i (* why not *) else i)
+
+ type status =
+ | O | Qonly | Z | Q
+
+ let interval_kind = function
+ | Empty -> O
+ | Point n -> if ceiling_num n =/ n then Z else Qonly
+ | Itv(None,None) -> Z
+ | Itv(None,Some i) -> if ceiling_num i <>/ i then Q else Z
+ | Itv(Some i,None) -> if ceiling_num i <>/ i then Q else Z
+ | Itv(Some i,Some j) ->
+ if ceiling_num i <>/ i or floor_num j <>/ j then Q else Z
+
+ let empty_z = function
+ | Empty -> true
+ | Point n -> ceiling_num n <>/ n
+ | Itv(None,None) | Itv(None,Some _) | Itv(Some _,None) -> false
+ | Itv(Some i,Some j) -> ceiling_num i >/ floor_num j
+
+
+ let normalise b1 b2 =
+ match b1 , b2 with
+ | Some i , Some j ->
+ (match compare_num i j with
+ | 1 -> Empty
+ | 0 -> Point i
+ | _ -> Itv(b1,b2)
+ )
+ | _ -> Itv(b1,b2)
+
+
+
+ let min x y =
+ match x , y with
+ | None , x | x , None -> x
+ | Some i , Some j -> Some (min_num i j)
+
+ let max x y =
+ match x , y with
+ | None , x | x , None -> x
+ | Some i , Some j -> Some (max_num i j)
+
+ let inter i1 i2 =
+ match i1,i2 with
+ | Empty , _ -> Empty
+ | _ , Empty -> Empty
+ | Point n , Point m -> if n =/ m then i1 else Empty
+ | Point n , Itv (mn,mx) | Itv (mn,mx) , Point n->
+ if (match mn with
+ | None -> true
+ | Some mn -> mn <=/ n) &&
+ (match mx with
+ | None -> true
+ | Some mx -> n <=/ mx) then Point n else Empty
+ | Itv (min1,max1) , Itv (min2,max2) ->
+ let bmin = max min1 min2
+ and bmax = min max1 max2 in
+ normalise bmin bmax
+
+ (* a.x >= b*)
+ let bound_of_constraint (a,b) =
+ match compare_num a (Int 0) with
+ | 0 ->
+ if compare_num b (Int 0) = 1
+ then Empty
+ (*actually this is a contradiction failwith "bound_of_constraint" *)
+ else Itv (None,None)
+ | 1 -> Itv (Some (div_num b a),None)
+ | -1 -> Itv (None, Some (div_num b a))
+ | x -> failwith "bound_of_constraint(2)"
+
+
+ let bounded x =
+ match x with
+ | Itv(None,_) | Itv(_,None) -> false
+ | _ -> true
+
+
+ let range = function
+ | Empty -> Some (Int 0)
+ | Point n -> Some (Int (if ceiling_num n =/ n then 1 else 0))
+ | Itv(None,_) | Itv(_,None)-> None
+ | Itv(Some i,Some j) -> Some (floor_num j -/ceiling_num i +/ (Int 1))
+
+ (* Returns the interval of smallest range *)
+ let smaller_itv i1 i2 =
+ match range i1 , range i2 with
+ | None , _ -> false
+ | _ , None -> true
+ | Some i , Some j -> i <=/ j
+
+end
+open Interval
+
+(* A set of constraints *)
+module Sys(V:Vector.S) (* : Vector.SystemS with module Vect = V*) =
+struct
+
+ module Vect = V
+
+ module Cstr = Vector.Cstr(V)
+ open Cstr
+
+
+ module CMap = Map.Make(
+ struct
+ type t = Vect.t
+ let compare = Vect.compare
+ end)
+
+ module CstrBag =
+ struct
+
+ type mut_itv = { mutable itv : intrvl}
+
+ type t = mut_itv CMap.t
+
+ exception Contradiction
+
+ let cstr_to_itv cstr =
+ let (n,l) = V.normalise cstr.coeffs in
+ if n =/ (Int 0)
+ then (Vect.null, bound_of_constraint (Int 0,cstr.cst)) (* Might be empty *)
+ else
+ match cstr.op with
+ | Eq -> let n = cstr.cst // n in (l, Point n)
+ | Ge ->
+ match compare_num n (Int 0) with
+ | 0 -> failwith "intrvl_of_constraint"
+ | 1 -> (l,Itv (Some (cstr.cst // n), None))
+ | -1 -> (l, Itv(None,Some (cstr.cst // n)))
+ | _ -> failwith "cstr_to_itv"
+
+
+ let empty = CMap.empty
+
+
+
+
+ let is_empty = CMap.is_empty
+
+ let find_vect v bag =
+ try
+ (bag,CMap.find v bag)
+ with Not_found -> let x = { itv = Itv(None,None)} in (CMap.add v x bag ,x)
+
+
+ let add (v,b) bag =
+ match b with
+ | Empty -> raise Contradiction
+ | Itv(None,None) -> bag
+ | _ ->
+ let (bag,intrl) = find_vect v bag in
+ match inter b intrl.itv with
+ | Empty -> raise Contradiction
+ | itv -> intrl.itv <- itv ; bag
+
+ exception Found of cstr
+
+ let find_equation bag =
+ try
+ CMap.fold (fun v i () ->
+ match i.itv with
+ | Point n -> let e = {coeffs = v ; op = Eq ; cst = n}
+ in raise (Found e)
+ | _ -> () ) bag () ; None
+ with Found c -> Some c
+
+
+ let fold f bag acc =
+ CMap.fold (fun v itv acc ->
+ match itv.itv with
+ | Empty | Itv(None,None) -> failwith "fold Empty"
+ | Itv(None ,Some i) ->
+ f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc
+ | Point n -> f {coeffs = v ; op = Eq ; cst = n} acc
+ | Itv(x,y) ->
+ (match x with
+ | None -> (fun x -> x)
+ | Some i -> f {coeffs = v ; op = Ge ; cst = i})
+ (match y with
+ | None -> acc
+ | Some i ->
+ f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc
+ ) ) bag acc
+
+
+ let remove l _ = failwith "remove:Not implemented"
+
+ module Map =
+ Map.Make(
+ struct
+ type t = int
+ let compare : int -> int -> int = Pervasives.compare
+ end)
+
+ let split f (t:t) =
+ let res =
+ fold (fun e m -> let i = f e in
+ Map.add i (add (cstr_to_itv e)
+ (try Map.find i m with
+ Not_found -> empty)) m) t Map.empty in
+ (fun i -> try Map.find i res with Not_found -> empty)
+
+ type map = (int list * int list) Map.t
+
+
+ let status (b:t) =
+ let _ , map = fold (fun c ( (idx:int),(res: map)) ->
+ ( idx + 1,
+ List.fold_left (fun (res:map) (pos,s) ->
+ let (lp,ln) = try Map.find pos res with Not_found -> ([],[]) in
+ match s with
+ | Vect.Pos -> Map.add pos (idx::lp,ln) res
+ | Vect.Neg ->
+ Map.add pos (lp, idx::ln) res) res
+ (Vect.status c.coeffs))) b (0,Map.empty) in
+ Map.fold (fun k e res -> (k,e)::res) map []
+
+
+ type it = num CMap.t
+
+ let iterator x = x
+
+ let element it = failwith "element:Not implemented"
+
+ end
+end
+
+module Fourier(Vect : Vector.S) =
+struct
+ module Vect = Vect
+ module Sys = Sys( Vect)
+ module Cstr = Sys.Cstr
+ module Bag = Sys.CstrBag
+
+ open Cstr
+ open Sys
+
+ let debug = false
+
+ let print_bag msg b =
+ print_endline msg;
+ CstrBag.fold (fun e () -> print_endline (Cstr.string_of_cstr e)) b ()
+
+ let print_bag_file file msg b =
+ let f = open_out file in
+ output_string f msg;
+ CstrBag.fold (fun e () ->
+ Printf.fprintf f "%s\n" (Cstr.string_of_cstr e)) b ()
+
+
+ (* A system with only inequations --
+ *)
+ let partition i m =
+ let splitter cstr = compare_num (Vect.get i cstr.coeffs ) (Int 0) in
+ let split = CstrBag.split splitter m in
+ (split (-1) , split 0, split 1)
+
+
+ (* op of the result is arbitrary Ge *)
+ let lin_comb n1 c1 n2 c2 =
+ { coeffs = Vect.lin_comb n1 c1.coeffs n2 c2.coeffs ;
+ op = Ge ;
+ cst = (n1 */ c1.cst) +/ (n2 */ c2.cst)}
+
+ (* BUG? : operator of the result ? *)
+
+ let combine_project i c1 c2 =
+ let p = Vect.get i c1.coeffs
+ and n = Vect.get i c2.coeffs in
+ assert (n </ Int 0 && p >/ Int 0) ;
+ let nopp = minus_num n in
+ let c =lin_comb nopp c1 p c2 in
+ let op = if c1.op = Ge || c2.op = Ge then Ge else Eq in
+ CstrBag.cstr_to_itv {coeffs = c.coeffs ; op = op ; cst= c.cst }
+
+
+ let project i m =
+ let (neg,zero,pos) = partition i m in
+ let project1 cpos acc =
+ CstrBag.fold (fun cneg res ->
+ CstrBag.add (combine_project i cpos cneg) res) neg acc in
+ (CstrBag.fold project1 pos zero)
+
+ (* Given a vector [x1 -> v1; ... ; xn -> vn]
+ and a constraint {x1 ; .... xn >= c }
+ *)
+ let evaluate_constraint i map cstr =
+ let {coeffs = _coeffs ; op = _op ; cst = _cst} = cstr in
+ let vi = Vect.get i _coeffs in
+ let v = Vect.set i (Int 0) _coeffs in
+ (vi, _cst -/ Vect.dotp map v)
+
+
+ let rec bounds m itv =
+ match m with
+ | [] -> itv
+ | e::m -> bounds m (inter itv (bound_of_constraint e))
+
+
+
+ let compare_status (i,(lp,ln)) (i',(lp',ln')) =
+ let cmp = Pervasives.compare
+ ((List.length lp) * (List.length ln))
+ ((List.length lp') * (List.length ln')) in
+ if cmp = 0
+ then Pervasives.compare i i'
+ else cmp
+
+ let cardinal m = CstrBag.fold (fun _ x -> x + 1) m 0
+
+ let lightest_projection l c m =
+ let bound = c in
+ if debug then (Printf.printf "l%i" bound; flush stdout) ;
+ let rec xlight best l =
+ match l with
+ | [] -> best
+ | i::l ->
+ let proj = (project i m) in
+ let cproj = cardinal proj in
+ (*Printf.printf " p %i " cproj; flush stdout;*)
+ match best with
+ | None ->
+ if cproj < bound
+ then Some(cproj,proj,i)
+ else xlight (Some(cproj,proj,i)) l
+ | Some (cbest,_,_) ->
+ if cproj < cbest
+ then
+ if cproj < bound then Some(cproj,proj,i)
+ else xlight (Some(cproj,proj,i)) l
+ else xlight best l in
+ match xlight None l with
+ | None -> None
+ | Some(_,p,i) -> Some (p,i)
+
+
+
+ exception Equality of cstr
+
+ let find_equality m = Bag.find_equation m
+
+
+
+ let pivot (n,v) eq ge =
+ assert (eq.op = Eq) ;
+ let res =
+ match
+ compare_num v (Int 0),
+ compare_num (Vect.get n ge.coeffs) (Int 0)
+ with
+ | 0 , _ -> failwith "Buggy"
+ | _ ,0 -> (CstrBag.cstr_to_itv ge)
+ | 1 , -1 -> combine_project n eq ge
+ | -1 , 1 -> combine_project n ge eq
+ | 1 , 1 ->
+ combine_project n ge
+ {coeffs = Vect.mul (Int (-1)) eq.coeffs;
+ op = eq.op ;
+ cst = minus_num eq.cst}
+ | -1 , -1 ->
+ combine_project n
+ {coeffs = Vect.mul (Int (-1)) eq.coeffs;
+ op = eq.op ; cst = minus_num eq.cst} ge
+ | _ -> failwith "pivot" in
+ res
+
+ let check_cstr v c =
+ let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in
+ let vl = Vect.dotp v _coeffs in
+ match _op with
+ | Eq -> vl =/ _cst
+ | Ge -> vl >= _cst
+
+
+ let forall p sys =
+ try
+ CstrBag.fold (fun c () -> if p c then () else raise Not_found) sys (); true
+ with Not_found -> false
+
+
+ let check_sys v sys = forall (check_cstr v) sys
+
+ let check_null_cstr c =
+ let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in
+ match _op with
+ | Eq -> (Int 0) =/ _cst
+ | Ge -> (Int 0) >= _cst
+
+ let check_null sys = forall check_null_cstr sys
+
+
+ let optimise_ge
+ quick_check choose choose_idx return_empty return_ge return_eq m =
+ let c = cardinal m in
+ let bound = 2 * c in
+ if debug then (Printf.printf "optimise_ge: %i\n" c; flush stdout);
+
+ let rec xoptimise m =
+ if debug then (Printf.printf "x%i" (cardinal m) ; flush stdout);
+ if debug then (print_bag "xoptimise" m ; flush stdout);
+ if quick_check m
+ then return_empty m
+ else
+ match find_equality m with
+ | None -> xoptimise_ge m
+ | Some eq -> xoptimise_eq eq m
+
+ and xoptimise_ge m =
+ begin
+ let c = cardinal m in
+ let l = List.map fst (List.sort compare_status (CstrBag.status m)) in
+ let idx = choose bound l c m in
+ match idx with
+ | None -> return_empty m
+ | Some (proj,i) ->
+ match xoptimise proj with
+ | None -> None
+ | Some mapping -> return_ge m i mapping
+ end
+ and xoptimise_eq eq m =
+ let l = List.map fst (Vect.status eq.coeffs) in
+ match choose_idx l with
+ | None -> (*if l = [] then None else*) return_empty m
+ | Some i ->
+ let p = (i,Vect.get i eq.coeffs) in
+ let m' = CstrBag.fold
+ (fun ge res -> CstrBag.add (pivot p eq ge) res) m CstrBag.empty in
+ match xoptimise ( m') with
+ | None -> None
+ | Some mapp -> return_eq m eq i mapp in
+ try
+ let res = xoptimise m in res
+ with CstrBag.Contradiction -> (*print_string "contradiction" ;*) None
+
+
+
+ let minimise m =
+ let opt_zero_choose bound l c m =
+ if c > bound
+ then lightest_projection l c m
+ else match l with
+ | [] -> None
+ | i::_ -> Some (project i m, i) in
+
+ let choose_idx = function [] -> None | x::l -> Some x in
+
+ let opt_zero_return_empty m = Some Vect.null in
+
+
+ let opt_zero_return_ge m i mapping =
+ let (it:intrvl) = CstrBag.fold (fun cstr itv -> Interval.inter
+ (bound_of_constraint (evaluate_constraint i mapping cstr)) itv) m
+ (Itv (None, None)) in
+ match pick_closed_to_zero it with
+ | None -> print_endline "Cannot pick" ; None
+ | Some v ->
+ let res = (Vect.set i v mapping) in
+ if debug
+ then Printf.printf "xoptimise res %i [%s]" i (Vect.string res) ;
+ Some res in
+
+ let opt_zero_return_eq m eq i mapp =
+ let (a,b) = evaluate_constraint i mapp eq in
+ Some (Vect.set i (div_num b a) mapp) in
+
+ optimise_ge check_null opt_zero_choose
+ choose_idx opt_zero_return_empty opt_zero_return_ge opt_zero_return_eq m
+
+ let normalise cstr = [CstrBag.cstr_to_itv cstr]
+
+ let find_point l =
+ (* List.iter (fun e -> print_endline (Cstr.string_of_cstr e)) l;*)
+ try
+ let m = List.fold_left (fun sys e -> CstrBag.add (CstrBag.cstr_to_itv e) sys)
+ CstrBag.empty l in
+ match minimise m with
+ | None -> None
+ | Some res ->
+ if debug then Printf.printf "[%s]" (Vect.string res);
+ Some res
+ with CstrBag.Contradiction -> None
+
+
+ let find_q_interval_for x m =
+ if debug then Printf.printf "find_q_interval_for %i\n" x ;
+
+ let choose bound l c m =
+ let rec xchoose l =
+ match l with
+ | [] -> None
+ | i::l -> if i = x then xchoose l else Some (project i m,i) in
+ xchoose l in
+
+ let rec choose_idx = function
+ [] -> None
+ | e::l -> if e = x then choose_idx l else Some e in
+
+ let return_empty m = (* Beurk *)
+ (* returns the interval of x *)
+ Some (CstrBag.fold (fun cstr itv ->
+ let i = if cstr.op = Eq
+ then Point (cstr.cst // Vect.get x cstr.coeffs)
+ else if Vect.is_null (Vect.set x (Int 0) cstr.coeffs)
+ then bound_of_constraint (Vect.get x cstr.coeffs , cstr.cst)
+ else itv
+ in
+ Interval.inter i itv) m (Itv (None, None))) in
+
+ let return_ge m i res = Some res in
+
+ let return_eq m eq i res = Some res in
+
+ try
+ optimise_ge
+ (fun x -> false) choose choose_idx return_empty return_ge return_eq m
+ with CstrBag.Contradiction -> None
+
+
+ let find_q_intervals sys =
+ let variables =
+ List.map fst (List.sort compare_status (CstrBag.status sys)) in
+ List.map (fun x -> (x,find_q_interval_for x sys)) variables
+
+ let pp_option f o = function
+ None -> Printf.fprintf o "None"
+ | Some x -> Printf.fprintf o "Some %a" f x
+
+ let optimise vect sys =
+ (* we have to modify the system with a dummy variable *)
+ let fresh =
+ List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 sys in
+ assert (List.for_all (fun x -> Vect.get fresh x.coeffs =/ Int 0) sys);
+ let cstr = {
+ coeffs = Vect.set fresh (Int (-1)) vect ;
+ op = Eq ;
+ cst = (Int 0)} in
+ try
+ find_q_interval_for fresh
+ (List.fold_left
+ (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg)
+ CstrBag.empty (cstr::sys))
+ with CstrBag.Contradiction -> None
+
+
+ let optimise vect sys =
+ let res = optimise vect sys in
+ if debug
+ then Printf.printf "optimise %s -> %a\n"
+ (Vect.string vect) (pp_option (fun o x -> Printf.printf "%s" (string_of_intrvl x))) res
+ ; res
+
+ let find_Q_interval sys =
+ try
+ let sys =
+ (List.fold_left
+ (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg) CstrBag.empty sys) in
+ let candidates =
+ List.fold_left
+ (fun l (x,i) -> match i with
+ None -> (x,Empty)::l
+ | Some i -> (x,i)::l) [] (find_q_intervals sys) in
+ match List.fold_left
+ (fun (x1,i1) (x2,i2) ->
+ if smaller_itv i1 i2
+ then (x1,i1) else (x2,i2)) (-1,Itv(None,None)) candidates
+ with
+ | (i,Empty) -> None
+ | (x,Itv(Some i, Some j)) -> Some(i,x,j)
+ | (x,Point n) -> Some(n,x,n)
+ | _ -> None
+ with CstrBag.Contradiction -> None
+
+
+end
+
diff --git a/contrib/micromega/micromega.ml b/contrib/micromega/micromega.ml
new file mode 100644
index 00000000..e151e4e1
--- /dev/null
+++ b/contrib/micromega/micromega.ml
@@ -0,0 +1,1512 @@
+type __ = Obj.t
+let __ = let rec f _ = Obj.repr f in Obj.repr f
+
+type bool =
+ | True
+ | False
+
+(** val negb : bool -> bool **)
+
+let negb = function
+ | True -> False
+ | False -> True
+
+type nat =
+ | O
+ | S of nat
+
+type 'a option =
+ | Some of 'a
+ | None
+
+type ('a, 'b) prod =
+ | Pair of 'a * 'b
+
+type comparison =
+ | Eq
+ | Lt
+ | Gt
+
+(** val compOpp : comparison -> comparison **)
+
+let compOpp = function
+ | Eq -> Eq
+ | Lt -> Gt
+ | Gt -> Lt
+
+type sumbool =
+ | Left
+ | Right
+
+type 'a sumor =
+ | Inleft of 'a
+ | Inright
+
+type 'a list =
+ | Nil
+ | Cons of 'a * 'a list
+
+(** val app : 'a1 list -> 'a1 list -> 'a1 list **)
+
+let rec app l m =
+ match l with
+ | Nil -> m
+ | Cons (a, l1) -> Cons (a, (app l1 m))
+
+(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **)
+
+let rec nth n0 l default =
+ match n0 with
+ | O -> (match l with
+ | Nil -> default
+ | Cons (x, l') -> x)
+ | S m ->
+ (match l with
+ | Nil -> default
+ | Cons (x, t0) -> nth m t0 default)
+
+(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
+
+let rec map f = function
+ | Nil -> Nil
+ | Cons (a, t0) -> Cons ((f a), (map f t0))
+
+type positive =
+ | XI of positive
+ | XO of positive
+ | XH
+
+(** val psucc : positive -> positive **)
+
+let rec psucc = function
+ | XI p -> XO (psucc p)
+ | XO p -> XI p
+ | XH -> XO XH
+
+(** val pplus : positive -> positive -> positive **)
+
+let rec pplus x y =
+ match x with
+ | XI p ->
+ (match y with
+ | XI q0 -> XO (pplus_carry p q0)
+ | XO q0 -> XI (pplus p q0)
+ | XH -> XO (psucc p))
+ | XO p ->
+ (match y with
+ | XI q0 -> XI (pplus p q0)
+ | XO q0 -> XO (pplus p q0)
+ | XH -> XI p)
+ | XH ->
+ (match y with
+ | XI q0 -> XO (psucc q0)
+ | XO q0 -> XI q0
+ | XH -> XO XH)
+
+(** val pplus_carry : positive -> positive -> positive **)
+
+and pplus_carry x y =
+ match x with
+ | XI p ->
+ (match y with
+ | XI q0 -> XI (pplus_carry p q0)
+ | XO q0 -> XO (pplus_carry p q0)
+ | XH -> XI (psucc p))
+ | XO p ->
+ (match y with
+ | XI q0 -> XO (pplus_carry p q0)
+ | XO q0 -> XI (pplus p q0)
+ | XH -> XO (psucc p))
+ | XH ->
+ (match y with
+ | XI q0 -> XI (psucc q0)
+ | XO q0 -> XO (psucc q0)
+ | XH -> XI XH)
+
+(** val p_of_succ_nat : nat -> positive **)
+
+let rec p_of_succ_nat = function
+ | O -> XH
+ | S x -> psucc (p_of_succ_nat x)
+
+(** val pdouble_minus_one : positive -> positive **)
+
+let rec pdouble_minus_one = function
+ | XI p -> XI (XO p)
+ | XO p -> XI (pdouble_minus_one p)
+ | XH -> XH
+
+type positive_mask =
+ | IsNul
+ | IsPos of positive
+ | IsNeg
+
+(** val pdouble_plus_one_mask : positive_mask -> positive_mask **)
+
+let pdouble_plus_one_mask = function
+ | IsNul -> IsPos XH
+ | IsPos p -> IsPos (XI p)
+ | IsNeg -> IsNeg
+
+(** val pdouble_mask : positive_mask -> positive_mask **)
+
+let pdouble_mask = function
+ | IsNul -> IsNul
+ | IsPos p -> IsPos (XO p)
+ | IsNeg -> IsNeg
+
+(** val pdouble_minus_two : positive -> positive_mask **)
+
+let pdouble_minus_two = function
+ | XI p -> IsPos (XO (XO p))
+ | XO p -> IsPos (XO (pdouble_minus_one p))
+ | XH -> IsNul
+
+(** val pminus_mask : positive -> positive -> positive_mask **)
+
+let rec pminus_mask x y =
+ match x with
+ | XI p ->
+ (match y with
+ | XI q0 -> pdouble_mask (pminus_mask p q0)
+ | XO q0 -> pdouble_plus_one_mask (pminus_mask p q0)
+ | XH -> IsPos (XO p))
+ | XO p ->
+ (match y with
+ | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
+ | XO q0 -> pdouble_mask (pminus_mask p q0)
+ | XH -> IsPos (pdouble_minus_one p))
+ | XH -> (match y with
+ | XH -> IsNul
+ | _ -> IsNeg)
+
+(** val pminus_mask_carry : positive -> positive -> positive_mask **)
+
+and pminus_mask_carry x y =
+ match x with
+ | XI p ->
+ (match y with
+ | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
+ | XO q0 -> pdouble_mask (pminus_mask p q0)
+ | XH -> IsPos (pdouble_minus_one p))
+ | XO p ->
+ (match y with
+ | XI q0 -> pdouble_mask (pminus_mask_carry p q0)
+ | XO q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
+ | XH -> pdouble_minus_two p)
+ | XH -> IsNeg
+
+(** val pminus : positive -> positive -> positive **)
+
+let pminus x y =
+ match pminus_mask x y with
+ | IsPos z0 -> z0
+ | _ -> XH
+
+(** val pmult : positive -> positive -> positive **)
+
+let rec pmult x y =
+ match x with
+ | XI p -> pplus y (XO (pmult p y))
+ | XO p -> XO (pmult p y)
+ | XH -> y
+
+(** val pcompare : positive -> positive -> comparison -> comparison **)
+
+let rec pcompare x y r =
+ match x with
+ | XI p ->
+ (match y with
+ | XI q0 -> pcompare p q0 r
+ | XO q0 -> pcompare p q0 Gt
+ | XH -> Gt)
+ | XO p ->
+ (match y with
+ | XI q0 -> pcompare p q0 Lt
+ | XO q0 -> pcompare p q0 r
+ | XH -> Gt)
+ | XH -> (match y with
+ | XH -> r
+ | _ -> Lt)
+
+type n =
+ | N0
+ | Npos of positive
+
+type z =
+ | Z0
+ | Zpos of positive
+ | Zneg of positive
+
+(** val zdouble_plus_one : z -> z **)
+
+let zdouble_plus_one = function
+ | Z0 -> Zpos XH
+ | Zpos p -> Zpos (XI p)
+ | Zneg p -> Zneg (pdouble_minus_one p)
+
+(** val zdouble_minus_one : z -> z **)
+
+let zdouble_minus_one = function
+ | Z0 -> Zneg XH
+ | Zpos p -> Zpos (pdouble_minus_one p)
+ | Zneg p -> Zneg (XI p)
+
+(** val zdouble : z -> z **)
+
+let zdouble = function
+ | Z0 -> Z0
+ | Zpos p -> Zpos (XO p)
+ | Zneg p -> Zneg (XO p)
+
+(** val zPminus : positive -> positive -> z **)
+
+let rec zPminus x y =
+ match x with
+ | XI p ->
+ (match y with
+ | XI q0 -> zdouble (zPminus p q0)
+ | XO q0 -> zdouble_plus_one (zPminus p q0)
+ | XH -> Zpos (XO p))
+ | XO p ->
+ (match y with
+ | XI q0 -> zdouble_minus_one (zPminus p q0)
+ | XO q0 -> zdouble (zPminus p q0)
+ | XH -> Zpos (pdouble_minus_one p))
+ | XH ->
+ (match y with
+ | XI q0 -> Zneg (XO q0)
+ | XO q0 -> Zneg (pdouble_minus_one q0)
+ | XH -> Z0)
+
+(** val zplus : z -> z -> z **)
+
+let zplus x y =
+ match x with
+ | Z0 -> y
+ | Zpos x' ->
+ (match y with
+ | Z0 -> Zpos x'
+ | Zpos y' -> Zpos (pplus x' y')
+ | Zneg y' ->
+ (match pcompare x' y' Eq with
+ | Eq -> Z0
+ | Lt -> Zneg (pminus y' x')
+ | Gt -> Zpos (pminus x' y')))
+ | Zneg x' ->
+ (match y with
+ | Z0 -> Zneg x'
+ | Zpos y' ->
+ (match pcompare x' y' Eq with
+ | Eq -> Z0
+ | Lt -> Zpos (pminus y' x')
+ | Gt -> Zneg (pminus x' y'))
+ | Zneg y' -> Zneg (pplus x' y'))
+
+(** val zopp : z -> z **)
+
+let zopp = function
+ | Z0 -> Z0
+ | Zpos x0 -> Zneg x0
+ | Zneg x0 -> Zpos x0
+
+(** val zminus : z -> z -> z **)
+
+let zminus m n0 =
+ zplus m (zopp n0)
+
+(** val zmult : z -> z -> z **)
+
+let zmult x y =
+ match x with
+ | Z0 -> Z0
+ | Zpos x' ->
+ (match y with
+ | Z0 -> Z0
+ | Zpos y' -> Zpos (pmult x' y')
+ | Zneg y' -> Zneg (pmult x' y'))
+ | Zneg x' ->
+ (match y with
+ | Z0 -> Z0
+ | Zpos y' -> Zneg (pmult x' y')
+ | Zneg y' -> Zpos (pmult x' y'))
+
+(** val zcompare : z -> z -> comparison **)
+
+let zcompare x y =
+ match x with
+ | Z0 -> (match y with
+ | Z0 -> Eq
+ | Zpos y' -> Lt
+ | Zneg y' -> Gt)
+ | Zpos x' -> (match y with
+ | Zpos y' -> pcompare x' y' Eq
+ | _ -> Gt)
+ | Zneg x' ->
+ (match y with
+ | Zneg y' -> compOpp (pcompare x' y' Eq)
+ | _ -> Lt)
+
+(** val dcompare_inf : comparison -> sumbool sumor **)
+
+let dcompare_inf = function
+ | Eq -> Inleft Left
+ | Lt -> Inleft Right
+ | Gt -> Inright
+
+(** val zcompare_rec :
+ z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
+
+let zcompare_rec x y h1 h2 h3 =
+ match dcompare_inf (zcompare x y) with
+ | Inleft x0 -> (match x0 with
+ | Left -> h1 __
+ | Right -> h2 __)
+ | Inright -> h3 __
+
+(** val z_gt_dec : z -> z -> sumbool **)
+
+let z_gt_dec x y =
+ zcompare_rec x y (fun _ -> Right) (fun _ -> Right) (fun _ -> Left)
+
+(** val zle_bool : z -> z -> bool **)
+
+let zle_bool x y =
+ match zcompare x y with
+ | Gt -> False
+ | _ -> True
+
+(** val zge_bool : z -> z -> bool **)
+
+let zge_bool x y =
+ match zcompare x y with
+ | Lt -> False
+ | _ -> True
+
+(** val zgt_bool : z -> z -> bool **)
+
+let zgt_bool x y =
+ match zcompare x y with
+ | Gt -> True
+ | _ -> False
+
+(** val zeq_bool : z -> z -> bool **)
+
+let zeq_bool x y =
+ match zcompare x y with
+ | Eq -> True
+ | _ -> False
+
+(** val n_of_nat : nat -> n **)
+
+let n_of_nat = function
+ | O -> N0
+ | S n' -> Npos (p_of_succ_nat n')
+
+(** val zdiv_eucl_POS : positive -> z -> (z, z) prod **)
+
+let rec zdiv_eucl_POS a b =
+ match a with
+ | XI a' ->
+ let Pair (q0, r) = zdiv_eucl_POS a' b in
+ let r' = zplus (zmult (Zpos (XO XH)) r) (Zpos XH) in
+ (match zgt_bool b r' with
+ | True -> Pair ((zmult (Zpos (XO XH)) q0), r')
+ | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)),
+ (zminus r' b)))
+ | XO a' ->
+ let Pair (q0, r) = zdiv_eucl_POS a' b in
+ let r' = zmult (Zpos (XO XH)) r in
+ (match zgt_bool b r' with
+ | True -> Pair ((zmult (Zpos (XO XH)) q0), r')
+ | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)),
+ (zminus r' b)))
+ | XH ->
+ (match zge_bool b (Zpos (XO XH)) with
+ | True -> Pair (Z0, (Zpos XH))
+ | False -> Pair ((Zpos XH), Z0))
+
+(** val zdiv_eucl : z -> z -> (z, z) prod **)
+
+let zdiv_eucl a b =
+ match a with
+ | Z0 -> Pair (Z0, Z0)
+ | Zpos a' ->
+ (match b with
+ | Z0 -> Pair (Z0, Z0)
+ | Zpos p -> zdiv_eucl_POS a' b
+ | Zneg b' ->
+ let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in
+ (match r with
+ | Z0 -> Pair ((zopp q0), Z0)
+ | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zplus b r))))
+ | Zneg a' ->
+ (match b with
+ | Z0 -> Pair (Z0, Z0)
+ | Zpos p ->
+ let Pair (q0, r) = zdiv_eucl_POS a' b in
+ (match r with
+ | Z0 -> Pair ((zopp q0), Z0)
+ | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zminus b r)))
+ | Zneg b' ->
+ let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in
+ Pair (q0, (zopp r)))
+
+type 'c pol =
+ | Pc of 'c
+ | Pinj of positive * 'c pol
+ | PX of 'c pol * positive * 'c pol
+
+(** val p0 : 'a1 -> 'a1 pol **)
+
+let p0 cO =
+ Pc cO
+
+(** val p1 : 'a1 -> 'a1 pol **)
+
+let p1 cI =
+ Pc cI
+
+(** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **)
+
+let rec peq ceqb p p' =
+ match p with
+ | Pc c -> (match p' with
+ | Pc c' -> ceqb c c'
+ | _ -> False)
+ | Pinj (j, q0) ->
+ (match p' with
+ | Pinj (j', q') ->
+ (match pcompare j j' Eq with
+ | Eq -> peq ceqb q0 q'
+ | _ -> False)
+ | _ -> False)
+ | PX (p2, i, q0) ->
+ (match p' with
+ | PX (p'0, i', q') ->
+ (match pcompare i i' Eq with
+ | Eq ->
+ (match peq ceqb p2 p'0 with
+ | True -> peq ceqb q0 q'
+ | False -> False)
+ | _ -> False)
+ | _ -> False)
+
+(** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **)
+
+let mkPinj_pred j p =
+ match j with
+ | XI j0 -> Pinj ((XO j0), p)
+ | XO j0 -> Pinj ((pdouble_minus_one j0), p)
+ | XH -> p
+
+(** val mkPX :
+ 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+
+let mkPX cO ceqb p i q0 =
+ match p with
+ | Pc c ->
+ (match ceqb c cO with
+ | True ->
+ (match q0 with
+ | Pc c0 -> q0
+ | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
+ | PX (p2, p3, p4) -> Pinj (XH, q0))
+ | False -> PX (p, i, q0))
+ | Pinj (p2, p3) -> PX (p, i, q0)
+ | PX (p', i', q') ->
+ (match peq ceqb q' (p0 cO) with
+ | True -> PX (p', (pplus i' i), q0)
+ | False -> PX (p, i, q0))
+
+(** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **)
+
+let mkXi cO cI i =
+ PX ((p1 cI), i, (p0 cO))
+
+(** val mkX : 'a1 -> 'a1 -> 'a1 pol **)
+
+let mkX cO cI =
+ mkXi cO cI XH
+
+(** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **)
+
+let rec popp copp = function
+ | Pc c -> Pc (copp c)
+ | Pinj (j, q0) -> Pinj (j, (popp copp q0))
+ | PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0))
+
+(** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **)
+
+let rec paddC cadd p c =
+ match p with
+ | Pc c1 -> Pc (cadd c1 c)
+ | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c))
+ | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c))
+
+(** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **)
+
+let rec psubC csub p c =
+ match p with
+ | Pc c1 -> Pc (csub c1 c)
+ | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c))
+ | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c))
+
+(** val paddI :
+ ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol ->
+ positive -> 'a1 pol -> 'a1 pol **)
+
+let rec paddI cadd pop q0 j = function
+ | Pc c ->
+ let p2 = paddC cadd q0 c in
+ (match p2 with
+ | Pc c0 -> p2
+ | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
+ | PX (p3, p4, p5) -> Pinj (j, p2))
+ | Pinj (j', q') ->
+ (match zPminus j' j with
+ | Z0 ->
+ let p2 = pop q' q0 in
+ (match p2 with
+ | Pc c -> p2
+ | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+ | PX (p3, p4, p5) -> Pinj (j, p2))
+ | Zpos k ->
+ let p2 = pop (Pinj (k, q')) q0 in
+ (match p2 with
+ | Pc c -> p2
+ | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+ | PX (p3, p4, p5) -> Pinj (j, p2))
+ | Zneg k ->
+ let p2 = paddI cadd pop q0 k q' in
+ (match p2 with
+ | Pc c -> p2
+ | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
+ | PX (p3, p4, p5) -> Pinj (j', p2)))
+ | PX (p2, i, q') ->
+ (match j with
+ | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q'))
+ | XO j0 -> PX (p2, i, (paddI cadd pop q0 (pdouble_minus_one j0) q'))
+ | XH -> PX (p2, i, (pop q' q0)))
+
+(** val psubI :
+ ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) ->
+ 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+
+let rec psubI cadd copp pop q0 j = function
+ | Pc c ->
+ let p2 = paddC cadd (popp copp q0) c in
+ (match p2 with
+ | Pc c0 -> p2
+ | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
+ | PX (p3, p4, p5) -> Pinj (j, p2))
+ | Pinj (j', q') ->
+ (match zPminus j' j with
+ | Z0 ->
+ let p2 = pop q' q0 in
+ (match p2 with
+ | Pc c -> p2
+ | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+ | PX (p3, p4, p5) -> Pinj (j, p2))
+ | Zpos k ->
+ let p2 = pop (Pinj (k, q')) q0 in
+ (match p2 with
+ | Pc c -> p2
+ | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+ | PX (p3, p4, p5) -> Pinj (j, p2))
+ | Zneg k ->
+ let p2 = psubI cadd copp pop q0 k q' in
+ (match p2 with
+ | Pc c -> p2
+ | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
+ | PX (p3, p4, p5) -> Pinj (j', p2)))
+ | PX (p2, i, q') ->
+ (match j with
+ | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q'))
+ | XO j0 -> PX (p2, i,
+ (psubI cadd copp pop q0 (pdouble_minus_one j0) q'))
+ | XH -> PX (p2, i, (pop q' q0)))
+
+(** val paddX :
+ 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol
+ -> positive -> 'a1 pol -> 'a1 pol **)
+
+let rec paddX cO ceqb pop p' i' p = match p with
+ | Pc c -> PX (p', i', p)
+ | Pinj (j, q') ->
+ (match j with
+ | XI j0 -> PX (p', i', (Pinj ((XO j0), q')))
+ | XO j0 -> PX (p', i', (Pinj ((pdouble_minus_one j0), q')))
+ | XH -> PX (p', i', q'))
+ | PX (p2, i, q') ->
+ (match zPminus i i' with
+ | Z0 -> mkPX cO ceqb (pop p2 p') i q'
+ | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q'
+ | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q')
+
+(** val psubX :
+ 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1
+ pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+
+let rec psubX cO copp ceqb pop p' i' p = match p with
+ | Pc c -> PX ((popp copp p'), i', p)
+ | Pinj (j, q') ->
+ (match j with
+ | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q')))
+ | XO j0 -> PX ((popp copp p'), i', (Pinj (
+ (pdouble_minus_one j0), q')))
+ | XH -> PX ((popp copp p'), i', q'))
+ | PX (p2, i, q') ->
+ (match zPminus i i' with
+ | Z0 -> mkPX cO ceqb (pop p2 p') i q'
+ | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q'
+ | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q')
+
+(** val padd :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
+ -> 'a1 pol **)
+
+let rec padd cO cadd ceqb p = function
+ | Pc c' -> paddC cadd p c'
+ | Pinj (j', q') -> paddI cadd (fun x x0 -> padd cO cadd ceqb x x0) q' j' p
+ | PX (p'0, i', q') ->
+ (match p with
+ | Pc c -> PX (p'0, i', (paddC cadd q' c))
+ | Pinj (j, q0) ->
+ (match j with
+ | XI j0 -> PX (p'0, i',
+ (padd cO cadd ceqb (Pinj ((XO j0), q0)) q'))
+ | XO j0 -> PX (p'0, i',
+ (padd cO cadd ceqb (Pinj ((pdouble_minus_one j0), q0))
+ q'))
+ | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q')))
+ | PX (p2, i, q0) ->
+ (match zPminus i i' with
+ | Z0 ->
+ mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i
+ (padd cO cadd ceqb q0 q')
+ | Zpos k ->
+ mkPX cO ceqb
+ (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i'
+ (padd cO cadd ceqb q0 q')
+ | Zneg k ->
+ mkPX cO ceqb
+ (paddX cO ceqb (fun x x0 -> padd cO cadd ceqb x x0) p'0
+ k p2) i (padd cO cadd ceqb q0 q')))
+
+(** val psub :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
+ -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
+
+let rec psub cO cadd csub copp ceqb p = function
+ | Pc c' -> psubC csub p c'
+ | Pinj (j', q') ->
+ psubI cadd copp (fun x x0 -> psub cO cadd csub copp ceqb x x0) q' j' p
+ | PX (p'0, i', q') ->
+ (match p with
+ | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c))
+ | Pinj (j, q0) ->
+ (match j with
+ | XI j0 -> PX ((popp copp p'0), i',
+ (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q'))
+ | XO j0 -> PX ((popp copp p'0), i',
+ (psub cO cadd csub copp ceqb (Pinj
+ ((pdouble_minus_one j0), q0)) q'))
+ | XH -> PX ((popp copp p'0), i',
+ (psub cO cadd csub copp ceqb q0 q')))
+ | PX (p2, i, q0) ->
+ (match zPminus i i' with
+ | Z0 ->
+ mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i
+ (psub cO cadd csub copp ceqb q0 q')
+ | Zpos k ->
+ mkPX cO ceqb
+ (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0)
+ i' (psub cO cadd csub copp ceqb q0 q')
+ | Zneg k ->
+ mkPX cO ceqb
+ (psubX cO copp ceqb (fun x x0 ->
+ psub cO cadd csub copp ceqb x x0) p'0 k p2) i
+ (psub cO cadd csub copp ceqb q0 q')))
+
+(** val pmulC_aux :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 ->
+ 'a1 pol **)
+
+let rec pmulC_aux cO cmul ceqb p c =
+ match p with
+ | Pc c' -> Pc (cmul c' c)
+ | Pinj (j, q0) ->
+ let p2 = pmulC_aux cO cmul ceqb q0 c in
+ (match p2 with
+ | Pc c0 -> p2
+ | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
+ | PX (p3, p4, p5) -> Pinj (j, p2))
+ | PX (p2, i, q0) ->
+ mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i
+ (pmulC_aux cO cmul ceqb q0 c)
+
+(** val pmulC :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol ->
+ 'a1 -> 'a1 pol **)
+
+let pmulC cO cI cmul ceqb p c =
+ match ceqb c cO with
+ | True -> p0 cO
+ | False ->
+ (match ceqb c cI with
+ | True -> p
+ | False -> pmulC_aux cO cmul ceqb p c)
+
+(** val pmulI :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol ->
+ 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+
+let rec pmulI cO cI cmul ceqb pmul0 q0 j = function
+ | Pc c ->
+ let p2 = pmulC cO cI cmul ceqb q0 c in
+ (match p2 with
+ | Pc c0 -> p2
+ | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
+ | PX (p3, p4, p5) -> Pinj (j, p2))
+ | Pinj (j', q') ->
+ (match zPminus j' j with
+ | Z0 ->
+ let p2 = pmul0 q' q0 in
+ (match p2 with
+ | Pc c -> p2
+ | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+ | PX (p3, p4, p5) -> Pinj (j, p2))
+ | Zpos k ->
+ let p2 = pmul0 (Pinj (k, q')) q0 in
+ (match p2 with
+ | Pc c -> p2
+ | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
+ | PX (p3, p4, p5) -> Pinj (j, p2))
+ | Zneg k ->
+ let p2 = pmulI cO cI cmul ceqb pmul0 q0 k q' in
+ (match p2 with
+ | Pc c -> p2
+ | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
+ | PX (p3, p4, p5) -> Pinj (j', p2)))
+ | PX (p', i', q') ->
+ (match j with
+ | XI j' ->
+ mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i'
+ (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q')
+ | XO j' ->
+ mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i'
+ (pmulI cO cI cmul ceqb pmul0 q0 (pdouble_minus_one j') q')
+ | XH ->
+ mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i'
+ (pmul0 q' q0))
+
+(** val pmul :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
+
+let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with
+ | Pc c -> pmulC cO cI cmul ceqb p c
+ | Pinj (j', q') ->
+ pmulI cO cI cmul ceqb (fun x x0 -> pmul cO cI cadd cmul ceqb x x0) q'
+ j' p
+ | PX (p', i', q') ->
+ (match p with
+ | Pc c -> pmulC cO cI cmul ceqb p'' c
+ | Pinj (j, q0) ->
+ mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i'
+ (match j with
+ | XI j0 ->
+ pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q'
+ | XO j0 ->
+ pmul cO cI cadd cmul ceqb (Pinj
+ ((pdouble_minus_one j0), q0)) q'
+ | XH -> pmul cO cI cadd cmul ceqb q0 q')
+ | PX (p2, i, q0) ->
+ padd cO cadd ceqb
+ (mkPX cO ceqb
+ (padd cO cadd ceqb
+ (mkPX cO ceqb (pmul cO cI cadd cmul ceqb p2 p') i (p0 cO))
+ (pmul cO cI cadd cmul ceqb
+ (match q0 with
+ | Pc c -> q0
+ | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
+ | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i'
+ (p0 cO))
+ (mkPX cO ceqb
+ (pmulI cO cI cmul ceqb (fun x x0 ->
+ pmul cO cI cadd cmul ceqb x x0) q' XH p2) i
+ (pmul cO cI cadd cmul ceqb q0 q')))
+
+type 'c pExpr =
+ | PEc of 'c
+ | PEX of positive
+ | PEadd of 'c pExpr * 'c pExpr
+ | PEsub of 'c pExpr * 'c pExpr
+ | PEmul of 'c pExpr * 'c pExpr
+ | PEopp of 'c pExpr
+ | PEpow of 'c pExpr * n
+
+(** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **)
+
+let mk_X cO cI j =
+ mkPinj_pred j (mkX cO cI)
+
+(** val ppow_pos :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1
+ pol **)
+
+let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function
+ | XI p3 ->
+ subst_l
+ (pmul cO cI cadd cmul ceqb
+ (ppow_pos cO cI cadd cmul ceqb subst_l
+ (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p)
+ | XO p3 ->
+ ppow_pos cO cI cadd cmul ceqb subst_l
+ (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3
+ | XH -> subst_l (pmul cO cI cadd cmul ceqb res p)
+
+(** val ppow_N :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **)
+
+let ppow_N cO cI cadd cmul ceqb subst_l p = function
+ | N0 -> p1 cI
+ | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2
+
+(** val norm_aux :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **)
+
+let rec norm_aux cO cI cadd cmul csub copp ceqb = function
+ | PEc c -> Pc c
+ | PEX j -> mk_X cO cI j
+ | PEadd (pe1, pe2) ->
+ (match pe1 with
+ | PEopp pe3 ->
+ psub cO cadd csub copp ceqb
+ (norm_aux cO cI cadd cmul csub copp ceqb pe2)
+ (norm_aux cO cI cadd cmul csub copp ceqb pe3)
+ | _ ->
+ (match pe2 with
+ | PEopp pe3 ->
+ psub cO cadd csub copp ceqb
+ (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+ (norm_aux cO cI cadd cmul csub copp ceqb pe3)
+ | _ ->
+ padd cO cadd ceqb
+ (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+ (norm_aux cO cI cadd cmul csub copp ceqb pe2)))
+ | PEsub (pe1, pe2) ->
+ psub cO cadd csub copp ceqb
+ (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+ (norm_aux cO cI cadd cmul csub copp ceqb pe2)
+ | PEmul (pe1, pe2) ->
+ pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+ (norm_aux cO cI cadd cmul csub copp ceqb pe2)
+ | PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1)
+ | PEpow (pe1, n0) ->
+ ppow_N cO cI cadd cmul ceqb (fun p -> p)
+ (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0
+
+type 'a bFormula =
+ | TT
+ | FF
+ | X
+ | A of 'a
+ | Cj of 'a bFormula * 'a bFormula
+ | D of 'a bFormula * 'a bFormula
+ | N of 'a bFormula
+ | I of 'a bFormula * 'a bFormula
+
+type 'term' clause = 'term' list
+
+type 'term' cnf = 'term' clause list
+
+(** val tt : 'a1 cnf **)
+
+let tt =
+ Nil
+
+(** val ff : 'a1 cnf **)
+
+let ff =
+ Cons (Nil, Nil)
+
+(** val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf **)
+
+let or_clause_cnf t0 f =
+ map (fun x -> app t0 x) f
+
+(** val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **)
+
+let rec or_cnf f f' =
+ match f with
+ | Nil -> tt
+ | Cons (e, rst) -> app (or_cnf rst f') (or_clause_cnf e f')
+
+(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **)
+
+let and_cnf f1 f2 =
+ app f1 f2
+
+(** val xcnf :
+ ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **)
+
+let rec xcnf normalise0 negate0 pol0 = function
+ | TT -> (match pol0 with
+ | True -> tt
+ | False -> ff)
+ | FF -> (match pol0 with
+ | True -> ff
+ | False -> tt)
+ | X -> ff
+ | A x -> (match pol0 with
+ | True -> normalise0 x
+ | False -> negate0 x)
+ | Cj (e1, e2) ->
+ (match pol0 with
+ | True ->
+ and_cnf (xcnf normalise0 negate0 pol0 e1)
+ (xcnf normalise0 negate0 pol0 e2)
+ | False ->
+ or_cnf (xcnf normalise0 negate0 pol0 e1)
+ (xcnf normalise0 negate0 pol0 e2))
+ | D (e1, e2) ->
+ (match pol0 with
+ | True ->
+ or_cnf (xcnf normalise0 negate0 pol0 e1)
+ (xcnf normalise0 negate0 pol0 e2)
+ | False ->
+ and_cnf (xcnf normalise0 negate0 pol0 e1)
+ (xcnf normalise0 negate0 pol0 e2))
+ | N e -> xcnf normalise0 negate0 (negb pol0) e
+ | I (e1, e2) ->
+ (match pol0 with
+ | True ->
+ or_cnf (xcnf normalise0 negate0 (negb pol0) e1)
+ (xcnf normalise0 negate0 pol0 e2)
+ | False ->
+ and_cnf (xcnf normalise0 negate0 (negb pol0) e1)
+ (xcnf normalise0 negate0 pol0 e2))
+
+(** val cnf_checker :
+ ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **)
+
+let rec cnf_checker checker f l =
+ match f with
+ | Nil -> True
+ | Cons (e, f0) ->
+ (match l with
+ | Nil -> False
+ | Cons (c, l0) ->
+ (match checker e c with
+ | True -> cnf_checker checker f0 l0
+ | False -> False))
+
+(** val tauto_checker :
+ ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1
+ bFormula -> 'a3 list -> bool **)
+
+let tauto_checker normalise0 negate0 checker f w =
+ cnf_checker checker (xcnf normalise0 negate0 True f) w
+
+type 'c pExprC = 'c pExpr
+
+type 'c polC = 'c pol
+
+type op1 =
+ | Equal
+ | NonEqual
+ | Strict
+ | NonStrict
+
+type 'c nFormula = ('c pExprC, op1) prod
+
+type monoidMember = nat list
+
+type 'c coneMember =
+ | S_In of nat
+ | S_Ideal of 'c pExprC * 'c coneMember
+ | S_Square of 'c pExprC
+ | S_Monoid of monoidMember
+ | S_Mult of 'c coneMember * 'c coneMember
+ | S_Add of 'c coneMember * 'c coneMember
+ | S_Pos of 'c
+ | S_Z
+
+(** val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **)
+
+let nformula_times f f' =
+ let Pair (p, op) = f in
+ let Pair (p', op') = f' in
+ Pair ((PEmul (p, p')),
+ (match op with
+ | Equal -> Equal
+ | NonEqual -> NonEqual
+ | Strict -> op'
+ | NonStrict -> NonStrict))
+
+(** val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **)
+
+let nformula_plus f f' =
+ let Pair (p, op) = f in
+ let Pair (p', op') = f' in
+ Pair ((PEadd (p, p')),
+ (match op with
+ | Equal -> op'
+ | NonEqual -> NonEqual
+ | Strict -> Strict
+ | NonStrict -> (match op' with
+ | Strict -> Strict
+ | _ -> NonStrict)))
+
+(** val eval_monoid :
+ 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC **)
+
+let rec eval_monoid cI l = function
+ | Nil -> PEc cI
+ | Cons (n0, ns0) -> PEmul
+ ((let Pair (q0, o) = nth n0 l (Pair ((PEc cI), NonEqual)) in
+ (match o with
+ | NonEqual -> q0
+ | _ -> PEc cI)), (eval_monoid cI l ns0))
+
+(** val eval_cone :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
+ nFormula list -> 'a1 coneMember -> 'a1 nFormula **)
+
+let rec eval_cone cO cI ceqb cleb l = function
+ | S_In n0 ->
+ let Pair (p, o) = nth n0 l (Pair ((PEc cO), Equal)) in
+ (match o with
+ | NonEqual -> Pair ((PEc cO), Equal)
+ | _ -> nth n0 l (Pair ((PEc cO), Equal)))
+ | S_Ideal (p, cm') ->
+ let f = eval_cone cO cI ceqb cleb l cm' in
+ let Pair (q0, op) = f in
+ (match op with
+ | Equal -> Pair ((PEmul (q0, p)), Equal)
+ | _ -> f)
+ | S_Square p -> Pair ((PEmul (p, p)), NonStrict)
+ | S_Monoid m -> let p = eval_monoid cI l m in Pair ((PEmul (p, p)), Strict)
+ | S_Mult (p, q0) ->
+ nformula_times (eval_cone cO cI ceqb cleb l p)
+ (eval_cone cO cI ceqb cleb l q0)
+ | S_Add (p, q0) ->
+ nformula_plus (eval_cone cO cI ceqb cleb l p)
+ (eval_cone cO cI ceqb cleb l q0)
+ | S_Pos c ->
+ (match match cleb cO c with
+ | True -> negb (ceqb cO c)
+ | False -> False with
+ | True -> Pair ((PEc c), Strict)
+ | False -> Pair ((PEc cO), Equal))
+ | S_Z -> Pair ((PEc cO), Equal)
+
+(** val normalise_pexpr :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC **)
+
+let normalise_pexpr cO cI cplus ctimes cminus copp ceqb x =
+ norm_aux cO cI cplus ctimes cminus copp ceqb x
+
+(** val check_inconsistent :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool)
+ -> 'a1 nFormula -> bool **)
+
+let check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb = function
+ | Pair (e, op) ->
+ (match normalise_pexpr cO cI cplus ctimes cminus copp ceqb e with
+ | Pc c ->
+ (match op with
+ | Equal -> negb (ceqb c cO)
+ | NonEqual -> False
+ | Strict -> cleb c cO
+ | NonStrict ->
+ (match cleb c cO with
+ | True -> negb (ceqb c cO)
+ | False -> False))
+ | _ -> False)
+
+(** val check_normalised_formulas :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool)
+ -> 'a1 nFormula list -> 'a1 coneMember -> bool **)
+
+let check_normalised_formulas cO cI cplus ctimes cminus copp ceqb cleb l cm =
+ check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb
+ (eval_cone cO cI ceqb cleb l cm)
+
+type op2 =
+ | OpEq
+ | OpNEq
+ | OpLe
+ | OpGe
+ | OpLt
+ | OpGt
+
+type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC }
+
+(** val flhs : 'a1 formula -> 'a1 pExprC **)
+
+let flhs x = x.flhs
+
+(** val fop : 'a1 formula -> op2 **)
+
+let fop x = x.fop
+
+(** val frhs : 'a1 formula -> 'a1 pExprC **)
+
+let frhs x = x.frhs
+
+(** val xnormalise : 'a1 formula -> 'a1 nFormula list **)
+
+let xnormalise t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+ (match o with
+ | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair
+ ((PEsub (rhs, lhs)), Strict)), Nil)))
+ | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+ | OpLe -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil)
+ | OpGe -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil)
+ | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+ | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil))
+
+(** val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf **)
+
+let cnf_normalise t0 =
+ map (fun x -> Cons (x, Nil)) (xnormalise t0)
+
+(** val xnegate : 'a1 formula -> 'a1 nFormula list **)
+
+let xnegate t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+ (match o with
+ | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+ | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair
+ ((PEsub (rhs, lhs)), Strict)), Nil)))
+ | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)
+ | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+ | OpLt -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil)
+ | OpGt -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil))
+
+(** val cnf_negate : 'a1 formula -> 'a1 nFormula cnf **)
+
+let cnf_negate t0 =
+ map (fun x -> Cons (x, Nil)) (xnegate t0)
+
+(** val simpl_expr :
+ 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC **)
+
+let rec simpl_expr cI ceqb e = match e with
+ | PEadd (x, y) -> PEadd ((simpl_expr cI ceqb x), (simpl_expr cI ceqb y))
+ | PEmul (y, z0) ->
+ let y' = simpl_expr cI ceqb y in
+ (match y' with
+ | PEc c ->
+ (match ceqb c cI with
+ | True -> simpl_expr cI ceqb z0
+ | False -> PEmul (y', (simpl_expr cI ceqb z0)))
+ | _ -> PEmul (y', (simpl_expr cI ceqb z0)))
+ | _ -> e
+
+(** val simpl_cone :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1
+ coneMember -> 'a1 coneMember **)
+
+let simpl_cone cO cI ctimes ceqb e = match e with
+ | S_Square t0 ->
+ (match simpl_expr cI ceqb t0 with
+ | PEc c ->
+ (match ceqb cO c with
+ | True -> S_Z
+ | False -> S_Pos (ctimes c c))
+ | _ -> S_Square (simpl_expr cI ceqb t0))
+ | S_Mult (t1, t2) ->
+ (match t1 with
+ | S_Mult (x, x0) ->
+ (match x with
+ | S_Pos p2 ->
+ (match t2 with
+ | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x0)
+ | S_Z -> S_Z
+ | _ -> e)
+ | _ ->
+ (match x0 with
+ | S_Pos p2 ->
+ (match t2 with
+ | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x)
+ | S_Z -> S_Z
+ | _ -> e)
+ | _ ->
+ (match t2 with
+ | S_Pos c ->
+ (match ceqb cI c with
+ | True -> t1
+ | False -> S_Mult (t1, t2))
+ | S_Z -> S_Z
+ | _ -> e)))
+ | S_Pos c ->
+ (match t2 with
+ | S_Mult (x, x0) ->
+ (match x with
+ | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x0)
+ | _ ->
+ (match x0 with
+ | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x)
+ | _ ->
+ (match ceqb cI c with
+ | True -> t2
+ | False -> S_Mult (t1, t2))))
+ | S_Add (y, z0) -> S_Add ((S_Mult ((S_Pos c), y)), (S_Mult
+ ((S_Pos c), z0)))
+ | S_Pos c0 -> S_Pos (ctimes c c0)
+ | S_Z -> S_Z
+ | _ ->
+ (match ceqb cI c with
+ | True -> t2
+ | False -> S_Mult (t1, t2)))
+ | S_Z -> S_Z
+ | _ ->
+ (match t2 with
+ | S_Pos c ->
+ (match ceqb cI c with
+ | True -> t1
+ | False -> S_Mult (t1, t2))
+ | S_Z -> S_Z
+ | _ -> e))
+ | S_Add (t1, t2) ->
+ (match t1 with
+ | S_Z -> t2
+ | _ -> (match t2 with
+ | S_Z -> t1
+ | _ -> S_Add (t1, t2)))
+ | _ -> e
+
+type q = { qnum : z; qden : positive }
+
+(** val qnum : q -> z **)
+
+let qnum x = x.qnum
+
+(** val qden : q -> positive **)
+
+let qden x = x.qden
+
+(** val qplus : q -> q -> q **)
+
+let qplus x y =
+ { qnum = (zplus (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden)));
+ qden = (pmult x.qden y.qden) }
+
+(** val qmult : q -> q -> q **)
+
+let qmult x y =
+ { qnum = (zmult x.qnum y.qnum); qden = (pmult x.qden y.qden) }
+
+(** val qopp : q -> q **)
+
+let qopp x =
+ { qnum = (zopp x.qnum); qden = x.qden }
+
+(** val qminus : q -> q -> q **)
+
+let qminus x y =
+ qplus x (qopp y)
+
+type 'a t =
+ | Empty
+ | Leaf of 'a
+ | Node of 'a t * 'a * 'a t
+
+(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **)
+
+let rec find default vm p =
+ match vm with
+ | Empty -> default
+ | Leaf i -> i
+ | Node (l, e, r) ->
+ (match p with
+ | XI p2 -> find default r p2
+ | XO p2 -> find default l p2
+ | XH -> e)
+
+type zWitness = z coneMember
+
+(** val zWeakChecker : z nFormula list -> z coneMember -> bool **)
+
+let zWeakChecker x x0 =
+ check_normalised_formulas Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool
+ zle_bool x x0
+
+(** val xnormalise0 : z formula -> z nFormula list **)
+
+let xnormalise0 t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+ (match o with
+ | OpEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+ NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos
+ XH)))))), NonStrict)), Nil)))
+ | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+ | OpLe -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+ NonStrict)), Nil)
+ | OpGe -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))),
+ NonStrict)), Nil)
+ | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+ | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil))
+
+(** val normalise : z formula -> z nFormula cnf **)
+
+let normalise t0 =
+ map (fun x -> Cons (x, Nil)) (xnormalise0 t0)
+
+(** val xnegate0 : z formula -> z nFormula list **)
+
+let xnegate0 t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+ (match o with
+ | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+ | OpNEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+ NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos
+ XH)))))), NonStrict)), Nil)))
+ | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)
+ | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+ | OpLt -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))),
+ NonStrict)), Nil)
+ | OpGt -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+ NonStrict)), Nil))
+
+(** val negate : z formula -> z nFormula cnf **)
+
+let negate t0 =
+ map (fun x -> Cons (x, Nil)) (xnegate0 t0)
+
+(** val ceiling : z -> z -> z **)
+
+let ceiling a b =
+ let Pair (q0, r) = zdiv_eucl a b in
+ (match r with
+ | Z0 -> q0
+ | _ -> zplus q0 (Zpos XH))
+
+type proofTerm =
+ | RatProof of zWitness
+ | CutProof of z pExprC * q * zWitness * proofTerm
+ | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list
+
+(** val makeLb : z pExpr -> q -> z nFormula **)
+
+let makeLb v q0 =
+ let { qnum = n0; qden = d } = q0 in
+ Pair ((PEsub ((PEmul ((PEc (Zpos d)), v)), (PEc n0))), NonStrict)
+
+(** val qceiling : q -> z **)
+
+let qceiling q0 =
+ let { qnum = n0; qden = d } = q0 in ceiling n0 (Zpos d)
+
+(** val makeLbCut : z pExprC -> q -> z nFormula **)
+
+let makeLbCut v q0 =
+ Pair ((PEsub (v, (PEc (qceiling q0)))), NonStrict)
+
+(** val neg_nformula : z nFormula -> (z pExpr, op1) prod **)
+
+let neg_nformula = function
+ | Pair (e, o) -> Pair ((PEopp (PEadd (e, (PEc (Zpos XH))))), o)
+
+(** val cutChecker :
+ z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option **)
+
+let cutChecker l e lb pf =
+ match zWeakChecker (Cons ((neg_nformula (makeLb e lb)), l)) pf with
+ | True -> Some (makeLbCut e lb)
+ | False -> None
+
+(** val zChecker : z nFormula list -> proofTerm -> bool **)
+
+let rec zChecker l = function
+ | RatProof pf0 -> zWeakChecker l pf0
+ | CutProof (e, q0, pf0, rst) ->
+ (match cutChecker l e q0 pf0 with
+ | Some c -> zChecker (Cons (c, l)) rst
+ | None -> False)
+ | EnumProof (lb, e, ub, pf1, pf2, rst) ->
+ (match cutChecker l e lb pf1 with
+ | Some n0 ->
+ (match cutChecker l (PEopp e) (qopp ub) pf2 with
+ | Some n1 ->
+ let rec label pfs lb0 ub0 =
+ match pfs with
+ | Nil ->
+ (match z_gt_dec lb0 ub0 with
+ | Left -> True
+ | Right -> False)
+ | Cons (pf0, rsr) ->
+ (match zChecker (Cons ((Pair ((PEsub (e, (PEc
+ lb0))), Equal)), l)) pf0 with
+ | True -> label rsr (zplus lb0 (Zpos XH)) ub0
+ | False -> False)
+ in label rst (qceiling lb) (zopp (qceiling (qopp ub)))
+ | None -> False)
+ | None -> False)
+
+(** val zTautoChecker : z formula bFormula -> proofTerm list -> bool **)
+
+let zTautoChecker f w =
+ tauto_checker normalise negate zChecker f w
+
+(** val map_cone : (nat -> nat) -> zWitness -> zWitness **)
+
+let rec map_cone f e = match e with
+ | S_In n0 -> S_In (f n0)
+ | S_Ideal (e0, cm) -> S_Ideal (e0, (map_cone f cm))
+ | S_Monoid l -> S_Monoid (map f l)
+ | S_Mult (cm1, cm2) -> S_Mult ((map_cone f cm1), (map_cone f cm2))
+ | S_Add (cm1, cm2) -> S_Add ((map_cone f cm1), (map_cone f cm2))
+ | _ -> e
+
+(** val indexes : zWitness -> nat list **)
+
+let rec indexes = function
+ | S_In n0 -> Cons (n0, Nil)
+ | S_Ideal (e0, cm) -> indexes cm
+ | S_Monoid l -> l
+ | S_Mult (cm1, cm2) -> app (indexes cm1) (indexes cm2)
+ | S_Add (cm1, cm2) -> app (indexes cm1) (indexes cm2)
+ | _ -> Nil
+
+(** val n_of_Z : z -> n **)
+
+let n_of_Z = function
+ | Zpos p -> Npos p
+ | _ -> N0
+
+(** val qeq_bool : q -> q -> bool **)
+
+let qeq_bool p q0 =
+ zeq_bool (zmult p.qnum (Zpos q0.qden)) (zmult q0.qnum (Zpos p.qden))
+
+(** val qle_bool : q -> q -> bool **)
+
+let qle_bool x y =
+ zle_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden))
+
+type qWitness = q coneMember
+
+(** val qWeakChecker : q nFormula list -> q coneMember -> bool **)
+
+let qWeakChecker x x0 =
+ check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH);
+ qden = XH } qplus qmult qminus qopp qeq_bool qle_bool x x0
+
+(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **)
+
+let qTautoChecker f w =
+ tauto_checker (fun x -> cnf_normalise x) (fun x ->
+ cnf_negate x) qWeakChecker f w
+
diff --git a/contrib/micromega/micromega.mli b/contrib/micromega/micromega.mli
new file mode 100644
index 00000000..f94f091e
--- /dev/null
+++ b/contrib/micromega/micromega.mli
@@ -0,0 +1,398 @@
+type __ = Obj.t
+
+type bool =
+ | True
+ | False
+
+val negb : bool -> bool
+
+type nat =
+ | O
+ | S of nat
+
+type 'a option =
+ | Some of 'a
+ | None
+
+type ('a, 'b) prod =
+ | Pair of 'a * 'b
+
+type comparison =
+ | Eq
+ | Lt
+ | Gt
+
+val compOpp : comparison -> comparison
+
+type sumbool =
+ | Left
+ | Right
+
+type 'a sumor =
+ | Inleft of 'a
+ | Inright
+
+type 'a list =
+ | Nil
+ | Cons of 'a * 'a list
+
+val app : 'a1 list -> 'a1 list -> 'a1 list
+
+val nth : nat -> 'a1 list -> 'a1 -> 'a1
+
+val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list
+
+type positive =
+ | XI of positive
+ | XO of positive
+ | XH
+
+val psucc : positive -> positive
+
+val pplus : positive -> positive -> positive
+
+val pplus_carry : positive -> positive -> positive
+
+val p_of_succ_nat : nat -> positive
+
+val pdouble_minus_one : positive -> positive
+
+type positive_mask =
+ | IsNul
+ | IsPos of positive
+ | IsNeg
+
+val pdouble_plus_one_mask : positive_mask -> positive_mask
+
+val pdouble_mask : positive_mask -> positive_mask
+
+val pdouble_minus_two : positive -> positive_mask
+
+val pminus_mask : positive -> positive -> positive_mask
+
+val pminus_mask_carry : positive -> positive -> positive_mask
+
+val pminus : positive -> positive -> positive
+
+val pmult : positive -> positive -> positive
+
+val pcompare : positive -> positive -> comparison -> comparison
+
+type n =
+ | N0
+ | Npos of positive
+
+type z =
+ | Z0
+ | Zpos of positive
+ | Zneg of positive
+
+val zdouble_plus_one : z -> z
+
+val zdouble_minus_one : z -> z
+
+val zdouble : z -> z
+
+val zPminus : positive -> positive -> z
+
+val zplus : z -> z -> z
+
+val zopp : z -> z
+
+val zminus : z -> z -> z
+
+val zmult : z -> z -> z
+
+val zcompare : z -> z -> comparison
+
+val dcompare_inf : comparison -> sumbool sumor
+
+val zcompare_rec : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
+
+val z_gt_dec : z -> z -> sumbool
+
+val zle_bool : z -> z -> bool
+
+val zge_bool : z -> z -> bool
+
+val zgt_bool : z -> z -> bool
+
+val zeq_bool : z -> z -> bool
+
+val n_of_nat : nat -> n
+
+val zdiv_eucl_POS : positive -> z -> (z, z) prod
+
+val zdiv_eucl : z -> z -> (z, z) prod
+
+type 'c pol =
+ | Pc of 'c
+ | Pinj of positive * 'c pol
+ | PX of 'c pol * positive * 'c pol
+
+val p0 : 'a1 -> 'a1 pol
+
+val p1 : 'a1 -> 'a1 pol
+
+val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool
+
+val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol
+
+val mkPX :
+ 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol
+
+val mkX : 'a1 -> 'a1 -> 'a1 pol
+
+val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol
+
+val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol
+
+val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol
+
+val paddI :
+ ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol ->
+ positive -> 'a1 pol -> 'a1 pol
+
+val psubI :
+ ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) ->
+ 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val paddX :
+ 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol
+ -> positive -> 'a1 pol -> 'a1 pol
+
+val psubX :
+ 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1
+ pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val padd :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol ->
+ 'a1 pol
+
+val psub :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
+ -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+
+val pmulC_aux :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1
+ pol
+
+val pmulC :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1
+ -> 'a1 pol
+
+val pmulI :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol ->
+ 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val pmul :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+
+type 'c pExpr =
+ | PEc of 'c
+ | PEX of positive
+ | PEadd of 'c pExpr * 'c pExpr
+ | PEsub of 'c pExpr * 'c pExpr
+ | PEmul of 'c pExpr * 'c pExpr
+ | PEopp of 'c pExpr
+ | PEpow of 'c pExpr * n
+
+val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol
+
+val ppow_pos :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol
+
+val ppow_N :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol
+
+val norm_aux :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
+
+type 'a bFormula =
+ | TT
+ | FF
+ | X
+ | A of 'a
+ | Cj of 'a bFormula * 'a bFormula
+ | D of 'a bFormula * 'a bFormula
+ | N of 'a bFormula
+ | I of 'a bFormula * 'a bFormula
+
+type 'term' clause = 'term' list
+
+type 'term' cnf = 'term' clause list
+
+val tt : 'a1 cnf
+
+val ff : 'a1 cnf
+
+val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf
+
+val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf
+
+val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf
+
+val xcnf :
+ ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf
+
+val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool
+
+val tauto_checker :
+ ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1
+ bFormula -> 'a3 list -> bool
+
+type 'c pExprC = 'c pExpr
+
+type 'c polC = 'c pol
+
+type op1 =
+ | Equal
+ | NonEqual
+ | Strict
+ | NonStrict
+
+type 'c nFormula = ('c pExprC, op1) prod
+
+type monoidMember = nat list
+
+type 'c coneMember =
+ | S_In of nat
+ | S_Ideal of 'c pExprC * 'c coneMember
+ | S_Square of 'c pExprC
+ | S_Monoid of monoidMember
+ | S_Mult of 'c coneMember * 'c coneMember
+ | S_Add of 'c coneMember * 'c coneMember
+ | S_Pos of 'c
+ | S_Z
+
+val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula
+
+val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula
+
+val eval_monoid : 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC
+
+val eval_cone :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula
+ list -> 'a1 coneMember -> 'a1 nFormula
+
+val normalise_pexpr :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC
+
+val check_inconsistent :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
+ nFormula -> bool
+
+val check_normalised_formulas :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
+ nFormula list -> 'a1 coneMember -> bool
+
+type op2 =
+ | OpEq
+ | OpNEq
+ | OpLe
+ | OpGe
+ | OpLt
+ | OpGt
+
+type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC }
+
+val flhs : 'a1 formula -> 'a1 pExprC
+
+val fop : 'a1 formula -> op2
+
+val frhs : 'a1 formula -> 'a1 pExprC
+
+val xnormalise : 'a1 formula -> 'a1 nFormula list
+
+val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf
+
+val xnegate : 'a1 formula -> 'a1 nFormula list
+
+val cnf_negate : 'a1 formula -> 'a1 nFormula cnf
+
+val simpl_expr : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC
+
+val simpl_cone :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 coneMember
+ -> 'a1 coneMember
+
+type q = { qnum : z; qden : positive }
+
+val qnum : q -> z
+
+val qden : q -> positive
+
+val qplus : q -> q -> q
+
+val qmult : q -> q -> q
+
+val qopp : q -> q
+
+val qminus : q -> q -> q
+
+type 'a t =
+ | Empty
+ | Leaf of 'a
+ | Node of 'a t * 'a * 'a t
+
+val find : 'a1 -> 'a1 t -> positive -> 'a1
+
+type zWitness = z coneMember
+
+val zWeakChecker : z nFormula list -> z coneMember -> bool
+
+val xnormalise0 : z formula -> z nFormula list
+
+val normalise : z formula -> z nFormula cnf
+
+val xnegate0 : z formula -> z nFormula list
+
+val negate : z formula -> z nFormula cnf
+
+val ceiling : z -> z -> z
+
+type proofTerm =
+ | RatProof of zWitness
+ | CutProof of z pExprC * q * zWitness * proofTerm
+ | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list
+
+val makeLb : z pExpr -> q -> z nFormula
+
+val qceiling : q -> z
+
+val makeLbCut : z pExprC -> q -> z nFormula
+
+val neg_nformula : z nFormula -> (z pExpr, op1) prod
+
+val cutChecker :
+ z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option
+
+val zChecker : z nFormula list -> proofTerm -> bool
+
+val zTautoChecker : z formula bFormula -> proofTerm list -> bool
+
+val map_cone : (nat -> nat) -> zWitness -> zWitness
+
+val indexes : zWitness -> nat list
+
+val n_of_Z : z -> n
+
+val qeq_bool : q -> q -> bool
+
+val qle_bool : q -> q -> bool
+
+type qWitness = q coneMember
+
+val qWeakChecker : q nFormula list -> q coneMember -> bool
+
+val qTautoChecker : q formula bFormula -> qWitness list -> bool
+
diff --git a/contrib/micromega/mutils.ml b/contrib/micromega/mutils.ml
new file mode 100644
index 00000000..2473608f
--- /dev/null
+++ b/contrib/micromega/mutils.ml
@@ -0,0 +1,305 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+let debug = false
+
+let fst' (Micromega.Pair(x,y)) = x
+let snd' (Micromega.Pair(x,y)) = y
+
+let rec try_any l x =
+ match l with
+ | [] -> None
+ | (f,s)::l -> match f x with
+ | None -> try_any l x
+ | x -> x
+
+let list_try_find f =
+ let rec try_find_f = function
+ | [] -> failwith "try_find"
+ | h::t -> try f h with Failure _ -> try_find_f t
+ in
+ try_find_f
+
+let rec list_fold_right_elements f l =
+ let rec aux = function
+ | [] -> invalid_arg "list_fold_right_elements"
+ | [x] -> x
+ | x::l -> f x (aux l) in
+ aux l
+
+let interval n m =
+ let rec interval_n (l,m) =
+ if n > m then l else interval_n (m::l,pred m)
+ in
+ interval_n ([],m)
+
+open Num
+open Big_int
+
+let ppcm x y =
+ let g = gcd_big_int x y in
+ let x' = div_big_int x g in
+ let y' = div_big_int y g in
+ mult_big_int g (mult_big_int x' y')
+
+
+let denominator = function
+ | Int _ | Big_int _ -> unit_big_int
+ | Ratio r -> Ratio.denominator_ratio r
+
+let numerator = function
+ | Ratio r -> Ratio.numerator_ratio r
+ | Int i -> Big_int.big_int_of_int i
+ | Big_int i -> i
+
+let rec ppcm_list c l =
+ match l with
+ | [] -> c
+ | e::l -> ppcm_list (ppcm c (denominator e)) l
+
+let rec rec_gcd_list c l =
+ match l with
+ | [] -> c
+ | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l
+
+let rec gcd_list l =
+ let res = rec_gcd_list zero_big_int l in
+ if compare_big_int res zero_big_int = 0
+ then unit_big_int else res
+
+
+
+let rats_to_ints l =
+ let c = ppcm_list unit_big_int l in
+ List.map (fun x -> (div_big_int (mult_big_int (numerator x) c)
+ (denominator x))) l
+
+(* Nasty reordering of lists - useful to trim certificate down *)
+let mapi f l =
+ let rec xmapi i l =
+ match l with
+ | [] -> []
+ | e::l -> (f e i)::(xmapi (i+1) l) in
+ xmapi 0 l
+
+
+let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l)
+
+(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *)
+let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l))
+
+let assoc_pos_assoc l =
+ let rec xpos i l =
+ match l with
+ | [] -> []
+ | (x,l) ::rst -> let (l',j) = assoc_pos i l in
+ (x,l')::(xpos j rst) in
+ xpos 0 l
+
+let filter_pos f l =
+ (* Could sort ... take care of duplicates... *)
+ let rec xfilter l =
+ match l with
+ | [] -> []
+ | (x,e)::l ->
+ if List.exists (fun ee -> List.mem ee f) (List.map snd e)
+ then (x,e)::(xfilter l)
+ else xfilter l in
+ xfilter l
+
+let select_pos lpos l =
+ let rec xselect i lpos l =
+ match lpos with
+ | [] -> []
+ | j::rpos ->
+ match l with
+ | [] -> failwith "select_pos"
+ | e::l ->
+ if i = j
+ then e:: (xselect (i+1) rpos l)
+ else xselect (i+1) lpos l in
+ xselect 0 lpos l
+
+
+module CoqToCaml =
+struct
+ open Micromega
+
+ let rec nat = function
+ | O -> 0
+ | S n -> (nat n) + 1
+
+
+ let rec positive p =
+ match p with
+ | XH -> 1
+ | XI p -> 1+ 2*(positive p)
+ | XO p -> 2*(positive p)
+
+
+ let n nt =
+ match nt with
+ | N0 -> 0
+ | Npos p -> positive p
+
+
+ let rec index i = (* Swap left-right ? *)
+ match i with
+ | XH -> 1
+ | XI i -> 1+(2*(index i))
+ | XO i -> 2*(index i)
+
+
+ let z x =
+ match x with
+ | Z0 -> 0
+ | Zpos p -> (positive p)
+ | Zneg p -> - (positive p)
+
+ open Big_int
+
+ let rec positive_big_int p =
+ match p with
+ | XH -> unit_big_int
+ | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p))
+ | XO p -> (mult_int_big_int 2 (positive_big_int p))
+
+
+ let z_big_int x =
+ match x with
+ | Z0 -> zero_big_int
+ | Zpos p -> (positive_big_int p)
+ | Zneg p -> minus_big_int (positive_big_int p)
+
+
+ let num x = Num.Big_int (z_big_int x)
+
+ let rec list elt l =
+ match l with
+ | Nil -> []
+ | Cons(e,l) -> (elt e)::(list elt l)
+
+ let q_to_num {qnum = x ; qden = y} =
+ Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y)))
+
+end
+
+
+module CamlToCoq =
+struct
+ open Micromega
+
+ let rec nat = function
+ | 0 -> O
+ | n -> S (nat (n-1))
+
+
+ let rec positive n =
+ if n=1 then XH
+ else if n land 1 = 1 then XI (positive (n lsr 1))
+ else XO (positive (n lsr 1))
+
+ let n nt =
+ if nt < 0
+ then assert false
+ else if nt = 0 then N0
+ else Npos (positive nt)
+
+
+
+
+
+ let rec index n =
+ if n=1 then XH
+ else if n land 1 = 1 then XI (index (n lsr 1))
+ else XO (index (n lsr 1))
+
+
+ let idx n =
+ (*a.k.a path_of_int *)
+ (* returns the list of digits of n in reverse order with
+ initial 1 removed *)
+ let rec digits_of_int n =
+ if n=1 then []
+ else (n mod 2 = 1)::(digits_of_int (n lsr 1))
+ in
+ List.fold_right
+ (fun b c -> (if b then XI c else XO c))
+ (List.rev (digits_of_int n))
+ (XH)
+
+
+
+ let z x =
+ match compare x 0 with
+ | 0 -> Z0
+ | 1 -> Zpos (positive x)
+ | _ -> (* this should be -1 *)
+ Zneg (positive (-x))
+
+ open Big_int
+
+ let positive_big_int n =
+ let two = big_int_of_int 2 in
+ let rec _pos n =
+ if eq_big_int n unit_big_int then XH
+ else
+ let (q,m) = quomod_big_int n two in
+ if eq_big_int unit_big_int m
+ then XI (_pos q)
+ else XO (_pos q) in
+ _pos n
+
+ let bigint x =
+ match sign_big_int x with
+ | 0 -> Z0
+ | 1 -> Zpos (positive_big_int x)
+ | _ -> Zneg (positive_big_int (minus_big_int x))
+
+ let q n =
+ {Micromega.qnum = bigint (numerator n) ;
+ Micromega.qden = positive_big_int (denominator n)}
+
+
+ let list elt l = List.fold_right (fun x l -> Cons(elt x, l)) l Nil
+
+end
+
+module Cmp =
+struct
+
+ let rec compare_lexical l =
+ match l with
+ | [] -> 0 (* Equal *)
+ | f::l ->
+ let cmp = f () in
+ if cmp = 0 then compare_lexical l else cmp
+
+ let rec compare_list cmp l1 l2 =
+ match l1 , l2 with
+ | [] , [] -> 0
+ | [] , _ -> -1
+ | _ , [] -> 1
+ | e1::l1 , e2::l2 ->
+ let c = cmp e1 e2 in
+ if c = 0 then compare_list cmp l1 l2 else c
+
+ let hash_list hash l =
+ let rec _hash_list l h =
+ match l with
+ | [] -> h lxor (Hashtbl.hash [])
+ | e::l -> _hash_list l ((hash e) lxor h) in
+
+ _hash_list l 0
+end
diff --git a/contrib/micromega/sos.ml b/contrib/micromega/sos.ml
new file mode 100644
index 00000000..e3d72ed9
--- /dev/null
+++ b/contrib/micromega/sos.ml
@@ -0,0 +1,1919 @@
+(* ========================================================================= *)
+(* - This code originates from John Harrison's HOL LIGHT 2.20 *)
+(* (see file LICENSE.sos for license, copyright and disclaimer) *)
+(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *)
+(* independent bits *)
+(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *)
+(* - Addition of a csdp cache by the Coq development team *)
+(* ========================================================================= *)
+
+(* ========================================================================= *)
+(* Nonlinear universal reals procedure using SOS decomposition. *)
+(* ========================================================================= *)
+
+open Num;;
+open List;;
+
+let debugging = ref false;;
+
+exception Sanity;;
+
+exception Unsolvable;;
+
+(* ------------------------------------------------------------------------- *)
+(* Comparisons that are reflexive on NaN and also short-circuiting. *)
+(* ------------------------------------------------------------------------- *)
+
+let (=?) = fun x y -> Pervasives.compare x y = 0;;
+let (<?) = fun x y -> Pervasives.compare x y < 0;;
+let (<=?) = fun x y -> Pervasives.compare x y <= 0;;
+let (>?) = fun x y -> Pervasives.compare x y > 0;;
+let (>=?) = fun x y -> Pervasives.compare x y >= 0;;
+
+(* ------------------------------------------------------------------------- *)
+(* Combinators. *)
+(* ------------------------------------------------------------------------- *)
+
+let (o) = fun f g x -> f(g x);;
+
+(* ------------------------------------------------------------------------- *)
+(* Some useful functions on "num" type. *)
+(* ------------------------------------------------------------------------- *)
+
+
+let num_0 = Int 0
+and num_1 = Int 1
+and num_2 = Int 2
+and num_10 = Int 10;;
+
+let pow2 n = power_num num_2 (Int n);;
+let pow10 n = power_num num_10 (Int n);;
+
+let numdom r =
+ let r' = Ratio.normalize_ratio (ratio_of_num r) in
+ num_of_big_int(Ratio.numerator_ratio r'),
+ num_of_big_int(Ratio.denominator_ratio r');;
+
+let numerator = (o) fst numdom
+and denominator = (o) snd numdom;;
+
+let gcd_num n1 n2 =
+ num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));;
+
+let lcm_num x y =
+ if x =/ num_0 & y =/ num_0 then num_0
+ else abs_num((x */ y) // gcd_num x y);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* List basics. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec el n l =
+ if n = 0 then hd l else el (n - 1) (tl l);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Various versions of list iteration. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec itlist f l b =
+ match l with
+ [] -> b
+ | (h::t) -> f h (itlist f t b);;
+
+let rec end_itlist f l =
+ match l with
+ [] -> failwith "end_itlist"
+ | [x] -> x
+ | (h::t) -> f h (end_itlist f t);;
+
+let rec itlist2 f l1 l2 b =
+ match (l1,l2) with
+ ([],[]) -> b
+ | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b)
+ | _ -> failwith "itlist2";;
+
+(* ------------------------------------------------------------------------- *)
+(* All pairs arising from applying a function over two lists. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec allpairs f l1 l2 =
+ match l1 with
+ h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2)
+ | [] -> [];;
+
+(* ------------------------------------------------------------------------- *)
+(* String operations (surely there is a better way...) *)
+(* ------------------------------------------------------------------------- *)
+
+let implode l = itlist (^) l "";;
+
+let explode s =
+ let rec exap n l =
+ if n < 0 then l else
+ exap (n - 1) ((String.sub s n 1)::l) in
+ exap (String.length s - 1) [];;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Attempting function or predicate applications. *)
+(* ------------------------------------------------------------------------- *)
+
+let can f x = try (f x; true) with Failure _ -> false;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Repetition of a function. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec funpow n f x =
+ if n < 1 then x else funpow (n-1) f (f x);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* term?? *)
+(* ------------------------------------------------------------------------- *)
+
+type vname = string;;
+
+type term =
+| Zero
+| Const of Num.num
+| Var of vname
+| Inv of term
+| Opp of term
+| Add of (term * term)
+| Sub of (term * term)
+| Mul of (term * term)
+| Div of (term * term)
+| Pow of (term * int);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Data structure for Positivstellensatz refutations. *)
+(* ------------------------------------------------------------------------- *)
+
+type positivstellensatz =
+ Axiom_eq of int
+ | Axiom_le of int
+ | Axiom_lt of int
+ | Rational_eq of num
+ | Rational_le of num
+ | Rational_lt of num
+ | Square of term
+ | Monoid of int list
+ | Eqmul of term * positivstellensatz
+ | Sum of positivstellensatz * positivstellensatz
+ | Product of positivstellensatz * positivstellensatz;;
+
+
+
+(* ------------------------------------------------------------------------- *)
+(* Replication and sequences. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec replicate x n =
+ if n < 1 then []
+ else x::(replicate x (n - 1));;
+
+let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;
+
+(* ------------------------------------------------------------------------- *)
+(* Various useful list operations. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec forall p l =
+ match l with
+ [] -> true
+ | h::t -> p(h) & forall p t;;
+
+let rec tryfind f l =
+ match l with
+ [] -> failwith "tryfind"
+ | (h::t) -> try f h with Failure _ -> tryfind f t;;
+
+let index x =
+ let rec ind n l =
+ match l with
+ [] -> failwith "index"
+ | (h::t) -> if x =? h then n else ind (n + 1) t in
+ ind 0;;
+
+(* ------------------------------------------------------------------------- *)
+(* "Set" operations on lists. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec mem x lis =
+ match lis with
+ [] -> false
+ | (h::t) -> x =? h or mem x t;;
+
+let insert x l =
+ if mem x l then l else x::l;;
+
+let union l1 l2 = itlist insert l1 l2;;
+
+let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;;
+
+(* ------------------------------------------------------------------------- *)
+(* Merging and bottom-up mergesort. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec merge ord l1 l2 =
+ match l1 with
+ [] -> l2
+ | h1::t1 -> match l2 with
+ [] -> l1
+ | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2)
+ else h2::(merge ord l1 t2);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Common measure predicates to use with "sort". *)
+(* ------------------------------------------------------------------------- *)
+
+let increasing f x y = f x <? f y;;
+
+let decreasing f x y = f x >? f y;;
+
+(* ------------------------------------------------------------------------- *)
+(* Zipping, unzipping etc. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec zip l1 l2 =
+ match (l1,l2) with
+ ([],[]) -> []
+ | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2)
+ | _ -> failwith "zip";;
+
+let rec unzip =
+ function [] -> [],[]
+ | ((a,b)::rest) -> let alist,blist = unzip rest in
+ (a::alist,b::blist);;
+
+(* ------------------------------------------------------------------------- *)
+(* Iterating functions over lists. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec do_list f l =
+ match l with
+ [] -> ()
+ | (h::t) -> (f h; do_list f t);;
+
+(* ------------------------------------------------------------------------- *)
+(* Sorting. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec sort cmp lis =
+ match lis with
+ [] -> []
+ | piv::rest ->
+ let r,l = partition (cmp piv) rest in
+ (sort cmp l) @ (piv::(sort cmp r));;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing adjacent (NB!) equal elements from list. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec uniq l =
+ match l with
+ x::(y::_ as t) -> let t' = uniq t in
+ if x =? y then t' else
+ if t'==t then l else x::t'
+ | _ -> l;;
+
+(* ------------------------------------------------------------------------- *)
+(* Convert list into set by eliminating duplicates. *)
+(* ------------------------------------------------------------------------- *)
+
+let setify s = uniq (sort (<=?) s);;
+
+(* ------------------------------------------------------------------------- *)
+(* Polymorphic finite partial functions via Patricia trees. *)
+(* *)
+(* The point of this strange representation is that it is canonical (equal *)
+(* functions have the same encoding) yet reasonably efficient on average. *)
+(* *)
+(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *)
+(* ------------------------------------------------------------------------- *)
+
+type ('a,'b)func =
+ Empty
+ | Leaf of int * ('a*'b)list
+ | Branch of int * int * ('a,'b)func * ('a,'b)func;;
+
+(* ------------------------------------------------------------------------- *)
+(* Undefined function. *)
+(* ------------------------------------------------------------------------- *)
+
+let undefined = Empty;;
+
+(* ------------------------------------------------------------------------- *)
+(* In case of equality comparison worries, better use this. *)
+(* ------------------------------------------------------------------------- *)
+
+let is_undefined f =
+ match f with
+ Empty -> true
+ | _ -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Operation analagous to "map" for lists. *)
+(* ------------------------------------------------------------------------- *)
+
+let mapf =
+ let rec map_list f l =
+ match l with
+ [] -> []
+ | (x,y)::t -> (x,f(y))::(map_list f t) in
+ let rec mapf f t =
+ match t with
+ Empty -> Empty
+ | Leaf(h,l) -> Leaf(h,map_list f l)
+ | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in
+ mapf;;
+
+(* ------------------------------------------------------------------------- *)
+(* Operations analogous to "fold" for lists. *)
+(* ------------------------------------------------------------------------- *)
+
+let foldl =
+ let rec foldl_list f a l =
+ match l with
+ [] -> a
+ | (x,y)::t -> foldl_list f (f a x y) t in
+ let rec foldl f a t =
+ match t with
+ Empty -> a
+ | Leaf(h,l) -> foldl_list f a l
+ | Branch(p,b,l,r) -> foldl f (foldl f a l) r in
+ foldl;;
+
+let foldr =
+ let rec foldr_list f l a =
+ match l with
+ [] -> a
+ | (x,y)::t -> f x y (foldr_list f t a) in
+ let rec foldr f t a =
+ match t with
+ Empty -> a
+ | Leaf(h,l) -> foldr_list f l a
+ | Branch(p,b,l,r) -> foldr f l (foldr f r a) in
+ foldr;;
+
+(* ------------------------------------------------------------------------- *)
+(* Redefinition and combination. *)
+(* ------------------------------------------------------------------------- *)
+
+let (|->),combine =
+ let ldb x y = let z = x lxor y in z land (-z) in
+ let newbranch p1 t1 p2 t2 =
+ let b = ldb p1 p2 in
+ let p = p1 land (b - 1) in
+ if p1 land b = 0 then Branch(p,b,t1,t2)
+ else Branch(p,b,t2,t1) in
+ let rec define_list (x,y as xy) l =
+ match l with
+ (a,b as ab)::t ->
+ if x =? a then xy::t
+ else if x <? a then xy::l
+ else ab::(define_list xy t)
+ | [] -> [xy]
+ and combine_list op z l1 l2 =
+ match (l1,l2) with
+ [],_ -> l2
+ | _,[] -> l1
+ | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) ->
+ if x1 <? x2 then xy1::(combine_list op z t1 l2)
+ else if x2 <? x1 then xy2::(combine_list op z l1 t2) else
+ let y = op y1 y2 and l = combine_list op z t1 t2 in
+ if z(y) then l else (x1,y)::l in
+ let (|->) x y =
+ let k = Hashtbl.hash x in
+ let rec upd t =
+ match t with
+ Empty -> Leaf (k,[x,y])
+ | Leaf(h,l) ->
+ if h = k then Leaf(h,define_list (x,y) l)
+ else newbranch h t k (Leaf(k,[x,y]))
+ | Branch(p,b,l,r) ->
+ if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y]))
+ else if k land b = 0 then Branch(p,b,upd l,r)
+ else Branch(p,b,l,upd r) in
+ upd in
+ let rec combine op z t1 t2 =
+ match (t1,t2) with
+ Empty,_ -> t2
+ | _,Empty -> t1
+ | Leaf(h1,l1),Leaf(h2,l2) ->
+ if h1 = h2 then
+ let l = combine_list op z l1 l2 in
+ if l = [] then Empty else Leaf(h1,l)
+ else newbranch h1 t1 h2 t2
+ | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) |
+ (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) ->
+ if k land (b - 1) = p then
+ if k land b = 0 then
+ let l' = combine op z lf l in
+ if is_undefined l' then r else Branch(p,b,l',r)
+ else
+ let r' = combine op z lf r in
+ if is_undefined r' then l else Branch(p,b,l,r')
+ else
+ newbranch k lf p br
+ | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) ->
+ if b1 < b2 then
+ if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2
+ else if p2 land b1 = 0 then
+ let l = combine op z l1 t2 in
+ if is_undefined l then r1 else Branch(p1,b1,l,r1)
+ else
+ let r = combine op z r1 t2 in
+ if is_undefined r then l1 else Branch(p1,b1,l1,r)
+ else if b2 < b1 then
+ if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2
+ else if p1 land b2 = 0 then
+ let l = combine op z t1 l2 in
+ if is_undefined l then r2 else Branch(p2,b2,l,r2)
+ else
+ let r = combine op z t1 r2 in
+ if is_undefined r then l2 else Branch(p2,b2,l2,r)
+ else if p1 = p2 then
+ let l = combine op z l1 l2 and r = combine op z r1 r2 in
+ if is_undefined l then r
+ else if is_undefined r then l else Branch(p1,b1,l,r)
+ else
+ newbranch p1 t1 p2 t2 in
+ (|->),combine;;
+
+(* ------------------------------------------------------------------------- *)
+(* Special case of point function. *)
+(* ------------------------------------------------------------------------- *)
+
+let (|=>) = fun x y -> (x |-> y) undefined;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Grab an arbitrary element. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec choose t =
+ match t with
+ Empty -> failwith "choose: completely undefined function"
+ | Leaf(h,l) -> hd l
+ | Branch(b,p,t1,t2) -> choose t1;;
+
+(* ------------------------------------------------------------------------- *)
+(* Application. *)
+(* ------------------------------------------------------------------------- *)
+
+let applyd =
+ let rec apply_listd l d x =
+ match l with
+ (a,b)::t -> if x =? a then b
+ else if x >? a then apply_listd t d x else d x
+ | [] -> d x in
+ fun f d x ->
+ let k = Hashtbl.hash x in
+ let rec look t =
+ match t with
+ Leaf(h,l) when h = k -> apply_listd l d x
+ | Branch(p,b,l,r) -> look (if k land b = 0 then l else r)
+ | _ -> d x in
+ look f;;
+
+let apply f = applyd f (fun x -> failwith "apply");;
+
+let tryapplyd f a d = applyd f (fun x -> d) a;;
+
+let defined f x = try apply f x; true with Failure _ -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Undefinition. *)
+(* ------------------------------------------------------------------------- *)
+
+let undefine =
+ let rec undefine_list x l =
+ match l with
+ (a,b as ab)::t ->
+ if x =? a then t
+ else if x <? a then l else
+ let t' = undefine_list x t in
+ if t' == t then l else ab::t'
+ | [] -> [] in
+ fun x ->
+ let k = Hashtbl.hash x in
+ let rec und t =
+ match t with
+ Leaf(h,l) when h = k ->
+ let l' = undefine_list x l in
+ if l' == l then t
+ else if l' = [] then Empty
+ else Leaf(h,l')
+ | Branch(p,b,l,r) when k land (b - 1) = p ->
+ if k land b = 0 then
+ let l' = und l in
+ if l' == l then t
+ else if is_undefined l' then r
+ else Branch(p,b,l',r)
+ else
+ let r' = und r in
+ if r' == r then t
+ else if is_undefined r' then l
+ else Branch(p,b,l,r')
+ | _ -> t in
+ und;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping to sorted-list representation of the graph, domain and range. *)
+(* ------------------------------------------------------------------------- *)
+
+let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);;
+
+let dom f = setify(foldl (fun a x y -> x::a) [] f);;
+
+let ran f = setify(foldl (fun a x y -> y::a) [] f);;
+
+(* ------------------------------------------------------------------------- *)
+(* Turn a rational into a decimal string with d sig digits. *)
+(* ------------------------------------------------------------------------- *)
+
+let decimalize =
+ let rec normalize y =
+ if abs_num y </ Int 1 // Int 10 then normalize (Int 10 */ y) - 1
+ else if abs_num y >=/ Int 1 then normalize (y // Int 10) + 1
+ else 0 in
+ fun d x ->
+ if x =/ Int 0 then "0.0" else
+ let y = abs_num x in
+ let e = normalize y in
+ let z = pow10(-e) */ y +/ Int 1 in
+ let k = round_num(pow10 d */ z) in
+ (if x </ Int 0 then "-0." else "0.") ^
+ implode(tl(explode(string_of_num k))) ^
+ (if e = 0 then "" else "e"^string_of_int e);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Iterations over numbers, and lists indexed by numbers. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec itern k l f a =
+ match l with
+ [] -> a
+ | h::t -> itern (k + 1) t f (f h k a);;
+
+let rec iter (m,n) f a =
+ if n < m then a
+ else iter (m+1,n) f (f m a);;
+
+(* ------------------------------------------------------------------------- *)
+(* The main types. *)
+(* ------------------------------------------------------------------------- *)
+
+type vector = int*(int,num)func;;
+
+type matrix = (int*int)*(int*int,num)func;;
+
+type monomial = (vname,int)func;;
+
+type poly = (monomial,num)func;;
+
+(* ------------------------------------------------------------------------- *)
+(* Assignment avoiding zeros. *)
+(* ------------------------------------------------------------------------- *)
+
+let (|-->) x y a = if y =/ Int 0 then a else (x |-> y) a;;
+
+(* ------------------------------------------------------------------------- *)
+(* This can be generic. *)
+(* ------------------------------------------------------------------------- *)
+
+let element (d,v) i = tryapplyd v i (Int 0);;
+
+let mapa f (d,v) =
+ d,foldl (fun a i c -> (i |--> f(c)) a) undefined v;;
+
+let is_zero (d,v) =
+ match v with
+ Empty -> true
+ | _ -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Vectors. Conventionally indexed 1..n. *)
+(* ------------------------------------------------------------------------- *)
+
+let vector_0 n = (n,undefined:vector);;
+
+let dim (v:vector) = fst v;;
+
+let vector_const c n =
+ if c =/ Int 0 then vector_0 n
+ else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);;
+
+let vector_1 = vector_const (Int 1);;
+
+let vector_cmul c (v:vector) =
+ let n = dim v in
+ if c =/ Int 0 then vector_0 n
+ else n,mapf (fun x -> c */ x) (snd v);;
+
+let vector_neg (v:vector) = (fst v,mapf minus_num (snd v) :vector);;
+
+let vector_add (v1:vector) (v2:vector) =
+ let m = dim v1 and n = dim v2 in
+ if m <> n then failwith "vector_add: incompatible dimensions" else
+ (n,combine (+/) (fun x -> x =/ Int 0) (snd v1) (snd v2) :vector);;
+
+let vector_sub v1 v2 = vector_add v1 (vector_neg v2);;
+
+let vector_of_list l =
+ let n = length l in
+ (n,itlist2 (|->) (1--n) l undefined :vector);;
+
+(* ------------------------------------------------------------------------- *)
+(* Matrices; again rows and columns indexed from 1. *)
+(* ------------------------------------------------------------------------- *)
+
+let matrix_0 (m,n) = ((m,n),undefined:matrix);;
+
+let dimensions (m:matrix) = fst m;;
+
+let matrix_const c (m,n as mn) =
+ if m <> n then failwith "matrix_const: needs to be square"
+ else if c =/ Int 0 then matrix_0 mn
+ else (mn,itlist (fun k -> (k,k) |-> c) (1--n) undefined :matrix);;
+
+let matrix_1 = matrix_const (Int 1);;
+
+let matrix_cmul c (m:matrix) =
+ let (i,j) = dimensions m in
+ if c =/ Int 0 then matrix_0 (i,j)
+ else (i,j),mapf (fun x -> c */ x) (snd m);;
+
+let matrix_neg (m:matrix) = (dimensions m,mapf minus_num (snd m) :matrix);;
+
+let matrix_add (m1:matrix) (m2:matrix) =
+ let d1 = dimensions m1 and d2 = dimensions m2 in
+ if d1 <> d2 then failwith "matrix_add: incompatible dimensions"
+ else (d1,combine (+/) (fun x -> x =/ Int 0) (snd m1) (snd m2) :matrix);;
+
+let matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2);;
+
+let row k (m:matrix) =
+ let i,j = dimensions m in
+ (j,
+ foldl (fun a (i,j) c -> if i = k then (j |-> c) a else a) undefined (snd m)
+ : vector);;
+
+let column k (m:matrix) =
+ let i,j = dimensions m in
+ (i,
+ foldl (fun a (i,j) c -> if j = k then (i |-> c) a else a) undefined (snd m)
+ : vector);;
+
+let transp (m:matrix) =
+ let i,j = dimensions m in
+ ((j,i),foldl (fun a (i,j) c -> ((j,i) |-> c) a) undefined (snd m) :matrix);;
+
+let diagonal (v:vector) =
+ let n = dim v in
+ ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);;
+
+let matrix_of_list l =
+ let m = length l in
+ if m = 0 then matrix_0 (0,0) else
+ let n = length (hd l) in
+ (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;;
+
+(* ------------------------------------------------------------------------- *)
+(* Monomials. *)
+(* ------------------------------------------------------------------------- *)
+
+let monomial_eval assig (m:monomial) =
+ foldl (fun a x k -> a */ power_num (apply assig x) (Int k))
+ (Int 1) m;;
+
+let monomial_1 = (undefined:monomial);;
+
+let monomial_var x = (x |=> 1 :monomial);;
+
+let (monomial_mul:monomial->monomial->monomial) =
+ combine (+) (fun x -> false);;
+
+let monomial_pow (m:monomial) k =
+ if k = 0 then monomial_1
+ else mapf (fun x -> k * x) m;;
+
+let monomial_divides (m1:monomial) (m2:monomial) =
+ foldl (fun a x k -> tryapplyd m2 x 0 >= k & a) true m1;;
+
+let monomial_div (m1:monomial) (m2:monomial) =
+ let m = combine (+) (fun x -> x = 0) m1 (mapf (fun x -> -x) m2) in
+ if foldl (fun a x k -> k >= 0 & a) true m then m
+ else failwith "monomial_div: non-divisible";;
+
+let monomial_degree x (m:monomial) = tryapplyd m x 0;;
+
+let monomial_lcm (m1:monomial) (m2:monomial) =
+ (itlist (fun x -> x |-> max (monomial_degree x m1) (monomial_degree x m2))
+ (union (dom m1) (dom m2)) undefined :monomial);;
+
+let monomial_multidegree (m:monomial) = foldl (fun a x k -> k + a) 0 m;;
+
+let monomial_variables m = dom m;;
+
+(* ------------------------------------------------------------------------- *)
+(* Polynomials. *)
+(* ------------------------------------------------------------------------- *)
+
+let eval assig (p:poly) =
+ foldl (fun a m c -> a +/ c */ monomial_eval assig m) (Int 0) p;;
+
+let poly_0 = (undefined:poly);;
+
+let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 & a) true p;;
+
+let poly_var x = ((monomial_var x) |=> Int 1 :poly);;
+
+let poly_const c =
+ if c =/ Int 0 then poly_0 else (monomial_1 |=> c);;
+
+let poly_cmul c (p:poly) =
+ if c =/ Int 0 then poly_0
+ else mapf (fun x -> c */ x) p;;
+
+let poly_neg (p:poly) = (mapf minus_num p :poly);;
+
+let poly_add (p1:poly) (p2:poly) =
+ (combine (+/) (fun x -> x =/ Int 0) p1 p2 :poly);;
+
+let poly_sub p1 p2 = poly_add p1 (poly_neg p2);;
+
+let poly_cmmul (c,m) (p:poly) =
+ if c =/ Int 0 then poly_0
+ else if m = monomial_1 then mapf (fun d -> c */ d) p
+ else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p;;
+
+let poly_mul (p1:poly) (p2:poly) =
+ foldl (fun a m c -> poly_add (poly_cmmul (c,m) p2) a) poly_0 p1;;
+
+let poly_div (p1:poly) (p2:poly) =
+ if not(poly_isconst p2) then failwith "poly_div: non-constant" else
+ let c = eval undefined p2 in
+ if c =/ Int 0 then failwith "poly_div: division by zero"
+ else poly_cmul (Int 1 // c) p1;;
+
+let poly_square p = poly_mul p p;;
+
+let rec poly_pow p k =
+ if k = 0 then poly_const (Int 1)
+ else if k = 1 then p
+ else let q = poly_square(poly_pow p (k / 2)) in
+ if k mod 2 = 1 then poly_mul p q else q;;
+
+let poly_exp p1 p2 =
+ if not(poly_isconst p2) then failwith "poly_exp: not a constant" else
+ poly_pow p1 (Num.int_of_num (eval undefined p2));;
+
+let degree x (p:poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p;;
+
+let multidegree (p:poly) =
+ foldl (fun a m c -> max (monomial_multidegree m) a) 0 p;;
+
+let poly_variables (p:poly) =
+ foldr (fun m c -> union (monomial_variables m)) p [];;
+
+(* ------------------------------------------------------------------------- *)
+(* Order monomials for human presentation. *)
+(* ------------------------------------------------------------------------- *)
+
+let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or (x1 = x2 & k1 > k2);;
+
+let humanorder_monomial =
+ let rec ord l1 l2 = match (l1,l2) with
+ _,[] -> true
+ | [],_ -> false
+ | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or (h1 = h2 & ord t1 t2) in
+ fun m1 m2 -> m1 = m2 or
+ ord (sort humanorder_varpow (graph m1))
+ (sort humanorder_varpow (graph m2));;
+
+(* ------------------------------------------------------------------------- *)
+(* Conversions to strings. *)
+(* ------------------------------------------------------------------------- *)
+
+let string_of_vector min_size max_size (v:vector) =
+ let n_raw = dim v in
+ if n_raw = 0 then "[]" else
+ let n = max min_size (min n_raw max_size) in
+ let xs = map ((o) string_of_num (element v)) (1--n) in
+ "[" ^ end_itlist (fun s t -> s ^ ", " ^ t) xs ^
+ (if n_raw > max_size then ", ...]" else "]");;
+
+let string_of_matrix max_size (m:matrix) =
+ let i_raw,j_raw = dimensions m in
+ let i = min max_size i_raw and j = min max_size j_raw in
+ let rstr = map (fun k -> string_of_vector j j (row k m)) (1--i) in
+ "["^end_itlist(fun s t -> s^";\n "^t) rstr ^
+ (if j > max_size then "\n ...]" else "]");;
+
+let string_of_vname (v:vname): string = (v: string);;
+
+let rec string_of_term t =
+ match t with
+ Opp t1 -> "(- " ^ string_of_term t1 ^ ")"
+| Add (t1, t2) ->
+ "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")"
+| Sub (t1, t2) ->
+ "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")"
+| Mul (t1, t2) ->
+ "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")"
+| Inv t1 -> "(/ " ^ string_of_term t1 ^ ")"
+| Div (t1, t2) ->
+ "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")"
+| Pow (t1, n1) ->
+ "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")"
+| Zero -> "0"
+| Var v -> "x" ^ (string_of_vname v)
+| Const x -> string_of_num x;;
+
+
+let string_of_varpow x k =
+ if k = 1 then string_of_vname x else string_of_vname x^"^"^string_of_int k;;
+
+let string_of_monomial m =
+ if m = monomial_1 then "1" else
+ let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a)
+ (sort humanorder_varpow (graph m)) [] in
+ end_itlist (fun s t -> s^"*"^t) vps;;
+
+let string_of_cmonomial (c,m) =
+ if m = monomial_1 then string_of_num c
+ else if c =/ Int 1 then string_of_monomial m
+ else string_of_num c ^ "*" ^ string_of_monomial m;;
+
+let string_of_poly (p:poly) =
+ if p = poly_0 then "<<0>>" else
+ let cms = sort (fun (m1,_) (m2,_) -> humanorder_monomial m1 m2) (graph p) in
+ let s =
+ List.fold_left (fun a (m,c) ->
+ if c </ Int 0 then a ^ " - " ^ string_of_cmonomial(minus_num c,m)
+ else a ^ " + " ^ string_of_cmonomial(c,m))
+ "" cms in
+ let s1 = String.sub s 0 3
+ and s2 = String.sub s 3 (String.length s - 3) in
+ "<<" ^(if s1 = " + " then s2 else "-"^s2)^">>";;
+
+(* ------------------------------------------------------------------------- *)
+(* Printers. *)
+(* ------------------------------------------------------------------------- *)
+
+let print_vector v = Format.print_string(string_of_vector 0 20 v);;
+
+let print_matrix m = Format.print_string(string_of_matrix 20 m);;
+
+let print_monomial m = Format.print_string(string_of_monomial m);;
+
+let print_poly m = Format.print_string(string_of_poly m);;
+
+(*
+#install_printer print_vector;;
+#install_printer print_matrix;;
+#install_printer print_monomial;;
+#install_printer print_poly;;
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* Conversion from term. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec poly_of_term t = match t with
+ Zero -> poly_0
+| Const n -> poly_const n
+| Var x -> poly_var x
+| Opp t1 -> poly_neg (poly_of_term t1)
+| Inv t1 ->
+ let p = poly_of_term t1 in
+ if poly_isconst p then poly_const(Int 1 // eval undefined p)
+ else failwith "poly_of_term: inverse of non-constant polyomial"
+| Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r)
+| Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r)
+| Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r)
+| Div (l, r) ->
+ let p = poly_of_term l and q = poly_of_term r in
+ if poly_isconst q then poly_cmul (Int 1 // eval undefined q) p
+ else failwith "poly_of_term: division by non-constant polynomial"
+| Pow (t, n) ->
+ poly_pow (poly_of_term t) n;;
+
+(* ------------------------------------------------------------------------- *)
+(* String of vector (just a list of space-separated numbers). *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_vector (v:vector) =
+ let n = dim v in
+ let strs = map (o (decimalize 20) (element v)) (1--n) in
+ end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";;
+
+(* ------------------------------------------------------------------------- *)
+(* String for block diagonal matrix numbered k. *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_blockdiagonal k m =
+ let pfx = string_of_int k ^" " in
+ let ents =
+ foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in
+ let entss = sort (increasing fst) ents in
+ itlist (fun ((b,i,j),c) a ->
+ pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
+ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";;
+
+(* ------------------------------------------------------------------------- *)
+(* String for a matrix numbered k, in SDPA sparse format. *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_matrix k (m:matrix) =
+ let pfx = string_of_int k ^ " 1 " in
+ let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a)
+ (snd m) [] in
+ let mss = sort (increasing fst) ms in
+ itlist (fun ((i,j),c) a ->
+ pfx ^ string_of_int i ^ " " ^ string_of_int j ^
+ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";;
+
+(* ------------------------------------------------------------------------- *)
+(* String in SDPA sparse format for standard SDP problem: *)
+(* *)
+(* X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD *)
+(* Minimize obj_1 * v_1 + ... obj_m * v_m *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_problem comment obj mats =
+ let m = length mats - 1
+ and n,_ = dimensions (hd mats) in
+ "\"" ^ comment ^ "\"\n" ^
+ string_of_int m ^ "\n" ^
+ "1\n" ^
+ string_of_int n ^ "\n" ^
+ sdpa_of_vector obj ^
+ itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
+ (1--length mats) mats "";;
+
+(* ------------------------------------------------------------------------- *)
+(* More parser basics. *)
+(* ------------------------------------------------------------------------- *)
+
+exception Noparse;;
+
+
+let isspace,issep,isbra,issymb,isalpha,isnum,isalnum =
+ let charcode s = Char.code(String.get s 0) in
+ let spaces = " \t\n\r"
+ and separators = ",;"
+ and brackets = "()[]{}"
+ and symbs = "\\!@#$%^&*-+|\\<=>/?~.:"
+ and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ and nums = "0123456789" in
+ let allchars = spaces^separators^brackets^symbs^alphas^nums in
+ let csetsize = itlist ((o) max charcode) (explode allchars) 256 in
+ let ctable = Array.make csetsize 0 in
+ do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces);
+ do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators);
+ do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets);
+ do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs);
+ do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas);
+ do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums);
+ let isspace c = Array.get ctable (charcode c) = 1
+ and issep c = Array.get ctable (charcode c) = 2
+ and isbra c = Array.get ctable (charcode c) = 4
+ and issymb c = Array.get ctable (charcode c) = 8
+ and isalpha c = Array.get ctable (charcode c) = 16
+ and isnum c = Array.get ctable (charcode c) = 32
+ and isalnum c = Array.get ctable (charcode c) >= 16 in
+ isspace,issep,isbra,issymb,isalpha,isnum,isalnum;;
+
+let (||) parser1 parser2 input =
+ try parser1 input
+ with Noparse -> parser2 input;;
+
+let (++) parser1 parser2 input =
+ let result1,rest1 = parser1 input in
+ let result2,rest2 = parser2 rest1 in
+ (result1,result2),rest2;;
+
+let rec many prs input =
+ try let result,next = prs input in
+ let results,rest = many prs next in
+ (result::results),rest
+ with Noparse -> [],input;;
+
+let (>>) prs treatment input =
+ let result,rest = prs input in
+ treatment(result),rest;;
+
+let fix err prs input =
+ try prs input
+ with Noparse -> failwith (err ^ " expected");;
+
+let rec listof prs sep err =
+ prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);;
+
+let possibly prs input =
+ try let x,rest = prs input in [x],rest
+ with Noparse -> [],input;;
+
+let some p =
+ function
+ [] -> raise Noparse
+ | (h::t) -> if p h then (h,t) else raise Noparse;;
+
+let a tok = some (fun item -> item = tok);;
+
+let rec atleast n prs i =
+ (if n <= 0 then many prs
+ else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;;
+
+let finished input =
+ if input = [] then 0,input else failwith "Unparsed input";;
+
+let word s =
+ end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t))
+ (map a (explode s));;
+
+let token s =
+ many (some isspace) ++ word s ++ many (some isspace)
+ >> (fun ((_,t),_) -> t);;
+
+let decimal =
+ let numeral = some isnum in
+ let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in
+ let decimalfrac = atleast 1 numeral
+ >> (fun s -> Num.num_of_string(implode s) // pow10 (length s)) in
+ let decimalsig =
+ decimalint ++ possibly (a "." ++ decimalfrac >> snd)
+ >> (function (h,[]) -> h | (h,[x]) -> h +/ x | _ -> failwith "decimalsig") in
+ let signed prs =
+ a "-" ++ prs >> ((o) minus_num snd)
+ || a "+" ++ prs >> snd
+ || prs in
+ let exponent = (a "e" || a "E") ++ signed decimalint >> snd in
+ signed decimalsig ++ possibly exponent
+ >> (function (h,[]) -> h | (h,[x]) -> h */ power_num (Int 10) x | _ ->
+ failwith "exponent");;
+
+let mkparser p s =
+ let x,rst = p(explode s) in
+ if rst = [] then x else failwith "mkparser: unparsed input";;
+
+let parse_decimal = mkparser decimal;;
+
+(* ------------------------------------------------------------------------- *)
+(* Parse back a vector. *)
+(* ------------------------------------------------------------------------- *)
+
+let parse_csdpoutput =
+ let rec skipupto dscr prs inp =
+ (dscr ++ prs >> snd
+ || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in
+ let ignore inp = (),[] in
+ let csdpoutput =
+ (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++
+ (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in
+ mkparser csdpoutput;;
+
+(* ------------------------------------------------------------------------- *)
+(* CSDP parameters; so far I'm sticking with the defaults. *)
+(* ------------------------------------------------------------------------- *)
+
+let csdp_default_parameters =
+"axtol=1.0e-8
+atytol=1.0e-8
+objtol=1.0e-8
+pinftol=1.0e8
+dinftol=1.0e8
+maxiter=100
+minstepfrac=0.9
+maxstepfrac=0.97
+minstepp=1.0e-8
+minstepd=1.0e-8
+usexzgap=1
+tweakgap=0
+affine=0
+printlevel=1
+";;
+
+let csdp_params = csdp_default_parameters;;
+
+(* ------------------------------------------------------------------------- *)
+(* The same thing with CSDP. *)
+(* Modified by the Coq development team to use a cache *)
+(* ------------------------------------------------------------------------- *)
+
+let buffer_add_line buff line =
+ Buffer.add_string buff line; Buffer.add_char buff '\n'
+
+let string_of_file filename =
+ let fd = open_in filename in
+ let buff = Buffer.create 16 in
+ try while true do buffer_add_line buff (input_line fd) done; failwith ""
+ with End_of_file -> (close_in fd; Buffer.contents buff)
+
+let file_of_string filename s =
+ let fd = Pervasives.open_out filename in
+ output_string fd s; close_out fd
+
+let request_mark = "*** REQUEST ***"
+let answer_mark = "*** ANSWER ***"
+let end_mark = "*** END ***"
+let infeasible_mark = "Infeasible\n"
+let failure_mark = "Failure\n"
+
+let cache_name = "csdp.cache"
+
+let look_in_cache string_problem =
+ let n = String.length string_problem in
+ try
+ let inch = open_in cache_name in
+ let rec search () =
+ while input_line inch <> request_mark do () done;
+ let i = ref 0 in
+ while !i < n & string_problem.[!i] = input_char inch do incr i done;
+ if !i < n or input_line inch <> answer_mark then
+ search ()
+ else begin
+ let buff = Buffer.create 16 in
+ let line = ref (input_line inch) in
+ while (!line <> end_mark) do
+ buffer_add_line buff !line; line := input_line inch
+ done;
+ close_in inch;
+ Buffer.contents buff
+ end in
+ try search () with End_of_file -> close_in inch; raise Not_found
+ with Sys_error _ -> raise Not_found
+
+let flush_to_cache string_problem string_result =
+ try
+ let flags = [Open_append;Open_text;Open_creat] in
+ let outch = open_out_gen flags 0o666 cache_name in
+ begin
+ try
+ Printf.fprintf outch "%s\n" request_mark;
+ Printf.fprintf outch "%s" string_problem;
+ Printf.fprintf outch "%s\n" answer_mark;
+ Printf.fprintf outch "%s" string_result;
+ Printf.fprintf outch "%s\n" end_mark;
+ with Sys_error _ as e -> close_out outch; raise e
+ end;
+ close_out outch
+ with Sys_error _ ->
+ print_endline "Warning: Could not open or write to csdp cache"
+
+exception CsdpInfeasible
+
+let run_csdp dbg string_problem =
+ try
+ let res = look_in_cache string_problem in
+ if res = infeasible_mark then raise CsdpInfeasible;
+ if res = failure_mark then failwith "csdp error";
+ res
+ with Not_found ->
+ let input_file = Filename.temp_file "sos" ".dat-s" in
+ let output_file = Filename.temp_file "sos" ".dat-s" in
+ let temp_path = Filename.dirname input_file in
+ let params_file = Filename.concat temp_path "param.csdp" in
+ file_of_string input_file string_problem;
+ file_of_string params_file csdp_params;
+ let rv = Sys.command("cd "^temp_path^"; csdp "^input_file^" "^output_file^
+ (if dbg then "" else "> /dev/null")) in
+ if rv = 1 or rv = 2 then
+ (flush_to_cache string_problem infeasible_mark; raise CsdpInfeasible);
+ if rv = 127 then
+ (print_string "csdp not found, exiting..."; exit 1);
+ if rv <> 0 & rv <> 3 (* reduced accuracy *) then
+ (flush_to_cache string_problem failure_mark;
+ failwith("csdp: error "^string_of_int rv));
+ let string_result = string_of_file output_file in
+ flush_to_cache string_problem string_result;
+ if not dbg then
+ (Sys.remove input_file; Sys.remove output_file; Sys.remove params_file);
+ string_result
+
+let csdp obj mats =
+ try parse_csdpoutput (run_csdp !debugging (sdpa_of_problem "" obj mats))
+ with CsdpInfeasible -> failwith "csdp: Problem is infeasible"
+
+(* ------------------------------------------------------------------------- *)
+(* Try some apparently sensible scaling first. Note that this is purely to *)
+(* get a cleaner translation to floating-point, and doesn't affect any of *)
+(* the results, in principle. In practice it seems a lot better when there *)
+(* are extreme numbers in the original problem. *)
+(* ------------------------------------------------------------------------- *)
+
+let scale_then =
+ let common_denominator amat acc =
+ foldl (fun a m c -> lcm_num (denominator c) a) acc amat
+ and maximal_element amat acc =
+ foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in
+ fun solver obj mats ->
+ let cd1 = itlist common_denominator mats (Int 1)
+ and cd2 = common_denominator (snd obj) (Int 1) in
+ let mats' = map (mapf (fun x -> cd1 */ x)) mats
+ and obj' = vector_cmul cd2 obj in
+ let max1 = itlist maximal_element mats' (Int 0)
+ and max2 = maximal_element (snd obj') (Int 0) in
+ let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0))
+ and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in
+ let mats'' = map (mapf (fun x -> x */ scal1)) mats'
+ and obj'' = vector_cmul scal2 obj' in
+ solver obj'' mats'';;
+
+(* ------------------------------------------------------------------------- *)
+(* Round a vector to "nice" rationals. *)
+(* ------------------------------------------------------------------------- *)
+
+let nice_rational n x = round_num (n */ x) // n;;
+
+let nice_vector n = mapa (nice_rational n);;
+
+(* ------------------------------------------------------------------------- *)
+(* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *)
+(* one tests A [-1;x1;..;xn] >= 0 (i.e. left column is negated constants). *)
+(* ------------------------------------------------------------------------- *)
+
+let linear_program_basic a =
+ let m,n = dimensions a in
+ let mats = map (fun j -> diagonal (column j a)) (1--n)
+ and obj = vector_const (Int 1) m in
+ try ignore (run_csdp false (sdpa_of_problem "" obj mats)); true
+ with CsdpInfeasible -> false
+
+(* ------------------------------------------------------------------------- *)
+(* Test whether a point is in the convex hull of others. Rather than use *)
+(* computational geometry, express as linear inequalities and call CSDP. *)
+(* This is a bit lazy of me, but it's easy and not such a bottleneck so far. *)
+(* ------------------------------------------------------------------------- *)
+
+let in_convex_hull pts pt =
+ let pts1 = (1::pt) :: map (fun x -> 1::x) pts in
+ let pts2 = map (fun p -> map (fun x -> -x) p @ p) pts1 in
+ let n = length pts + 1
+ and v = 2 * (length pt + 1) in
+ let m = v + n - 1 in
+ let mat =
+ (m,n),
+ itern 1 pts2 (fun pts j -> itern 1 pts (fun x i -> (i,j) |-> Int x))
+ (iter (1,n) (fun i -> (v + i,i+1) |-> Int 1) undefined) in
+ linear_program_basic mat;;
+
+(* ------------------------------------------------------------------------- *)
+(* Filter down a set of points to a minimal set with the same convex hull. *)
+(* ------------------------------------------------------------------------- *)
+
+let minimal_convex_hull =
+ let augment1 = function (m::ms) -> if in_convex_hull ms m then ms else ms@[m]
+ | _ -> failwith "augment1"
+ in
+ let augment m ms = funpow 3 augment1 (m::ms) in
+ fun mons ->
+ let mons' = itlist augment (tl mons) [hd mons] in
+ funpow (length mons') augment1 mons';;
+
+(* ------------------------------------------------------------------------- *)
+(* Stuff for "equations" (generic A->num functions). *)
+(* ------------------------------------------------------------------------- *)
+
+let equation_cmul c eq =
+ if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq;;
+
+let equation_add eq1 eq2 = combine (+/) (fun x -> x =/ Int 0) eq1 eq2;;
+
+let equation_eval assig eq =
+ let value v = apply assig v in
+ foldl (fun a v c -> a +/ value(v) */ c) (Int 0) eq;;
+
+(* ------------------------------------------------------------------------- *)
+(* Eliminate among linear equations: return unconstrained variables and *)
+(* assignments for the others in terms of them. We give one pseudo-variable *)
+(* "one" that's used for a constant term. *)
+(* ------------------------------------------------------------------------- *)
+
+
+let eliminate_equations =
+ let rec extract_first p l =
+ match l with
+ [] -> failwith "extract_first"
+ | h::t -> if p(h) then h,t else
+ let k,s = extract_first p t in
+ k,h::s in
+ let rec eliminate vars dun eqs =
+ match vars with
+ [] -> if forall is_undefined eqs then dun
+ else (raise Unsolvable)
+ | v::vs ->
+ try let eq,oeqs = extract_first (fun e -> defined e v) eqs in
+ let a = apply eq v in
+ let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in
+ let elim e =
+ let b = tryapplyd e v (Int 0) in
+ if b =/ Int 0 then e else
+ equation_add e (equation_cmul (minus_num b // a) eq) in
+ eliminate vs ((v |-> eq') (mapf elim dun)) (map elim oeqs)
+ with Failure _ -> eliminate vs dun eqs in
+ fun one vars eqs ->
+ let assig = eliminate vars undefined eqs in
+ let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in
+ setify vs,assig;;
+
+(* ------------------------------------------------------------------------- *)
+(* Eliminate all variables, in an essentially arbitrary order. *)
+(* ------------------------------------------------------------------------- *)
+
+let eliminate_all_equations one =
+ let choose_variable eq =
+ let (v,_) = choose eq in
+ if v = one then
+ let eq' = undefine v eq in
+ if is_undefined eq' then failwith "choose_variable" else
+ let (w,_) = choose eq' in w
+ else v in
+ let rec eliminate dun eqs =
+ match eqs with
+ [] -> dun
+ | eq::oeqs ->
+ if is_undefined eq then eliminate dun oeqs else
+ let v = choose_variable eq in
+ let a = apply eq v in
+ let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in
+ let elim e =
+ let b = tryapplyd e v (Int 0) in
+ if b =/ Int 0 then e else
+ equation_add e (equation_cmul (minus_num b // a) eq) in
+ eliminate ((v |-> eq') (mapf elim dun)) (map elim oeqs) in
+ fun eqs ->
+ let assig = eliminate undefined eqs in
+ let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in
+ setify vs,assig;;
+
+(* ------------------------------------------------------------------------- *)
+(* Solve equations by assigning arbitrary numbers. *)
+(* ------------------------------------------------------------------------- *)
+
+let solve_equations one eqs =
+ let vars,assigs = eliminate_all_equations one eqs in
+ let vfn = itlist (fun v -> (v |-> Int 0)) vars (one |=> Int(-1)) in
+ let ass =
+ combine (+/) (fun c -> false) (mapf (equation_eval vfn) assigs) vfn in
+ if forall (fun e -> equation_eval ass e =/ Int 0) eqs
+ then undefine one ass else raise Sanity;;
+
+(* ------------------------------------------------------------------------- *)
+(* Hence produce the "relevant" monomials: those whose squares lie in the *)
+(* Newton polytope of the monomials in the input. (This is enough according *)
+(* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal, *)
+(* vol 45, pp. 363--374, 1978. *)
+(* *)
+(* These are ordered in sort of decreasing degree. In particular the *)
+(* constant monomial is last; this gives an order in diagonalization of the *)
+(* quadratic form that will tend to display constants. *)
+(* ------------------------------------------------------------------------- *)
+
+let newton_polytope pol =
+ let vars = poly_variables pol in
+ let mons = map (fun m -> map (fun x -> monomial_degree x m) vars) (dom pol)
+ and ds = map (fun x -> (degree x pol + 1) / 2) vars in
+ let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]]
+ and mons' = minimal_convex_hull mons in
+ let all' =
+ filter (fun m -> in_convex_hull mons' (map (fun x -> 2 * x) m)) all in
+ map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a)
+ vars m monomial_1) (rev all');;
+
+(* ------------------------------------------------------------------------- *)
+(* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *)
+(* ------------------------------------------------------------------------- *)
+
+let diag m =
+ let nn = dimensions m in
+ let n = fst nn in
+ if snd nn <> n then failwith "diagonalize: non-square matrix" else
+ let rec diagonalize i m =
+ if is_zero m then [] else
+ let a11 = element m (i,i) in
+ if a11 </ Int 0 then failwith "diagonalize: not PSD"
+ else if a11 =/ Int 0 then
+ if is_zero(row i m) then diagonalize (i + 1) m
+ else failwith "diagonalize: not PSD"
+ else
+ let v = row i m in
+ let v' = mapa (fun a1k -> a1k // a11) v in
+ let m' =
+ (n,n),
+ iter (i+1,n) (fun j ->
+ iter (i+1,n) (fun k ->
+ ((j,k) |--> (element m (j,k) -/ element v j */ element v' k))))
+ undefined in
+ (a11,v')::diagonalize (i + 1) m' in
+ diagonalize 1 m;;
+
+(* ------------------------------------------------------------------------- *)
+(* Adjust a diagonalization to collect rationals at the start. *)
+(* ------------------------------------------------------------------------- *)
+
+let deration d =
+ if d = [] then Int 0,d else
+ let adj(c,l) =
+ let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) //
+ foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in
+ (c // (a */ a)),mapa (fun x -> a */ x) l in
+ let d' = map adj d in
+ let a = itlist ((o) lcm_num ((o) denominator fst)) d' (Int 1) //
+ itlist ((o) gcd_num ((o) numerator fst)) d' (Int 0) in
+ (Int 1 // a),map (fun (c,l) -> (a */ c,l)) d';;
+
+(* ------------------------------------------------------------------------- *)
+(* Enumeration of monomials with given multidegree bound. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec enumerate_monomials d vars =
+ if d < 0 then []
+ else if d = 0 then [undefined]
+ else if vars = [] then [monomial_1] else
+ let alts =
+ map (fun k -> let oths = enumerate_monomials (d - k) (tl vars) in
+ map (fun ks -> if k = 0 then ks else (hd vars |-> k) ks) oths)
+ (0--d) in
+ end_itlist (@) alts;;
+
+(* ------------------------------------------------------------------------- *)
+(* Enumerate products of distinct input polys with degree <= d. *)
+(* We ignore any constant input polynomials. *)
+(* Give the output polynomial and a record of how it was derived. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec enumerate_products d pols =
+ if d = 0 then [poly_const num_1,Rational_lt num_1] else if d < 0 then [] else
+ match pols with
+ [] -> [poly_const num_1,Rational_lt num_1]
+ | (p,b)::ps -> let e = multidegree p in
+ if e = 0 then enumerate_products d ps else
+ enumerate_products d ps @
+ map (fun (q,c) -> poly_mul p q,Product(b,c))
+ (enumerate_products (d - e) ps);;
+
+(* ------------------------------------------------------------------------- *)
+(* Multiply equation-parametrized poly by regular poly and add accumulator. *)
+(* ------------------------------------------------------------------------- *)
+
+let epoly_pmul p q acc =
+ foldl (fun a m1 c ->
+ foldl (fun b m2 e ->
+ let m = monomial_mul m1 m2 in
+ let es = tryapplyd b m undefined in
+ (m |-> equation_add (equation_cmul c e) es) b)
+ a q) acc p;;
+
+(* ------------------------------------------------------------------------- *)
+(* Usual operations on equation-parametrized poly. *)
+(* ------------------------------------------------------------------------- *)
+
+let epoly_cmul c l =
+ if c =/ Int 0 then undefined else mapf (equation_cmul c) l;;
+
+let epoly_neg x = epoly_cmul (Int(-1)) x;;
+
+let epoly_add x = combine equation_add is_undefined x;;
+
+let epoly_sub p q = epoly_add p (epoly_neg q);;
+
+(* ------------------------------------------------------------------------- *)
+(* Convert regular polynomial. Note that we treat (0,0,0) as -1. *)
+(* ------------------------------------------------------------------------- *)
+
+let epoly_of_poly p =
+ foldl (fun a m c -> (m |-> ((0,0,0) |=> minus_num c)) a) undefined p;;
+
+(* ------------------------------------------------------------------------- *)
+(* String for block diagonal matrix numbered k. *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_blockdiagonal k m =
+ let pfx = string_of_int k ^" " in
+ let ents =
+ foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in
+ let entss = sort (increasing fst) ents in
+ itlist (fun ((b,i,j),c) a ->
+ pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
+ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";;
+
+(* ------------------------------------------------------------------------- *)
+(* SDPA for problem using block diagonal (i.e. multiple SDPs) *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_blockproblem comment nblocks blocksizes obj mats =
+ let m = length mats - 1 in
+ "\"" ^ comment ^ "\"\n" ^
+ string_of_int m ^ "\n" ^
+ string_of_int nblocks ^ "\n" ^
+ (end_itlist (fun s t -> s^" "^t) (map string_of_int blocksizes)) ^
+ "\n" ^
+ sdpa_of_vector obj ^
+ itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a)
+ (1--length mats) mats "";;
+
+(* ------------------------------------------------------------------------- *)
+(* Hence run CSDP on a problem in block diagonal form. *)
+(* ------------------------------------------------------------------------- *)
+
+let csdp_blocks nblocks blocksizes obj mats =
+ let string_problem = sdpa_of_blockproblem "" nblocks blocksizes obj mats in
+ try parse_csdpoutput (run_csdp !debugging string_problem)
+ with CsdpInfeasible -> failwith "csdp: Problem is infeasible"
+
+(* ------------------------------------------------------------------------- *)
+(* 3D versions of matrix operations to consider blocks separately. *)
+(* ------------------------------------------------------------------------- *)
+
+let bmatrix_add = combine (+/) (fun x -> x =/ Int 0);;
+
+let bmatrix_cmul c bm =
+ if c =/ Int 0 then undefined
+ else mapf (fun x -> c */ x) bm;;
+
+let bmatrix_neg = bmatrix_cmul (Int(-1));;
+
+let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);;
+
+(* ------------------------------------------------------------------------- *)
+(* Smash a block matrix into components. *)
+(* ------------------------------------------------------------------------- *)
+
+let blocks blocksizes bm =
+ map (fun (bs,b0) ->
+ let m = foldl
+ (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a)
+ undefined bm in
+ (*let d = foldl (fun a (i,j) c -> max a (max i j)) 0 m in*)
+ (((bs,bs),m):matrix))
+ (zip blocksizes (1--length blocksizes));;
+
+(* ------------------------------------------------------------------------- *)
+(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *)
+(* ------------------------------------------------------------------------- *)
+
+let real_positivnullstellensatz_general linf d eqs leqs pol
+ : poly list * (positivstellensatz * (num * poly) list) list =
+
+ let vars = itlist ((o) union poly_variables) (pol::eqs @ map fst leqs) [] in
+ let monoid =
+ if linf then
+ (poly_const num_1,Rational_lt num_1)::
+ (filter (fun (p,c) -> multidegree p <= d) leqs)
+ else enumerate_products d leqs in
+ let nblocks = length monoid in
+ let mk_idmultiplier k p =
+ let e = d - multidegree p in
+ let mons = enumerate_monomials e vars in
+ let nons = zip mons (1--length mons) in
+ mons,
+ itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in
+ let mk_sqmultiplier k (p,c) =
+ let e = (d - multidegree p) / 2 in
+ let mons = enumerate_monomials e vars in
+ let nons = zip mons (1--length mons) in
+ mons,
+ itlist (fun (m1,n1) ->
+ itlist (fun (m2,n2) a ->
+ let m = monomial_mul m1 m2 in
+ if n1 > n2 then a else
+ let c = if n1 = n2 then Int 1 else Int 2 in
+ let e = tryapplyd a m undefined in
+ (m |-> equation_add ((k,n1,n2) |=> c) e) a)
+ nons)
+ nons undefined in
+ let sqmonlist,sqs = unzip(map2 mk_sqmultiplier (1--length monoid) monoid)
+ and idmonlist,ids = unzip(map2 mk_idmultiplier (1--length eqs) eqs) in
+ let blocksizes = map length sqmonlist in
+ let bigsum =
+ itlist2 (fun p q a -> epoly_pmul p q a) eqs ids
+ (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs
+ (epoly_of_poly(poly_neg pol))) in
+ let eqns = foldl (fun a m e -> e::a) [] bigsum in
+ let pvs,assig = eliminate_all_equations (0,0,0) eqns in
+ let qvars = (0,0,0)::pvs in
+ let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in
+ let mk_matrix v =
+ foldl (fun m (b,i,j) ass -> if b < 0 then m else
+ let c = tryapplyd ass v (Int 0) in
+ if c =/ Int 0 then m else
+ ((b,j,i) |-> c) (((b,i,j) |-> c) m))
+ undefined allassig in
+ let diagents = foldl
+ (fun a (b,i,j) e -> if b > 0 & i = j then equation_add e a else a)
+ undefined allassig in
+ let mats = map mk_matrix qvars
+ and obj = length pvs,
+ itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
+ undefined in
+ let raw_vec = if pvs = [] then vector_0 0
+ else scale_then (csdp_blocks nblocks blocksizes) obj mats in
+ let find_rounding d =
+ (if !debugging then
+ (Format.print_string("Trying rounding with limit "^string_of_num d);
+ Format.print_newline())
+ else ());
+ let vec = nice_vector d raw_vec in
+ let blockmat = iter (1,dim vec)
+ (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a)
+ (bmatrix_neg (el 0 mats)) in
+ let allmats = blocks blocksizes blockmat in
+ vec,map diag allmats in
+ let vec,ratdias =
+ if pvs = [] then find_rounding num_1
+ else tryfind find_rounding (map Num.num_of_int (1--31) @
+ map pow2 (5--66)) in
+ let newassigs =
+ itlist (fun k -> el (k - 1) pvs |-> element vec k)
+ (1--dim vec) ((0,0,0) |=> Int(-1)) in
+ let finalassigs =
+ foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs
+ allassig in
+ let poly_of_epoly p =
+ foldl (fun a v e -> (v |--> equation_eval finalassigs e) a)
+ undefined p in
+ let mk_sos mons =
+ let mk_sq (c,m) =
+ c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a)
+ (1--length mons) undefined in
+ map mk_sq in
+ let sqs = map2 mk_sos sqmonlist ratdias
+ and cfs = map poly_of_epoly ids in
+ let msq = filter (fun (a,b) -> b <> []) (map2 (fun a b -> a,b) monoid sqs) in
+ let eval_sq sqs = itlist
+ (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in
+ let sanity =
+ itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq
+ (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs
+ (poly_neg pol)) in
+ if not(is_undefined sanity) then raise Sanity else
+ cfs,map (fun (a,b) -> snd a,b) msq;;
+
+
+let term_of_monoid l1 m = itlist (fun i m -> Mul (nth l1 i,m)) m (Const num_1)
+
+let rec term_of_pos l1 x = match x with
+ Axiom_eq i -> failwith "term_of_pos"
+ | Axiom_le i -> nth l1 i
+ | Axiom_lt i -> nth l1 i
+ | Monoid m -> term_of_monoid l1 m
+ | Rational_eq n -> Const n
+ | Rational_le n -> Const n
+ | Rational_lt n -> Const n
+ | Square t -> Pow (t, 2)
+ | Eqmul (t, y) -> Mul (t, term_of_pos l1 y)
+ | Sum (y, z) -> Add (term_of_pos l1 y, term_of_pos l1 z)
+ | Product (y, z) -> Mul (term_of_pos l1 y, term_of_pos l1 z);;
+
+
+let dest_monomial mon = sort (increasing fst) (graph mon);;
+
+let monomial_order =
+ let rec lexorder l1 l2 =
+ match (l1,l2) with
+ [],[] -> true
+ | vps,[] -> false
+ | [],vps -> true
+ | ((x1,n1)::vs1),((x2,n2)::vs2) ->
+ if x1 < x2 then true
+ else if x2 < x1 then false
+ else if n1 < n2 then false
+ else if n2 < n1 then true
+ else lexorder vs1 vs2 in
+ fun m1 m2 ->
+ if m2 = monomial_1 then true else if m1 = monomial_1 then false else
+ let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in
+ let deg1 = itlist ((o) (+) snd) mon1 0
+ and deg2 = itlist ((o) (+) snd) mon2 0 in
+ if deg1 < deg2 then false else if deg1 > deg2 then true
+ else lexorder mon1 mon2;;
+
+let dest_poly p =
+ map (fun (m,c) -> c,dest_monomial m)
+ (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));;
+
+(* ------------------------------------------------------------------------- *)
+(* Map back polynomials and their composites to term. *)
+(* ------------------------------------------------------------------------- *)
+
+let term_of_varpow =
+ fun x k ->
+ if k = 1 then Var x else Pow (Var x, k);;
+
+let term_of_monomial =
+ fun m -> if m = monomial_1 then Const num_1 else
+ let m' = dest_monomial m in
+ let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in
+ end_itlist (fun s t -> Mul (s,t)) vps;;
+
+let term_of_cmonomial =
+ fun (m,c) ->
+ if m = monomial_1 then Const c
+ else if c =/ num_1 then term_of_monomial m
+ else Mul (Const c,term_of_monomial m);;
+
+let term_of_poly =
+ fun p ->
+ if p = poly_0 then Zero else
+ let cms = map term_of_cmonomial
+ (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in
+ end_itlist (fun t1 t2 -> Add (t1,t2)) cms;;
+
+let term_of_sqterm (c,p) =
+ Product(Rational_lt c,Square(term_of_poly p));;
+
+let term_of_sos (pr,sqs) =
+ if sqs = [] then pr
+ else Product(pr,end_itlist (fun a b -> Sum(a,b)) (map term_of_sqterm sqs));;
+
+let rec deepen f n =
+ try (*print_string "Searching with depth limit ";
+ print_int n; print_newline();*) f n
+ with Failure _ -> deepen f (n + 1);;
+
+
+
+
+
+exception TooDeep
+
+let deepen_until limit f n =
+ match compare limit 0 with
+ | 0 -> raise TooDeep
+ | -1 -> deepen f n
+ | _ ->
+ let rec d_until f n =
+ try if !debugging
+ then (print_string "Searching with depth limit ";
+ print_int n; print_newline()) ; f n
+ with Failure x ->
+ if !debugging then (Printf.printf "solver error : %s\n" x) ;
+ if n = limit then raise TooDeep else d_until f (n + 1) in
+ d_until f n
+
+
+(* patch to remove zero polynomials from equalities.
+ In this case, hol light loops *)
+
+let real_nonlinear_prover depthmax eqs les lts =
+ let eq = map poly_of_term eqs
+ and le = map poly_of_term les
+ and lt = map poly_of_term lts in
+ let pol = itlist poly_mul lt (poly_const num_1)
+ and lep = map (fun (t,i) -> t,Axiom_le i) (zip le (0--(length le - 1)))
+ and ltp = map (fun (t,i) -> t,Axiom_lt i) (zip lt (0--(length lt - 1)))
+ and eqp = itlist2 (fun t i res ->
+ if t = undefined then res else (t,Axiom_eq i)::res) eq (0--(length eq - 1)) []
+ in
+
+ let proof =
+ let leq = lep @ ltp in
+ let eq = List.map fst eqp in
+ let tryall d =
+ let e = multidegree pol (*and pol' = poly_neg pol*) in
+ let k = if e = 0 then 1 else d / e in
+ tryfind (fun i -> d,i,
+ real_positivnullstellensatz_general false d eq leq
+ (poly_neg(poly_pow pol i)))
+ (0--k) in
+ let d,i,(cert_ideal,cert_cone) = deepen_until depthmax tryall 0 in
+ let proofs_ideal =
+ map2 (fun q i -> Eqmul(term_of_poly q,i))
+ cert_ideal (List.map snd eqp)
+ and proofs_cone = map term_of_sos cert_cone
+ and proof_ne =
+ if lt = [] then Rational_lt num_1 else
+ let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in
+ funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in
+ end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in
+ if !debugging then (print_string("Translating proof certificate to Coq"); print_newline());
+ proof;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Now pure SOS stuff. *)
+(* ------------------------------------------------------------------------- *)
+
+(* ------------------------------------------------------------------------- *)
+(* Some combinatorial helper functions. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec allpermutations l =
+ if l = [] then [[]] else
+ itlist (fun h acc -> map (fun t -> h::t)
+ (allpermutations (subtract l [h])) @ acc) l [];;
+
+let allvarorders l =
+ map (fun vlis x -> index x vlis) (allpermutations l);;
+
+let changevariables_monomial zoln (m:monomial) =
+ foldl (fun a x k -> (assoc x zoln |-> k) a) monomial_1 m;;
+
+let changevariables zoln pol =
+ foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a)
+ poly_0 pol;;
+
+(* ------------------------------------------------------------------------- *)
+(* Sum-of-squares function with some lowbrow symmetry reductions. *)
+(* ------------------------------------------------------------------------- *)
+
+let sumofsquares_general_symmetry tool pol =
+ let vars = poly_variables pol
+ and lpps = newton_polytope pol in
+ let n = length lpps in
+ let sym_eqs =
+ let invariants = filter
+ (fun vars' ->
+ is_undefined(poly_sub pol (changevariables (zip vars vars') pol)))
+ (allpermutations vars) in
+(* let lpps2 = allpairs monomial_mul lpps lpps in*)
+(* let lpp2_classes =
+ setify(map (fun m ->
+ setify(map (fun vars' -> changevariables_monomial (zip vars vars') m)
+ invariants)) lpps2) in *)
+ let lpns = zip lpps (1--length lpps) in
+ let lppcs =
+ filter (fun (m,(n1,n2)) -> n1 <= n2)
+ (allpairs
+ (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in
+ let clppcs = end_itlist (@)
+ (map (fun ((m1,m2),(n1,n2)) ->
+ map (fun vars' ->
+ (changevariables_monomial (zip vars vars') m1,
+ changevariables_monomial (zip vars vars') m2),(n1,n2))
+ invariants)
+ lppcs) in
+ let clppcs_dom = setify(map fst clppcs) in
+ let clppcs_cls = map (fun d -> filter (fun (e,_) -> e = d) clppcs)
+ clppcs_dom in
+ let eqvcls = map (o setify (map snd)) clppcs_cls in
+ let mk_eq cls acc =
+ match cls with
+ [] -> raise Sanity
+ | [h] -> acc
+ | h::t -> map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in
+ itlist mk_eq eqvcls [] in
+ let eqs = foldl (fun a x y -> y::a) []
+ (itern 1 lpps (fun m1 n1 ->
+ itern 1 lpps (fun m2 n2 f ->
+ let m = monomial_mul m1 m2 in
+ if n1 > n2 then f else
+ let c = if n1 = n2 then Int 1 else Int 2 in
+ (m |-> ((n1,n2) |-> c) (tryapplyd f m undefined)) f))
+ (foldl (fun a m c -> (m |-> ((0,0)|=>c)) a)
+ undefined pol)) @
+ sym_eqs in
+ let pvs,assig = eliminate_all_equations (0,0) eqs in
+ let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in
+ let qvars = (0,0)::pvs in
+ let diagents =
+ end_itlist equation_add (map (fun i -> apply allassig (i,i)) (1--n)) in
+ let mk_matrix v =
+ ((n,n),
+ foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in
+ if c =/ Int 0 then m else
+ ((j,i) |-> c) (((i,j) |-> c) m))
+ undefined allassig :matrix) in
+ let mats = map mk_matrix qvars
+ and obj = length pvs,
+ itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
+ undefined in
+ let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in
+ let find_rounding d =
+ (if !debugging then
+ (Format.print_string("Trying rounding with limit "^string_of_num d);
+ Format.print_newline())
+ else ());
+ let vec = nice_vector d raw_vec in
+ let mat = iter (1,dim vec)
+ (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a)
+ (matrix_neg (el 0 mats)) in
+ deration(diag mat) in
+ let rat,dia =
+ if pvs = [] then
+ let mat = matrix_neg (el 0 mats) in
+ deration(diag mat)
+ else
+ tryfind find_rounding (map Num.num_of_int (1--31) @
+ map pow2 (5--66)) in
+ let poly_of_lin(d,v) =
+ d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in
+ let lins = map poly_of_lin dia in
+ let sqs = map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in
+ let sos = poly_cmul rat (end_itlist poly_add sqs) in
+ if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;;
+
+let (sumofsquares: poly -> Num.num * (( Num.num * poly) list)) =
+sumofsquares_general_symmetry csdp;;
diff --git a/contrib/micromega/sos.mli b/contrib/micromega/sos.mli
new file mode 100644
index 00000000..31c9518c
--- /dev/null
+++ b/contrib/micromega/sos.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+
+type vname = string;;
+
+type term =
+| Zero
+| Const of Num.num
+| Var of vname
+| Inv of term
+| Opp of term
+| Add of (term * term)
+| Sub of (term * term)
+| Mul of (term * term)
+| Div of (term * term)
+| Pow of (term * int)
+
+type positivstellensatz =
+ Axiom_eq of int
+ | Axiom_le of int
+ | Axiom_lt of int
+ | Rational_eq of Num.num
+ | Rational_le of Num.num
+ | Rational_lt of Num.num
+ | Square of term
+ | Monoid of int list
+ | Eqmul of term * positivstellensatz
+ | Sum of positivstellensatz * positivstellensatz
+ | Product of positivstellensatz * positivstellensatz
+
+type poly
+
+val poly_isconst : poly -> bool
+
+val poly_neg : poly -> poly
+
+val poly_mul : poly -> poly -> poly
+
+val poly_pow : poly -> int -> poly
+
+val poly_const : Num.num -> poly
+
+val poly_of_term : term -> poly
+
+val term_of_poly : poly -> term
+
+val term_of_sos : positivstellensatz * (Num.num * poly) list ->
+ positivstellensatz
+
+val string_of_poly : poly -> string
+
+exception TooDeep
+
+val deepen_until : int -> (int -> 'a) -> int -> 'a
+
+val real_positivnullstellensatz_general : bool -> int -> poly list ->
+ (poly * positivstellensatz) list ->
+ poly -> poly list * (positivstellensatz * (Num.num * poly) list) list
+
+val sumofsquares : poly -> Num.num * ( Num.num * poly) list
diff --git a/contrib/micromega/vector.ml b/contrib/micromega/vector.ml
new file mode 100644
index 00000000..fee4ebfc
--- /dev/null
+++ b/contrib/micromega/vector.ml
@@ -0,0 +1,674 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+open Num
+
+module type S =
+sig
+ type t
+
+ val fresh : t -> int
+
+ val null : t
+
+ val is_null : t -> bool
+
+ val get : int -> t -> num
+
+ val update : int -> (num -> num) -> t -> t
+ (* behaviour is undef if index < 0 -- might loop*)
+
+ val set : int -> num -> t -> t
+
+ (*
+ For efficiency...
+
+ val get_update : int -> (num -> num) -> t -> num * t
+ *)
+
+ val mul : num -> t -> t
+
+ val uminus : t -> t
+
+ val add : t -> t -> t
+
+ val dotp : t -> t -> num
+
+ val lin_comb : num -> t -> num -> t -> t
+ (* lin_comb n1 t1 n2 t2 = (n1 * t1) + (n2 * t2) *)
+
+ val gcd : t -> Big_int.big_int
+
+ val normalise : t -> num * t
+
+ val hash : t -> int
+
+ val compare : t -> t -> int
+
+ type it
+
+ val iterator : t -> it
+ val element : it -> (num*it) option
+
+ val string : t -> string
+
+ type status = Pos | Neg
+
+ (* the result list is ordered by fst *)
+ val status : t -> (int * status) list
+
+ val from_list : num list -> t
+ val to_list : t -> num list
+
+end
+
+
+module type SystemS =
+sig
+
+ module Vect : S
+
+ module Cstr :
+ sig
+ type kind = Eq | Ge
+ val string_of_kind : kind -> string
+ type cstr = {coeffs : Vect.t ; op : kind ; cst : num}
+ val string_of_cstr : cstr -> string
+ val compare : cstr -> cstr -> int
+ end
+ open Cstr
+
+
+ module CstrBag :
+ sig
+ type t
+ exception Contradiction
+
+ val empty : t
+
+ val is_empty : t -> bool
+
+ val add : cstr -> t -> t
+ (* c can be deduced from add c t *)
+
+ val find : (cstr -> bool) -> t -> cstr option
+
+ val fold : (cstr -> 'a -> 'a) -> t -> 'a -> 'a
+
+ val status : t -> (int * (int list * int list)) list
+ (* aggregate of vector statuses *)
+
+ val remove : cstr -> t -> t
+
+ (* remove_list the ith element -- it is the ith element visited by 'fold' *)
+
+ val split : (cstr -> int) -> t -> (int -> t)
+
+ type it
+ val iterator : t -> it
+ val element : it -> (cstr*it) option
+
+ end
+
+end
+
+let zero_num = Int 0
+let unit_num = Int 1
+
+
+
+
+module Cstr(V:S) =
+struct
+ type kind = Eq | Ge
+ let string_of_kind = function Eq -> "Eq" | Ge -> "Ge"
+
+ type cstr = {coeffs : V.t ; op : kind ; cst : num}
+
+ let string_of_cstr {coeffs =a ; op = b ; cst =c} =
+ Printf.sprintf "{coeffs = %s;op=%s;cst=%s}" (V.string a) (string_of_kind b) (string_of_num c)
+
+ type t = cstr
+ let compare
+ {coeffs = v1 ; op = op1 ; cst = c1}
+ {coeffs = v2 ; op = op2 ; cst = c2} =
+ Mutils.Cmp.compare_lexical [
+ (fun () -> V.compare v1 v2);
+ (fun () -> Pervasives.compare op1 op2);
+ (fun () -> compare_num c1 c2)
+ ]
+
+
+end
+
+
+
+module VList : S with type t = num list =
+struct
+ type t = num list
+
+ let fresh l = failwith "not implemented"
+
+ let null = []
+
+ let is_null = List.for_all ((=/) zero_num)
+
+ let normalise l = failwith "Not implemented"
+ (*match l with (* Buggy : What if the first num is zero! *)
+ | [] -> (Int 0,[])
+ | [n] -> (n,[Int 1])
+ | n::l -> (n, (Int 1) :: List.map (fun x -> x // n) l)
+ *)
+
+
+ let get i l = try List.nth l i with _ -> zero_num
+
+ (* This is not tail-recursive *)
+ let rec update i f t =
+ match t with
+ | [] -> if i = 0 then [f zero_num] else (zero_num)::(update (i-1) f [])
+ | e::t -> if i = 0 then (f e)::t else e::(update (i-1) f t)
+
+ let rec set i n t =
+ match t with
+ | [] -> if i = 0 then [n] else (zero_num)::(set (i-1) n [])
+ | e::t -> if i = 0 then (n)::t else e::(set (i-1) n t)
+
+
+
+
+ let rec mul z t =
+ match z with
+ | Int 0 -> null
+ | Int 1 -> t
+ | _ -> List.map (mult_num z) t
+
+ let uminus t = mul (Int (-1)) t
+
+ let rec add t1 t2 =
+ match t1,t2 with
+ | [], _ -> t2
+ | _ , [] -> t1
+ | e1::t1,e2::t2 -> (e1 +/ e2 )::(add t1 t2)
+
+ let dotp t1 t2 =
+ let rec _dotp t1 t2 acc =
+ match t1, t2 with
+ | [] , _ -> acc
+ | _ , [] -> acc
+ | e1::t1,e2::t2 -> _dotp t1 t2 (acc +/ (e1 */ e2)) in
+ _dotp t1 t2 zero_num
+
+ let add_mul n t1 t2 =
+ match n with
+ | Int 0 -> t2
+ | Int 1 -> add t1 t2
+ | _ ->
+ let rec _add_mul t1 t2 =
+ match t1,t2 with
+ | [], _ -> t2
+ | _ , [] -> mul n t1
+ | e1::t1,e2::t2 -> ( (n */e1) +/ e2 )::(_add_mul t1 t2) in
+ _add_mul t1 t2
+
+ let lin_comb n1 t1 n2 t2 =
+ match n1,n2 with
+ | Int 0 , _ -> mul n2 t2
+ | Int 1 , _ -> add_mul n2 t2 t1
+ | _ , Int 0 -> mul n1 t1
+ | _ , Int 1 -> add_mul n1 t1 t2
+ | _ ->
+ let rec _lin_comb t1 t2 =
+ match t1,t2 with
+ | [], _ -> mul n2 t2
+ | _ , [] -> mul n1 t1
+ | e1::t1,e2::t2 -> ( (n1 */e1) +/ (n2 */ e2 ))::(_lin_comb t1 t2) in
+ _lin_comb t1 t2
+
+ (* could be computed on the fly *)
+ let gcd t =Mutils.gcd_list t
+
+
+
+
+ let hash = Mutils.Cmp.hash_list int_of_num
+
+ let compare = Mutils.Cmp.compare_list compare_num
+
+ type it = t
+ let iterator (x:t) : it = x
+ let element it =
+ match it with
+ | [] -> None
+ | e::l -> Some (e,l)
+
+ (* TODO: Buffer! *)
+ let string l = List.fold_right (fun n s -> (string_of_num n)^";"^s) l ""
+
+ type status = Pos | Neg
+
+ let status l =
+ let rec xstatus i l =
+ match l with
+ | [] -> []
+ | e::l ->
+ begin
+ match compare_num e (Int 0) with
+ | 1 -> (i,Pos):: (xstatus (i+1) l)
+ | 0 -> xstatus (i+1) l
+ | -1 -> (i,Neg) :: (xstatus (i+1) l)
+ | _ -> assert false
+ end in
+ xstatus 0 l
+
+ let from_list l = l
+ let to_list l = l
+
+end
+
+module VMap : S =
+struct
+ module Map = Map.Make(struct type t = int let compare (x:int) (y:int) = Pervasives.compare x y end)
+
+ type t = num Map.t
+
+ let null = Map.empty
+
+ let fresh m = failwith "not implemented"
+
+ let is_null = Map.is_empty
+
+ let normalise m = failwith "Not implemented"
+
+
+
+ let get i l = try Map.find i l with _ -> zero_num
+
+ let update i f t =
+ try
+ let res = f (Map.find i t) in
+ if res =/ zero_num
+ then Map.remove i t
+ else Map.add i res t
+ with
+ Not_found ->
+ let res = f zero_num in
+ if res =/ zero_num then t else Map.add i res t
+
+ let set i n t =
+ if n =/ zero_num then Map.remove i t
+ else Map.add i n t
+
+
+ let rec mul z t =
+ match z with
+ | Int 0 -> null
+ | Int 1 -> t
+ | _ -> Map.map (mult_num z) t
+
+ let uminus t = mul (Int (-1)) t
+
+
+ let map2 f m1 m2 =
+ let res,m2' =
+ Map.fold (fun k e (res,m2) ->
+ let v = f e (get k m2) in
+ if v =/ zero_num
+ then (res,Map.remove k m2)
+ else (Map.add k v res,Map.remove k m2)) m1 (Map.empty,m2) in
+ Map.fold (fun k e res ->
+ let v = f zero_num e in
+ if v =/ zero_num
+ then res else Map.add k v res) m2' res
+
+ let add t1 t2 = map2 (+/) t1 t2
+
+
+ let dotp t1 t2 =
+ Map.fold (fun k e res ->
+ res +/ (e */ get k t2)) t1 zero_num
+
+
+
+ let add_mul n t1 t2 =
+ match n with
+ | Int 0 -> t2
+ | Int 1 -> add t1 t2
+ | _ -> map2 (fun x y -> (n */ x) +/ y) t1 t2
+
+ let lin_comb n1 t1 n2 t2 =
+ match n1,n2 with
+ | Int 0 , _ -> mul n2 t2
+ | Int 1 , _ -> add_mul n2 t2 t1
+ | _ , Int 0 -> mul n1 t1
+ | _ , Int 1 -> add_mul n1 t1 t2
+ | _ -> map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2
+
+
+ let hash map = Map.fold (fun k e res -> k lxor (int_of_num e) lxor res) map 0
+
+ let compare = Map.compare compare_num
+
+ type it = t * int
+
+ let iterator (x:t) : it = (x,0)
+
+ let element (mp,id) =
+ try
+ Some (Map.find id mp, (mp, id+1))
+ with
+ Not_found -> None
+
+ (* TODO: Buffer! *)
+ type status = Pos | Neg
+
+ let status l = Map.fold (fun k e l ->
+ match compare_num e (Int 0) with
+ | 1 -> (k,Pos)::l
+ | 0 -> l
+ | -1 -> (k,Neg) :: l
+ | _ -> assert false) l []
+ let from_list l =
+ let rec from_list i l map =
+ match l with
+ | [] -> map
+ | e::l -> from_list (i+1) l (if e <>/ Int 0 then Map.add i e map else map) in
+ from_list 0 l Map.empty
+
+ let gcd m =
+ let res = Map.fold (fun _ e x -> Big_int.gcd_big_int x (Mutils.numerator e)) m Big_int.zero_big_int in
+ if Big_int.compare_big_int res Big_int.zero_big_int = 0
+ then Big_int.unit_big_int else res
+
+
+ let to_list m =
+ let l = List.rev (Map.fold (fun k e l -> (k,e)::l) m []) in
+ let rec xto_list i l =
+ match l with
+ | [] -> []
+ | (x,v)::l' -> if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in
+ xto_list 0 l
+
+ let string l = VList.string (to_list l)
+
+
+end
+
+
+module VSparse : S =
+struct
+
+ type t = (int*num) list
+
+ let null = []
+
+ let fresh l = List.fold_left (fun acc (i,_) -> max (i+1) acc) 0 l
+
+ let is_null l = l = []
+
+ let rec is_sorted l =
+ match l with
+ | [] -> true
+ | [e] -> true
+ | (i,_)::(j,x)::l -> i < j && is_sorted ((j,x)::l)
+
+
+ let check l = (List.for_all (fun (_,n) -> compare_num n (Int 0) <> 0) l) && (is_sorted l)
+
+ (* let get i t =
+ assert (check t);
+ try List.assoc i t with Not_found -> zero_num *)
+
+ let rec get (i:int) t =
+ match t with
+ | [] -> zero_num
+ | (j,n)::t ->
+ match compare i j with
+ | 0 -> n
+ | 1 -> get i t
+ | _ -> zero_num
+
+ let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst
+
+ let rec update i f t =
+ match t with
+ | [] -> cons i (f zero_num) []
+ | (k,v)::l ->
+ match Pervasives.compare i k with
+ | 0 -> cons k (f v) l
+ | -1 -> cons i (f zero_num) t
+ | 1 -> (k,v) ::(update i f l)
+ | _ -> failwith "compare_num"
+
+ let update i f t =
+ assert (check t);
+ let res = update i f t in
+ assert (check t) ; res
+
+
+ let rec set i n t =
+ match t with
+ | [] -> cons i n []
+ | (k,v)::l ->
+ match Pervasives.compare i k with
+ | 0 -> cons k n l
+ | -1 -> cons i n t
+ | 1 -> (k,v) :: (set i n l)
+ | _ -> failwith "compare_num"
+
+
+ let rec map f l =
+ match l with
+ | [] -> []
+ | (i,e)::l -> cons i (f e) (map f l)
+
+ let rec mul z t =
+ match z with
+ | Int 0 -> null
+ | Int 1 -> t
+ | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t
+
+ let mul z t =
+ assert (check t) ;
+ let res = mul z t in
+ assert (check res) ;
+ res
+
+ let uminus t = mul (Int (-1)) t
+
+
+ let normalise l =
+ match l with
+ | [] -> (Int 0,[])
+ | (i,n)::_ -> (n, mul ((Int 1) // n) l)
+
+
+ let rec map2 f m1 m2 =
+ match m1, m2 with
+ | [] , [] -> []
+ | l , [] -> map (fun x -> f x zero_num) l
+ | [] ,l -> map (f zero_num) l
+ | (i,e)::l1,(i',e')::l2 ->
+ match Pervasives.compare i i' with
+ | 0 -> cons i (f e e') (map2 f l1 l2)
+ | -1 -> cons i (f e zero_num) (map2 f l1 m2)
+ | 1 -> cons i' (f zero_num e') (map2 f m1 l2)
+ | _ -> assert false
+
+ (* let add t1 t2 = map2 (+/) t1 t2*)
+
+ let rec add (m1:t) (m2:t) =
+ match m1, m2 with
+ | [] , [] -> []
+ | l , [] -> l
+ | [] ,l -> l
+ | (i,e)::l1,(i',e')::l2 ->
+ match Pervasives.compare i i' with
+ | 0 -> cons i ( e +/ e') (add l1 l2)
+ | -1 -> (i,e) :: (add l1 m2)
+ | 1 -> (i', e') :: (add m1 l2)
+ | _ -> assert false
+
+
+
+
+ let add t1 t2 =
+ assert (check t1 && check t2);
+ let res = add t1 t2 in
+ assert (check res);
+ res
+
+
+ let rec dotp (t1:t) (t2:t) =
+ match t1, t2 with
+ | [] , _ -> zero_num
+ | _ , [] -> zero_num
+ | (i,e)::l1 , (i',e')::l2 ->
+ match Pervasives.compare i i' with
+ | 0 -> (e */ e') +/ (dotp l1 l2)
+ | -1 -> dotp l1 t2
+ | 1 -> dotp t1 l2
+ | _ -> assert false
+
+ let dotp t1 t2 =
+ assert (check t1 && check t2) ; dotp t1 t2
+
+ let add_mul n t1 t2 =
+ match n with
+ | Int 0 -> t2
+ | Int 1 -> add t1 t2
+ | _ -> map2 (fun x y -> (n */ x) +/ y) t1 t2
+
+ let add_mul n (t1:t) (t2:t) =
+ match n with
+ | Int 0 -> t2
+ | Int 1 -> add t1 t2
+ | _ ->
+ let rec xadd_mul m1 m2 =
+ match m1, m2 with
+ | [] , [] -> []
+ | _ , [] -> mul n m1
+ | [] , _ -> m2
+ | (i,e)::l1,(i',e')::l2 ->
+ match Pervasives.compare i i' with
+ | 0 -> cons i ( n */ e +/ e') (xadd_mul l1 l2)
+ | -1 -> (i,n */ e) :: (xadd_mul l1 m2)
+ | 1 -> (i', e') :: (xadd_mul m1 l2)
+ | _ -> assert false in
+ xadd_mul t1 t2
+
+
+
+
+ let lin_comb n1 t1 n2 t2 =
+ match n1,n2 with
+ | Int 0 , _ -> mul n2 t2
+ | Int 1 , _ -> add_mul n2 t2 t1
+ | _ , Int 0 -> mul n1 t1
+ | _ , Int 1 -> add_mul n1 t1 t2
+ | _ -> (*map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2*)
+ let rec xlin_comb m1 m2 =
+ match m1, m2 with
+ | [] , [] -> []
+ | _ , [] -> mul n1 m1
+ | [] , _ -> mul n2 m2
+ | (i,e)::l1,(i',e')::l2 ->
+ match Pervasives.compare i i' with
+ | 0 -> cons i ( n1 */ e +/ n2 */ e') (xlin_comb l1 l2)
+ | -1 -> (i,n1 */ e) :: (xlin_comb l1 m2)
+ | 1 -> (i', n2 */ e') :: (xlin_comb m1 l2)
+ | _ -> assert false in
+ xlin_comb t1 t2
+
+
+
+
+
+ let lin_comb n1 t1 n2 t2 =
+ assert (check t1 && check t2);
+ let res = lin_comb n1 t1 n2 t2 in
+ assert (check res); res
+
+ let hash = Mutils.Cmp.hash_list (fun (x,y) -> (Hashtbl.hash x) lxor (int_of_num y))
+
+
+ let compare = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical
+ [
+ (fun () -> Pervasives.compare (fst x) (fst y));
+ (fun () -> compare_num (snd x) (snd y))])
+
+ (*
+ let compare (x:t) (y:t) =
+ let rec xcompare acc1 acc2 x y =
+ match x , y with
+ | [] , [] -> xcomp acc1 acc2
+ | [] , _ -> -1
+ | _ , [] -> 1
+ | (i,n1)::l1 , (j,n2)::l2 ->
+ match Pervasives.compare i j with
+ | 0 -> xcompare (n1::acc1) (n2::acc2) l1 l2
+ | c -> c
+ and xcomp acc1 acc2 = Mutils.Cmp.compare_list compare_num acc1 acc2 in
+ xcompare [] [] x y
+ *)
+
+ type it = t
+
+ let iterator (x:t) : it = x
+
+ let element l = failwith "Not_implemented"
+
+ (* TODO: Buffer! *)
+ type status = Pos | Neg
+
+ let status l = List.map (fun (i,e) ->
+ match compare_num e (Int 0) with
+ | 1 -> i,Pos
+ | -1 -> i,Neg
+ | _ -> assert false) l
+
+ let from_list (l: num list) =
+ let rec xfrom_list i l =
+ match l with
+ | [] -> []
+ | e::l ->
+ if e <>/ Int 0
+ then (i,e)::(xfrom_list (i+1) l)
+ else xfrom_list (i+1) l in
+
+ let res = xfrom_list 0 l in
+ assert (check res) ; res
+
+
+ let gcd m =
+ let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Mutils.numerator e)) Big_int.zero_big_int m in
+ if Big_int.compare_big_int res Big_int.zero_big_int = 0
+ then Big_int.unit_big_int else res
+
+ let to_list m =
+ let rec xto_list i l =
+ match l with
+ | [] -> []
+ | (x,v)::l' ->
+ if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in
+ xto_list 0 m
+
+ let to_list l =
+ assert (check l);
+ to_list l
+
+
+ let string l = VList.string (to_list l)
+
+end