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