diff options
Diffstat (limited to 'contrib/micromega')
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 |