diff options
Diffstat (limited to 'contrib/micromega')
26 files changed, 0 insertions, 12878 deletions
diff --git a/contrib/micromega/CheckerMaker.v b/contrib/micromega/CheckerMaker.v deleted file mode 100644 index 93b4d213..00000000 --- a/contrib/micromega/CheckerMaker.v +++ /dev/null @@ -1,129 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index 40db9e46..00000000 --- a/contrib/micromega/Env.v +++ /dev/null @@ -1,182 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index 04e68272..00000000 --- a/contrib/micromega/EnvRing.v +++ /dev/null @@ -1,1403 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index 5aadfa2a..00000000 --- a/contrib/micromega/LICENSE.sos +++ /dev/null @@ -1,29 +0,0 @@ - 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 deleted file mode 100644 index a5ac92db..00000000 --- a/contrib/micromega/MExtraction.v +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* 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/OrderedRing.v b/contrib/micromega/OrderedRing.v deleted file mode 100644 index 149b7731..00000000 --- a/contrib/micromega/OrderedRing.v +++ /dev/null @@ -1,458 +0,0 @@ -(************************************************************************) -(* 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/Psatz.v b/contrib/micromega/Psatz.v deleted file mode 100644 index b2dd9910..00000000 --- a/contrib/micromega/Psatz.v +++ /dev/null @@ -1,75 +0,0 @@ -(************************************************************************) -(* 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 xpsatz dom d := - let tac := lazymatch dom with - | Z => - (sos_Z || psatz_Z d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | R => - (sos_R || psatz_R d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | Q => - (sos_Q || psatz_Q d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; - apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | _ => fail "Unsupported domain" - end in tac. - -Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. -Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1. - -Ltac psatzl dom := - let tac := lazymatch dom with - | Z => - psatzl_Z ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | Q => - psatzl_Q ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; - apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | R => - psatzl_R ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | _ => fail "Unsupported domain" - end in tac. - - - -Ltac lia := - xlia ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity. diff --git a/contrib/micromega/QMicromega.v b/contrib/micromega/QMicromega.v deleted file mode 100644 index c054f218..00000000 --- a/contrib/micromega/QMicromega.v +++ /dev/null @@ -1,199 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import OrderedRing. -Require Import RingMicromega. -Require Import Refl. -Require Import QArith. -Require Import Qfield. - -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_0_l. - auto. - compute in H. - discriminate. -Qed. - - -Lemma QSORaddon : - SORaddon 0 1 Qplus Qmult Qminus Qopp Qeq Qle (* ring elements *) - 0 1 Qplus Qmult Qminus Qopp (* coefficients *) - Qeq_bool Qle_bool - (fun x => x) (fun x => x) (pow_N 1 Qmult). -Proof. - constructor. - constructor ; intros ; try reflexivity. - apply Qeq_bool_eq; auto. - constructor. - reflexivity. - intros x y. - apply Qeq_bool_neq ; auto. - apply Qle_bool_imp_le. -Qed. - - -(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*) -Require Import EnvRing. - -Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := - match e with - | PEc c => c - | PEX j => env j - | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) - | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) - | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) - | PEopp pe1 => - (Qeval_expr env pe1) - | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n) - end. - -Lemma Qeval_expr_simpl : forall env e, - Qeval_expr env e = - match e with - | PEc c => c - | PEX j => env j - | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) - | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) - | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) - | PEopp pe1 => - (Qeval_expr env pe1) - | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n) - end. -Proof. - destruct e ; reflexivity. -Qed. - -Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult). - -Lemma QNpower : forall r n, r ^ Z_of_N n = pow_N 1 Qmult r n. -Proof. - destruct n ; reflexivity. -Qed. - - -Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e. -Proof. - induction e ; simpl ; subst ; try congruence. - rewrite IHe. - apply QNpower. -Qed. - -Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop := -match o with -| OpEq => Qeq -| OpNEq => fun x y => ~ x == y -| OpLe => Qle -| OpGe => fun x y => Qle y x -| OpLt => Qlt -| OpGt => fun x y => Qlt y x -end. - -Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) := - let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs). - -Definition Qeval_formula' := - eval_formula Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult). - -Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f. -Proof. - intros. - unfold Qeval_formula. - destruct f. - repeat rewrite Qeval_expr_compat. - unfold Qeval_formula'. - unfold Qeval_expr'. - split ; destruct Fop ; simpl; auto. -Qed. - - - -Definition Qeval_nformula := - eval_nformula 0 Qplus Qmult 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 deleted file mode 100644 index 7c6969c2..00000000 --- a/contrib/micromega/RMicromega.v +++ /dev/null @@ -1,174 +0,0 @@ -(************************************************************************) -(* 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 Zeq_bool_eq ; auto. - apply R_power_theory. - intros x y. - intro. - apply IZR_neq. - apply Zeq_bool_neq ; auto. - intros. apply IZR_le. apply Zle_bool_imp_le. auto. -Qed. - - -Require Import EnvRing. - -Definition INZ (n:N) : R := - match n with - | N0 => IZR 0%Z - | Npos p => IZR (Zpos p) - end. - -Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp IZR Nnat.nat_of_N pow. - - -Definition Reval_op2 (o:Op2) : R -> R -> Prop := - match o with - | OpEq => @eq R - | OpNEq => fun x y => ~ x = y - | OpLe => Rle - | OpGe => Rge - | OpLt => Rlt - | OpGt => Rgt - end. - - -Definition Reval_formula (e: PolEnv R) (ff : Formula Z) := - let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs). - -Definition Reval_formula' := - eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow. - -Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f. -Proof. - intros. - unfold Reval_formula. - destruct f. - unfold Reval_formula'. - unfold Reval_expr. - split ; destruct Fop ; simpl ; auto. - apply Rge_le. - apply Rle_ge. -Qed. - -Definition Reval_nformula := - eval_nformula 0 Rplus Rmult 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. rewrite Reval_formula_compat. - unfold Reval_formula'. now apply (cnf_normalise_correct Rsor). - intros. rewrite Reval_formula_compat. 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 deleted file mode 100644 index 801d8b21..00000000 --- a/contrib/micromega/Refl.v +++ /dev/null @@ -1,129 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index 6885b82c..00000000 --- a/contrib/micromega/RingMicromega.v +++ /dev/null @@ -1,779 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index ef48efa6..00000000 --- a/contrib/micromega/Tauto.v +++ /dev/null @@ -1,324 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index 240c0fb7..00000000 --- a/contrib/micromega/VarMap.v +++ /dev/null @@ -1,258 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index ced67e39..00000000 --- a/contrib/micromega/ZCoeff.v +++ /dev/null @@ -1,173 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index 0855925a..00000000 --- a/contrib/micromega/ZMicromega.v +++ /dev/null @@ -1,705 +0,0 @@ -(************************************************************************) -(* 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 ZSORaddon : - SORaddon 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle (* ring elements *) - 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *) - Zeq_bool Zle_bool - (fun x => x) (fun x => x) (pow_N 1 Zmult). -Proof. - constructor. - constructor ; intros ; try reflexivity. - apply Zeq_bool_eq ; auto. - constructor. - reflexivity. - intros x y. - apply Zeq_bool_neq ; auto. - apply Zle_bool_imp_le. -Qed. - - -(*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 deleted file mode 100644 index f4efcd08..00000000 --- a/contrib/micromega/certificate.ml +++ /dev/null @@ -1,740 +0,0 @@ -(************************************************************************) -(* 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 - -let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l - - -(* The prover is (probably) incomplete -- - only searching for naive cutting planes *) - -let candidates sys = - let ll = List.fold_right ( - fun (Mc.Pair(e,k)) r -> - match k with - | Mc.NonStrict -> (dev_form z_spec e , Ge)::r - | Mc.Equal -> (dev_form z_spec e , Eq)::r - (* we already know the bound -- don't compute it again *) - | _ -> failwith "Cannot happen candidates") sys [] in - - let (sys,var_mn) = make_linear_system ll in - let vars = mapi (fun _ i -> Vect.set i (Int 1) Vect.null) var_mn in - (List.fold_left (fun l cstr -> - let gcd = Big_int (Vect.gcd cstr.coeffs) in - if gcd =/ (Int 1) && cstr.op = Eq - then l - else (Vect.mul (Int 1 // gcd) cstr.coeffs)::l) [] sys) @ vars - - -let rec xzlinear_prover planes sys = - match linear_prover z_spec sys with - | Some prf -> Some (Mc.RatProof prf) - | None -> (* find the candidate with the smallest range *) - (* Grrr - linear_prover is also calling 'make_linear_system' *) - 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.NonStrict -> Ge - | Mc.Equal -> Eq - | Mc.Strict | Mc.NonEqual -> failwith "Cannot happen") :: r) sys [] in - let (ll,var) = make_linear_system ll in - let candidates = List.fold_left (fun acc vect -> - match Fourier.optimise vect ll with - | None -> acc - | Some i -> -(* Printf.printf "%s in %s\n" (Vect.string vect) (string_of_intrvl i) ; *) - flush stdout ; - (vect,i) ::acc) [] planes in - - let smallest_interval = - match List.fold_left (fun (x1,i1) (x2,i2) -> - if smaller_itv i1 i2 - then (x1,i1) else (x2,i2)) (Vect.null,Itv(None,None)) candidates - with - | (x,Itv(Some i, Some j)) -> Some(i,x,j) - | (x,Point n) -> Some(n,x,n) - | x -> None (* This might be a cutting plane *) - in - match smallest_interval with - | Some (lb,e,ub) -> - let (lbn,lbd) = - (Ml2C.bigint (sub_big_int (numerator lb) unit_big_int), - Ml2C.bigint (denominator lb)) in - let (ubn,ubd) = - (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) , - Ml2C.bigint (denominator ub)) in - let expr = list_to_polynomial var (Vect.to_list e) in - (match - (*x <= ub -> x > ub *) - linear_prover z_spec - (Mc.Pair(pplus (pmult (pconst ubd) expr) (popp (pconst ubn)), - Mc.NonStrict) :: sys), - (* lb <= x -> lb > x *) - linear_prover z_spec - (Mc.Pair( pplus (popp (pmult (pconst lbd) expr)) (pconst lbn) , - Mc.NonStrict)::sys) - with - | Some cub , Some clb -> - (match zlinear_enum (remove e planes) expr - (ceiling_num lb) (floor_num ub) sys - with - | None -> None - | Some prf -> - Some (Mc.EnumProof(Ml2C.q lb,expr,Ml2C.q ub,clb,cub,prf))) - | _ -> None - ) - | _ -> None -and zlinear_enum planes 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 - (*let enum = *) - match xzlinear_prover planes sys' with - | None -> if debug then print_string "zlp?"; None - | Some prf -> if debug then print_string "zlp!"; - match zlinear_enum planes expr (clb +/ (Int 1)) cub l with - | None -> None - | Some prfl -> Some (Mc.Cons(prf,prfl)) - -let zlinear_prover sys = - let candidates = candidates sys in - (* Printf.printf "candidates %d" (List.length candidates) ; *) - xzlinear_prover candidates sys - -open Sos - -let rec scale_term t = - match t with - | Zero -> unit_big_int , Zero - | Const n -> (denominator n) , Const (Big_int (numerator n)) - | Var n -> unit_big_int , Var n - | Inv _ -> failwith "scale_term : not implemented" - | Opp t -> let s, t = scale_term t in s, Opp t - | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - let e = mult_big_int g (mult_big_int s1' s2') in - if (compare_big_int e unit_big_int) = 0 - then (unit_big_int, Add (y1,y2)) - else e, Add (Mul(Const (Big_int s2'), y1), - Mul (Const (Big_int s1'), y2)) - | Sub _ -> failwith "scale term: not implemented" - | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in - mult_big_int s1 s2 , Mul (y1, y2) - | Pow(t,n) -> let s,t = scale_term t in - power_big_int_positive_int s n , Pow(t,n) - | _ -> failwith "scale_term : not implemented" - -let scale_term t = - let (s,t') = scale_term t in - s,t' - - -let get_index_of_ith_match f i l = - let rec get j res l = - match l with - | [] -> failwith "bad index" - | e::l -> if f e - then - (if j = i then res else get (j+1) (res+1) l ) - else get j (res+1) l in - get 0 0 l - - -let rec scale_certificate pos = match pos with - | Axiom_eq i -> unit_big_int , Axiom_eq i - | Axiom_le i -> unit_big_int , Axiom_le i - | Axiom_lt i -> unit_big_int , Axiom_lt i - | Monoid l -> unit_big_int , Monoid l - | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) - | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) - | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) - | Square t -> let s,t' = scale_term t in - mult_big_int s s , Square t' - | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in - mult_big_int s1 s2 , Eqmul (y1,y2) - | Sum (y, z) -> let s1,y1 = scale_certificate y - and s2,y2 = scale_certificate z in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - mult_big_int g (mult_big_int s1' s2'), - Sum (Product(Rational_le (Big_int s2'), y1), - Product (Rational_le (Big_int s1'), y2)) - | Product (y, z) -> - let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in - mult_big_int s1 s2 , Product (y1,y2) - - -open Micromega - let rec term_to_q_expr = function - | Const n -> PEc (Ml2C.q n) - | Zero -> PEc ( Ml2C.q (Int 0)) - | Var s -> PEX (Ml2C.index - (int_of_string (String.sub s 1 (String.length s - 1)))) - | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) - | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) - | Opp p -> PEopp (term_to_q_expr p) - | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n) - | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) - | _ -> failwith "term_to_q_expr: not implemented" - -let q_cert_of_pos pos = - 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.q n) - | Square t -> Mc.S_Square (term_to_q_expr t) - | Eqmul (t, y) -> Mc.S_Ideal(term_to_q_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 - simplify_cone q_spec (_cert_of_pos pos) - - - let rec term_to_z_expr = function - | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) - | Zero -> PEc ( Z0) - | Var s -> PEX (Ml2C.index - (int_of_string (String.sub s 1 (String.length s - 1)))) - | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2) - | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2) - | Opp p -> PEopp (term_to_z_expr p) - | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n) - | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2) - | _ -> failwith "term_to_z_expr: not implemented" - -let z_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_z_expr t) - | Eqmul (t, y) -> Mc.S_Ideal(term_to_z_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 - simplify_cone z_spec (_cert_of_pos pos) - diff --git a/contrib/micromega/coq_micromega.ml b/contrib/micromega/coq_micromega.ml deleted file mode 100644 index b4863ffc..00000000 --- a/contrib/micromega/coq_micromega.ml +++ /dev/null @@ -1,1286 +0,0 @@ -(************************************************************************) -(* 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"]; - ["Coq";"Reals" ; "Rpow_def"]; - ["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_R0 = lazy (constant "R0") - let coq_R1 = lazy (constant "R1") - - - 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_Zpower = lazy (constant "Zpower") - let coq_N_of_Z = lazy - (gen_constant_in_modules "ZArithRing" - [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z") - - let coq_Qgt = lazy (constant "Qgt") - let coq_Qge = lazy (constant "Qge") - let coq_Qle = lazy (constant "Qle") - let coq_Qlt = lazy (constant "Qlt") - let coq_Qeq = lazy (constant "Qeq") - - - let coq_Qplus = lazy (constant "Qplus") - let coq_Qminus = lazy (constant "Qminus") - let coq_Qopp = lazy (constant "Qopp") - let coq_Qmult = lazy (constant "Qmult") - let coq_Qpower = lazy (constant "Qpower") - - - let coq_Rgt = lazy (constant "Rgt") - let coq_Rge = lazy (constant "Rge") - let coq_Rle = lazy (constant "Rle") - let coq_Rlt = lazy (constant "Rlt") - - let coq_Rplus = lazy (constant "Rplus") - let coq_Rminus = lazy (constant "Rminus") - let coq_Ropp = lazy (constant "Ropp") - let coq_Rmult = lazy (constant "Rmult") - let coq_Rpower = lazy (constant "pow") - - - let coq_PEX = lazy (constant "PEX" ) - let coq_PEc = lazy (constant"PEc") - let coq_PEadd = lazy (constant "PEadd") - let coq_PEopp = lazy (constant "PEopp") - let coq_PEmul = lazy (constant "PEmul") - let coq_PEsub = lazy (constant "PEsub") - let coq_PEpow = lazy (constant "PEpow") - - - let coq_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) -> if c = Lazy.force coq_Qmake then - {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) } - else raise ParseError - | _ -> raise ParseError - - - let rec parse_list parse_elt term = - let (i,c) = get_left_construct term in - match i with - | 1 -> 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 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 assoc_const x l = - try - snd (List.find (fun (x',y) -> x = Lazy.force x') l) - with - Not_found -> raise ParseError - - let zop_table = [ - coq_Zgt, Mc.OpGt ; - coq_Zge, Mc.OpGe ; - coq_Zlt, Mc.OpLt ; - coq_Zle, Mc.OpLe ] - - let rop_table = [ - coq_Rgt, Mc.OpGt ; - coq_Rge, Mc.OpGe ; - coq_Rlt, Mc.OpLt ; - coq_Rle, Mc.OpLe ] - - let qop_table = [ - coq_Qlt, Mc.OpLt ; - coq_Qle, Mc.OpLe ; - coq_Qeq, Mc.OpEq - ] - - - let parse_zop (op,args) = - match kind_of_term op with - | Const x -> (assoc_const op zop_table, args.(0) , args.(1)) - | Ind(n,0) -> - if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_Z - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" - - - let parse_rop (op,args) = - match kind_of_term op with - | Const x -> (assoc_const op rop_table, args.(0) , args.(1)) - | Ind(n,0) -> - if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_R - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" - - let parse_qop (op,args) = - (assoc_const op qop_table, args.(0) , args.(1)) - - - 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 assoc_ops x l = - try - snd (List.find (fun (x',y) -> x = Lazy.force x') l) - with - Not_found -> Ukn "Oups" - - - - let parse_expr parse_constant parse_exp ops_spec env term = - if debug - then (Pp.pp (Pp.str "parse_expr: "); - Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ()); - - let constant_or_variable env term = - try - ( Mc.PEc (parse_constant term) , env) - with ParseError -> - let (env,n) = Env.compute_rank_add env term in - (Mc.PEX n , env) in - - let rec parse_expr env term = - let combine env op (t1,t2) = - let (expr1,env) = parse_expr env t1 in - let (expr2,env) = parse_expr env t2 in - (op expr1 expr2,env) in - match kind_of_term term with - | App(t,args) -> - ( - match kind_of_term t with - | Const c -> - ( match assoc_ops t ops_spec with - | Binop f -> combine env f (args.(0),args.(1)) - | Opp -> let (expr,env) = parse_expr env args.(0) in - (Mc.PEopp expr, env) - | Power -> - 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 = - [ - coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Zopp , Opp ; - coq_Zpower , Power] - -let qop_spec = - [ - coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Qopp , Opp ; - coq_Qpower , Power] - -let rop_spec = - [ - coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Ropp , Opp ; - coq_Rpower , Power] - - - - - -let zconstant = parse_z -let qconstant = parse_q - - -let rconstant term = - if debug - then (Pp.pp_flush (); - Pp.pp (Pp.str "rconstant: "); - Pp.pp (Printer.prterm term); Pp.pp_flush ()); - match Term.kind_of_term term with - | Const x -> - if term = Lazy.force coq_R0 - then Mc.Z0 - else if term = Lazy.force coq_R1 - then Mc.Zpos Mc.XH - else raise ParseError - | _ -> raise ParseError - - -let parse_zexpr = - parse_expr zconstant (fun 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 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 - - - - - (* ! 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 = Sos.positivstellensatz option -type micromega_polys = (Micromega.q 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 = - List.fold_left Filename.concat (Envars.coqlib ()) - ["contrib"; "micromega"; "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 rec z_to_q_expr e = - match e with - | Mc.PEc z -> Mc.PEc {Mc.qnum = z ; Mc.qden = Mc.XH} - | Mc.PEX x -> Mc.PEX x - | Mc.PEadd(e1,e2) -> Mc.PEadd(z_to_q_expr e1, z_to_q_expr e2) - | Mc.PEsub(e1,e2) -> Mc.PEsub(z_to_q_expr e1, z_to_q_expr e2) - | Mc.PEmul(e1,e2) -> Mc.PEmul(z_to_q_expr e1, z_to_q_expr e2) - | Mc.PEopp(e) -> Mc.PEopp(z_to_q_expr e) - | Mc.PEpow(e,n) -> Mc.PEpow(z_to_q_expr e,n) - - -let call_csdpcert_q provername poly = - match call_csdpcert provername poly with - | None -> None - | Some cert -> - let cert = Certificate.q_cert_of_pos cert in - match Mc.qWeakChecker (CamlToCoq.list (fun x -> x) poly) cert with - | Mc.True -> Some cert - | Mc.False -> (print_string "buggy certificate" ; flush stdout) ;None - - -let call_csdpcert_z provername poly = - let l = List.map (fun (Mc.Pair(e,o)) -> (Mc.Pair(z_to_q_expr e,o))) poly in - match call_csdpcert provername l with - | None -> None - | Some cert -> - let cert = Certificate.z_cert_of_pos cert in - match Mc.zWeakChecker (CamlToCoq.list (fun x -> x) poly) cert with - | Mc.True -> Some cert - | Mc.False -> (print_string "buggy certificate" ; flush stdout) ;None - - - - -let psatzl_Z gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec - [lift_ratproof - (Certificate.linear_prover Certificate.z_spec), "fourier refutation" ] gl - - -let psatzl_Q gl = - micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec - [ Certificate.linear_prover Certificate.q_spec, "fourier refutation" ] gl - -let psatz_Q i gl = - micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec - [ call_csdpcert_q ("real_nonlinear_prover", Some i), "fourier refutation" ] gl - -let psatzl_R gl = - micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec - [ Certificate.linear_prover Certificate.z_spec, "fourier refutation" ] gl - - -let psatz_R i gl = - micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec - [ call_csdpcert_z ("real_nonlinear_prover", Some i), "fourier refutation" ] gl - - -let psatz_Z i gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec - [lift_ratproof (call_csdpcert_z ("real_nonlinear_prover",Some i)), - "fourier refutation" ] gl - - -let sos_Z gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec - [lift_ratproof (call_csdpcert_z ("pure_sos", None)), "pure sos refutation"] gl - -let sos_Q gl = - micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec - [call_csdpcert_q ("pure_sos", None), "pure sos refutation"] gl - -let sos_R gl = - micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec - [call_csdpcert_z ("pure_sos", None), "pure sos refutation"] gl - - - -let xlia 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 deleted file mode 100644 index e451a38f..00000000 --- a/contrib/micromega/csdpcert.ml +++ /dev/null @@ -1,197 +0,0 @@ -(************************************************************************) -(* 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 (C2Ml.q_to_num z) - | PEX v -> Var ("x"^(string_of_int (C2Ml.index v))) - | PEmul(p1,p2) -> - let p1 = expr_to_term p1 in - let p2 = expr_to_term p2 in - let res = Mul(p1,p2) in res - - | PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2) - | PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2) - | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n) - | PEopp p -> Opp (expr_to_term p) - - - - -(* 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 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) - -(* 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 - Some proof - 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 proof - with - | Not_found -> (* This is no strict inequality *) None - | x -> None - - -type micromega_polys = (Micromega.q Mc.pExpr, Mc.op1) Micromega.prod list -type csdp_certificate = Sos.positivstellensatz 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 deleted file mode 100644 index 50024e78..00000000 --- a/contrib/micromega/g_micromega.ml4 +++ /dev/null @@ -1,74 +0,0 @@ -(************************************************************************) -(* 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 11306 2008-08-05 16:51:08Z notin $ *) - -open Quote -open Ring -open Mutils -open Rawterm -open Util - -let out_arg = function - | ArgVar _ -> anomaly "Unevaluated or_var variable" - | ArgArg x -> x - -TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) ] -> [ Coq_micromega.psatz_Z (out_arg i) ] -| [ "psatz_Z" ] -> [ Coq_micromega.psatz_Z (-1) ] -END - -TACTIC EXTEND Sos_Z -| [ "sos_Z" ] -> [ Coq_micromega.sos_Z] - END - -TACTIC EXTEND Sos_Q -| [ "sos_Q" ] -> [ Coq_micromega.sos_Q] - END - -TACTIC EXTEND Sos_R -| [ "sos_R" ] -> [ Coq_micromega.sos_R] -END - - -TACTIC EXTEND Omicron -[ "psatzl_Z" ] -> [ Coq_micromega.psatzl_Z] -END - -TACTIC EXTEND QOmicron -[ "psatzl_Q" ] -> [ Coq_micromega.psatzl_Q] -END - - -TACTIC EXTEND ZOmicron -[ "xlia" ] -> [ Coq_micromega.xlia] -END - -TACTIC EXTEND ROmicron -[ "psatzl_R" ] -> [ Coq_micromega.psatzl_R] -END - -TACTIC EXTEND RMicromega -| [ "psatz_R" int_or_var(i) ] -> [ Coq_micromega.psatz_R (out_arg i) ] -| [ "psatz_R" ] -> [ Coq_micromega.psatz_R (-1) ] -END - - -TACTIC EXTEND QMicromega -| [ "psatz_Q" int_or_var(i) ] -> [ Coq_micromega.psatz_Q (out_arg i) ] -| [ "psatz_Q" ] -> [ Coq_micromega.psatz_Q (-1) ] -END - diff --git a/contrib/micromega/mfourier.ml b/contrib/micromega/mfourier.ml deleted file mode 100644 index 415d3a3e..00000000 --- a/contrib/micromega/mfourier.ml +++ /dev/null @@ -1,667 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index e151e4e1..00000000 --- a/contrib/micromega/micromega.ml +++ /dev/null @@ -1,1512 +0,0 @@ -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 deleted file mode 100644 index f94f091e..00000000 --- a/contrib/micromega/micromega.mli +++ /dev/null @@ -1,398 +0,0 @@ -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 deleted file mode 100644 index 2473608f..00000000 --- a/contrib/micromega/mutils.ml +++ /dev/null @@ -1,305 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index e3d72ed9..00000000 --- a/contrib/micromega/sos.ml +++ /dev/null @@ -1,1919 +0,0 @@ -(* ========================================================================= *) -(* - 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 deleted file mode 100644 index 31c9518c..00000000 --- a/contrib/micromega/sos.mli +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* 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 deleted file mode 100644 index fee4ebfc..00000000 --- a/contrib/micromega/vector.ml +++ /dev/null @@ -1,674 +0,0 @@ -(************************************************************************) -(* 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 |