From 92fc4574985850e96d65de53c09d116af514bfb1 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 6 Aug 2025 14:34:15 +0200 Subject: [PATCH 01/12] Move a few list functions to ListDef.v In preparation of move to Corelib. --- theories/Lists/List.v | 31 +++++-------------------------- theories/Lists/ListDef.v | 2 +- 2 files changed, 6 insertions(+), 27 deletions(-) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index e2d092dddf..c214ed0aa3 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -1072,12 +1072,6 @@ Section ListOps. (** An alternative tail-recursive definition for reverse *) - Fixpoint rev_append (l l': list A) : list A := - match l with - | [] => l' - | a :: l => rev_append l (a::l') - end. - Definition rev' l : list A := rev_append l []. Lemma rev_append_rev : forall l l', rev_append l l' = rev l ++ l'. @@ -1154,6 +1148,7 @@ Section ListOps. Qed. End ListOps. +Notation rev_append := rev_append. (***************************************************) (** * Applying functions to the elements of a list *) @@ -1407,19 +1402,14 @@ Section Fold_Left_Recursor. Variables (A : Type) (B : Type). Variable f : A -> B -> A. - Fixpoint fold_left (l:list B) (a0:A) : A := - match l with - | [] => a0 - | b :: l => fold_left l (f a0 b) - end. - Lemma fold_left_app : forall (l l':list B)(i:A), - fold_left (l++l') i = fold_left l' (fold_left l i). + fold_left f (l++l') i = fold_left f l' (fold_left f l i). Proof. now intro l; induction l; cbn. Qed. End Fold_Left_Recursor. +Notation fold_left := fold_left. Lemma fold_left_S_0 : forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l. @@ -1432,18 +1422,7 @@ Qed. (** Right-to-left iterator on lists *) (************************************) -Section Fold_Right_Recursor. - Variables (A : Type) (B : Type). - Variable f : B -> A -> A. - Variable a0 : A. - - Fixpoint fold_right (l:list B) : A := - match l with - | [] => a0 - | b :: l => f b (fold_right l) - end. - -End Fold_Right_Recursor. + Notation fold_right := fold_right. Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i, fold_right f i (l++l') = fold_right f (fold_right f i l') l. @@ -3883,7 +3862,7 @@ Lemma length_concat A l: length (concat l) = list_sum (map (@length A) l). Proof. induction l; [reflexivity|]. - simpl. rewrite length_app. + simpl; rewrite length_app. f_equal. assumption. Qed. diff --git a/theories/Lists/ListDef.v b/theories/Lists/ListDef.v index aa3414c0fc..e98a7adf7b 100644 --- a/theories/Lists/ListDef.v +++ b/theories/Lists/ListDef.v @@ -1 +1 @@ -From Corelib Require Export ListDef. +From micromega_plugin Require Export ListDef. From c2fa2ab223f235d4b094bf455f0cd4e260cdb26e Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Fri, 15 Aug 2025 15:00:49 +0200 Subject: [PATCH 02/12] Move a few things to PosDef.v In preparation of move to Corelib. --- theories/BinNums/PosDef.v | 2 +- theories/PArith/BinPosDef.v | 87 +------------------------------------ 2 files changed, 2 insertions(+), 87 deletions(-) diff --git a/theories/BinNums/PosDef.v b/theories/BinNums/PosDef.v index ad44d4bb38..39a9b7f980 100644 --- a/theories/BinNums/PosDef.v +++ b/theories/BinNums/PosDef.v @@ -1 +1 @@ -From Corelib Require Export PosDef. +From micromega_plugin Require Export PosDef. diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index 9a4ad9a4c2..d35d3dbedb 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -24,7 +24,7 @@ From Stdlib Require Export BinNums BinNums.PosDef. Module Pos. -Include BinNums.PosDef.Pos. +Include PosDef.Pos. Definition t := positive. @@ -32,15 +32,6 @@ Definition t := positive. Infix "+" := add : positive_scope. -(** ** Predecessor *) - -Definition pred x := - match x with - | p~1 => p~0 - | p~0 => pred_double p - | 1 => 1 - end. - (** ** Predecessor with mask *) Definition pred_mask (p : mask) : mask := @@ -237,82 +228,6 @@ Fixpoint of_nat (n:nat) : positive := (** ** Conversion with a decimal representation for printing/parsing *) -#[local] Notation ten := 1~0~1~0. - -Fixpoint of_uint_acc (d:Decimal.uint)(acc:positive) := - match d with - | Decimal.Nil => acc - | Decimal.D0 l => of_uint_acc l (mul ten acc) - | Decimal.D1 l => of_uint_acc l (add 1 (mul ten acc)) - | Decimal.D2 l => of_uint_acc l (add 1~0 (mul ten acc)) - | Decimal.D3 l => of_uint_acc l (add 1~1 (mul ten acc)) - | Decimal.D4 l => of_uint_acc l (add 1~0~0 (mul ten acc)) - | Decimal.D5 l => of_uint_acc l (add 1~0~1 (mul ten acc)) - | Decimal.D6 l => of_uint_acc l (add 1~1~0 (mul ten acc)) - | Decimal.D7 l => of_uint_acc l (add 1~1~1 (mul ten acc)) - | Decimal.D8 l => of_uint_acc l (add 1~0~0~0 (mul ten acc)) - | Decimal.D9 l => of_uint_acc l (add 1~0~0~1 (mul ten acc)) - end. - -Fixpoint of_uint (d:Decimal.uint) : N := - match d with - | Decimal.Nil => N0 - | Decimal.D0 l => of_uint l - | Decimal.D1 l => Npos (of_uint_acc l 1) - | Decimal.D2 l => Npos (of_uint_acc l 1~0) - | Decimal.D3 l => Npos (of_uint_acc l 1~1) - | Decimal.D4 l => Npos (of_uint_acc l 1~0~0) - | Decimal.D5 l => Npos (of_uint_acc l 1~0~1) - | Decimal.D6 l => Npos (of_uint_acc l 1~1~0) - | Decimal.D7 l => Npos (of_uint_acc l 1~1~1) - | Decimal.D8 l => Npos (of_uint_acc l 1~0~0~0) - | Decimal.D9 l => Npos (of_uint_acc l 1~0~0~1) - end. - -#[local] Notation sixteen := 1~0~0~0~0. - -Fixpoint of_hex_uint_acc (d:Hexadecimal.uint)(acc:positive) := - match d with - | Hexadecimal.Nil => acc - | Hexadecimal.D0 l => of_hex_uint_acc l (mul sixteen acc) - | Hexadecimal.D1 l => of_hex_uint_acc l (add 1 (mul sixteen acc)) - | Hexadecimal.D2 l => of_hex_uint_acc l (add 1~0 (mul sixteen acc)) - | Hexadecimal.D3 l => of_hex_uint_acc l (add 1~1 (mul sixteen acc)) - | Hexadecimal.D4 l => of_hex_uint_acc l (add 1~0~0 (mul sixteen acc)) - | Hexadecimal.D5 l => of_hex_uint_acc l (add 1~0~1 (mul sixteen acc)) - | Hexadecimal.D6 l => of_hex_uint_acc l (add 1~1~0 (mul sixteen acc)) - | Hexadecimal.D7 l => of_hex_uint_acc l (add 1~1~1 (mul sixteen acc)) - | Hexadecimal.D8 l => of_hex_uint_acc l (add 1~0~0~0 (mul sixteen acc)) - | Hexadecimal.D9 l => of_hex_uint_acc l (add 1~0~0~1 (mul sixteen acc)) - | Hexadecimal.Da l => of_hex_uint_acc l (add 1~0~1~0 (mul sixteen acc)) - | Hexadecimal.Db l => of_hex_uint_acc l (add 1~0~1~1 (mul sixteen acc)) - | Hexadecimal.Dc l => of_hex_uint_acc l (add 1~1~0~0 (mul sixteen acc)) - | Hexadecimal.Dd l => of_hex_uint_acc l (add 1~1~0~1 (mul sixteen acc)) - | Hexadecimal.De l => of_hex_uint_acc l (add 1~1~1~0 (mul sixteen acc)) - | Hexadecimal.Df l => of_hex_uint_acc l (add 1~1~1~1 (mul sixteen acc)) - end. - -Fixpoint of_hex_uint (d:Hexadecimal.uint) : N := - match d with - | Hexadecimal.Nil => N0 - | Hexadecimal.D0 l => of_hex_uint l - | Hexadecimal.D1 l => Npos (of_hex_uint_acc l 1) - | Hexadecimal.D2 l => Npos (of_hex_uint_acc l 1~0) - | Hexadecimal.D3 l => Npos (of_hex_uint_acc l 1~1) - | Hexadecimal.D4 l => Npos (of_hex_uint_acc l 1~0~0) - | Hexadecimal.D5 l => Npos (of_hex_uint_acc l 1~0~1) - | Hexadecimal.D6 l => Npos (of_hex_uint_acc l 1~1~0) - | Hexadecimal.D7 l => Npos (of_hex_uint_acc l 1~1~1) - | Hexadecimal.D8 l => Npos (of_hex_uint_acc l 1~0~0~0) - | Hexadecimal.D9 l => Npos (of_hex_uint_acc l 1~0~0~1) - | Hexadecimal.Da l => Npos (of_hex_uint_acc l 1~0~1~0) - | Hexadecimal.Db l => Npos (of_hex_uint_acc l 1~0~1~1) - | Hexadecimal.Dc l => Npos (of_hex_uint_acc l 1~1~0~0) - | Hexadecimal.Dd l => Npos (of_hex_uint_acc l 1~1~0~1) - | Hexadecimal.De l => Npos (of_hex_uint_acc l 1~1~1~0) - | Hexadecimal.Df l => Npos (of_hex_uint_acc l 1~1~1~1) - end. - Definition of_num_uint (d:Number.uint) : N := match d with | Number.UIntDecimal d => of_uint d From 042c1b22e0e35e6c2a5ab63913805105737c9d45 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Fri, 15 Aug 2025 14:47:17 +0200 Subject: [PATCH 03/12] Move a few things to NatDef.v In preparation of move to Corelib. --- theories/BinNums/NatDef.v | 3 ++- theories/NArith/BinNatDef.v | 49 ++----------------------------------- 2 files changed, 4 insertions(+), 48 deletions(-) diff --git a/theories/BinNums/NatDef.v b/theories/BinNums/NatDef.v index 41a5777d30..07f9334433 100644 --- a/theories/BinNums/NatDef.v +++ b/theories/BinNums/NatDef.v @@ -1 +1,2 @@ -From Corelib Require Export NatDef. +From Stdlib Require Import PosDef. +From micromega_plugin Require Export NatDef. diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index 3fdb67e900..e839c2e955 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -10,7 +10,7 @@ From Stdlib Require Export BinNums. From Stdlib Require Import BinPos. -From Stdlib Require Export BinNums.NatDef. +From micromega_plugin Require Export NatDef. #[local] Open Scope N_scope. @@ -24,7 +24,7 @@ From Stdlib Require Export BinNums.NatDef. Module N. -Include BinNums.NatDef.N. +Include NatDef.N. Definition t := N. @@ -38,14 +38,6 @@ Definition zero := 0. Definition one := 1. Definition two := 2. -(** ** Successor *) - -Definition succ n := - match n with - | 0 => 1 - | pos p => pos (Pos.succ p) - end. - (** ** Predecessor *) Definition pred n := @@ -56,39 +48,18 @@ Definition pred n := (** ** Addition *) -Definition add n m := - match n, m with - | 0, _ => m - | _, 0 => n - | pos p, pos q => pos (p + q) - end. - Infix "+" := add : N_scope. Infix "-" := sub : N_scope. (** Multiplication *) -Definition mul n m := - match n, m with - | 0, _ => 0 - | _, 0 => 0 - | pos p, pos q => pos (p * q) - end. - Infix "*" := mul : N_scope. Infix "?=" := compare (at level 70, no associativity) : N_scope. (** Boolean equality and comparison *) -Definition eqb n m := - match n, m with - | 0, 0 => true - | pos p, pos q => Pos.eqb p q - | _, _ => false - end. - Definition ltb x y := match x ?= y with Lt => true | _ => false end. @@ -263,12 +234,6 @@ Definition testbit a n := (** Translation from [N] to [nat] and back. *) -Definition to_nat (a:N) := - match a with - | 0 => O - | pos p => Pos.to_nat p - end. - Definition of_nat (n:nat) := match n with | O => 0 @@ -290,16 +255,6 @@ Definition iter_op {A} (op : A -> A -> A) (z x : A) (n : N) := (** Conversion with a decimal representation for printing/parsing *) -Definition of_uint (d:Decimal.uint) := Pos.of_uint d. - -Definition of_hex_uint (d:Hexadecimal.uint) := Pos.of_hex_uint d. - -Definition of_num_uint (d:Number.uint) := - match d with - | Number.UIntDecimal d => of_uint d - | Number.UIntHexadecimal d => of_hex_uint d - end. - Definition of_int (d:Decimal.int) := match Decimal.norm d with | Decimal.Pos d => Some (Pos.of_uint d) From 8aeaa2d6d70c26d94c249b57b66459b9c2f98ce2 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 6 Aug 2025 11:09:30 +0200 Subject: [PATCH 04/12] Prepare move of RatDef.v to Corelib --- subcomponents/corelib_wrapper.v | 1 + theories/BinNums/RatDef.v | 1 + theories/Numbers/DecimalR.v | 4 +-- theories/Numbers/HexadecimalR.v | 4 +-- theories/QArith/QArith_base.v | 45 +++++++++++++-------------------- 5 files changed, 24 insertions(+), 31 deletions(-) create mode 100644 theories/BinNums/RatDef.v diff --git a/subcomponents/corelib_wrapper.v b/subcomponents/corelib_wrapper.v index 7ce6279b14..ae07b6f823 100644 --- a/subcomponents/corelib_wrapper.v +++ b/subcomponents/corelib_wrapper.v @@ -3,6 +3,7 @@ From Stdlib Require Array.PrimArray. From Stdlib Require BinNums.IntDef. From Stdlib Require BinNums.NatDef. From Stdlib Require BinNums.PosDef. +From Stdlib Require BinNums.RatDef. From Stdlib Require Classes.CMorphisms. From Stdlib Require Classes.CRelationClasses. From Stdlib Require Classes.Equivalence. diff --git a/theories/BinNums/RatDef.v b/theories/BinNums/RatDef.v new file mode 100644 index 0000000000..887381578e --- /dev/null +++ b/theories/BinNums/RatDef.v @@ -0,0 +1 @@ +From micromega_plugin Require Export RatDef. diff --git a/theories/Numbers/DecimalR.v b/theories/Numbers/DecimalR.v index 970cfb397c..ec1d70facf 100644 --- a/theories/Numbers/DecimalR.v +++ b/theories/Numbers/DecimalR.v @@ -13,15 +13,15 @@ Proofs that conversions between decimal numbers and [R] are bijections. *) +From Stdlib Require Import RatDef PeanoNat. From Stdlib Require Import Decimal DecimalFacts DecimalPos DecimalZ DecimalQ Rdefinitions. -From Stdlib Require Import PeanoNat. Lemma of_IQmake_to_decimal num den : match IQmake_to_decimal num den with | None => True | Some (DecimalExp _ _ _) => False | Some (Decimal i f) => - of_decimal (Decimal i f) = IRQ (QArith_base.Qmake num den) + of_decimal (Decimal i f) = IRQ (Qmake num den) end. Proof. unfold IQmake_to_decimal. diff --git a/theories/Numbers/HexadecimalR.v b/theories/Numbers/HexadecimalR.v index eb8f0ea1de..512803a152 100644 --- a/theories/Numbers/HexadecimalR.v +++ b/theories/Numbers/HexadecimalR.v @@ -13,7 +13,7 @@ Proofs that conversions between hexadecimal numbers and [R] are bijections. *) -From Stdlib Require Import PeanoNat. +From Stdlib Require Import RatDef PeanoNat. From Stdlib Require Import Decimal DecimalFacts. From Stdlib Require Import Hexadecimal HexadecimalFacts HexadecimalPos HexadecimalZ. From Stdlib Require Import HexadecimalQ Rdefinitions. @@ -23,7 +23,7 @@ Lemma of_IQmake_to_hexadecimal num den : | None => True | Some (HexadecimalExp _ _ _) => False | Some (Hexadecimal i f) => - of_hexadecimal (Hexadecimal i f) = IRQ (QArith_base.Qmake num den) + of_hexadecimal (Hexadecimal i f) = IRQ (Qmake num den) end. Proof. unfold IQmake_to_hexadecimal. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 3d40a3d502..389879f595 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +From Stdlib Require Export RatDef. From Stdlib Require Export BinInt. From Stdlib Require Export ZArithRing. From Stdlib Require Export ZArith.BinInt. @@ -20,7 +21,10 @@ From Stdlib Require ZArith_dec. (** Rationals are pairs of [Z] and [positive] numbers. *) -Record Q : Set := Qmake {Qnum : Z; Qden : positive}. +Notation Q := Q. +Notation Qmake := Qmake. +Notation Qnum := Qnum. +Notation Qden := Qden. Declare Scope hex_Q_scope. Delimit Scope hex_Q_scope with xQ. @@ -30,9 +34,6 @@ Delimit Scope Q_scope with Q. Bind Scope Q_scope with Q. Arguments Qmake _%_Z _%_positive. -Register Q as rat.Q.type. -Register Qmake as rat.Q.Qmake. - Open Scope Q_scope. Ltac simpl_mult := rewrite ?Pos2Z.inj_mul. @@ -177,11 +178,8 @@ Proof. apply Z.eq_dec. Defined. -Definition Qeq_bool x y := - (Z.eqb (Qnum x * QDen y) (Qnum y * QDen x))%Z. - -Definition Qle_bool x y := - (Z.leb (Qnum x * QDen y) (Qnum y * QDen x))%Z. +Notation Qeq_bool := Qeq_bool. +Notation Qle_bool := Qle_bool. Lemma Qeq_bool_iff x y : Qeq_bool x y = true <-> x == y. Proof. apply Z.eqb_eq. Qed. @@ -242,21 +240,11 @@ Hint Resolve Qnot_eq_sym : qarith. (** The addition, multiplication and opposite are defined in the straightforward way: *) -Definition Qplus (x y : Q) := - (Qnum x * QDen y + Qnum y * QDen x) # (Qden x * Qden y). - -Definition Qmult (x y : Q) := (Qnum x * Qnum y) # (Qden x * Qden y). - -Definition Qopp (x : Q) := (- Qnum x) # (Qden x). - -Definition Qminus (x y : Q) := Qplus x (Qopp y). - -Definition Qinv (x : Q) := - match Qnum x with - | Z0 => 0#1 - | Zpos p => (QDen x)#p - | Zneg p => (Zneg (Qden x))#p - end. +Notation Qplus := Qplus. +Notation Qmult := Qmult. +Notation Qopp := Qopp. +Notation Qminus := Qminus. +Notation Qinv := Qinv. Definition Qdiv (x y : Q) := Qmult x (Qinv y). @@ -1288,7 +1276,8 @@ Qed. Lemma Qmult_lt_0_compat : forall a b : Q, 0 < a -> 0 < b -> 0 < a * b. Proof. intros a b Ha Hb. - destruct a,b. unfold Qlt, Qmult, QArith_base.Qnum, QArith_base.Qden in *. + destruct a as [na da]; destruct b as [nb db]. + unfold Qlt, Qmult, Qnum, Qden in *. rewrite Pos2Z.inj_mul. rewrite Z.mul_0_l, Z.mul_1_r in *. apply Z.mul_pos_pos; assumption. @@ -1297,7 +1286,8 @@ Qed. Lemma Qmult_le_1_compat: forall a b : Q, 1 <= a -> 1 <= b -> 1 <= a * b. Proof. intros a b Ha Hb. - destruct a,b. unfold Qle, Qmult, QArith_base.Qnum, QArith_base.Qden in *. + destruct a as [na da]; destruct b as [nb db]. + unfold Qle, Qmult, Qnum, Qden in *. rewrite Pos2Z.inj_mul. rewrite Z.mul_1_l, Z.mul_1_r in *. apply Z.mul_le_mono_nonneg. @@ -1308,7 +1298,8 @@ Qed. Lemma Qmult_lt_1_compat: forall a b : Q, 1 < a -> 1 < b -> 1 < a * b. Proof. intros a b Ha Hb. - destruct a,b. unfold Qlt, Qmult, QArith_base.Qnum, QArith_base.Qden in *. + destruct a as [na da]; destruct b as [nb db]. + unfold Qlt, Qmult, Qnum, Qden in *. rewrite Pos2Z.inj_mul. rewrite Z.mul_1_l, Z.mul_1_r in *. apply Z.mul_lt_mono_nonneg. From 2c14ac7d75f1a0025c1aae48dbefb05ce5f318e6 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Tue, 2 Sep 2025 13:12:56 +0200 Subject: [PATCH 05/12] Move ring_checker.v to micromega-plugin --- subcomponents/ring.v | 1 + test-suite/bugs/bug_5359.v | 402 ++++++++++---------- theories/setoid_ring/Cring.v | 2 +- theories/setoid_ring/Field_theory.v | 2 +- theories/setoid_ring/Ncring_polynom.v | 11 - theories/setoid_ring/Ring_polynom.v | 515 +++----------------------- theories/setoid_ring/ring_checker.v | 1 + theories/setoid_ring/ring_eval.v | 1 + 8 files changed, 257 insertions(+), 678 deletions(-) create mode 100644 theories/setoid_ring/ring_checker.v create mode 100644 theories/setoid_ring/ring_eval.v diff --git a/subcomponents/ring.v b/subcomponents/ring.v index 1ba18583c5..1fe6b42300 100644 --- a/subcomponents/ring.v +++ b/subcomponents/ring.v @@ -18,6 +18,7 @@ From Stdlib Require setoid_ring.Ring_tac. From Stdlib Require setoid_ring.ArithRing. From Stdlib Require setoid_ring.NArithRing. From Stdlib Require setoid_ring.Ring_theory. +From Stdlib Require setoid_ring.ring_eval. From Stdlib Require nsatz.NsatzTactic. From Stdlib Require nsatz.ENsatzTactic. From Stdlib Require micromega.VarMap. diff --git a/test-suite/bugs/bug_5359.v b/test-suite/bugs/bug_5359.v index eb8205940f..50b6acc8a6 100644 --- a/test-suite/bugs/bug_5359.v +++ b/test-suite/bugs/bug_5359.v @@ -7,215 +7,215 @@ Goal False. let sugar := constr:( 0%Z ) in let nparams := constr:( (-1)%Z ) in let reified_goal := constr:( - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) ) in + (PEsub (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) (PEX Z 2)) + (PEX Z 5)) (PEX Z 3)) + (PEX Z 6))) ) in let power := constr:( N.one ) in let reified_givens := constr:( - (Ring_polynom.PEmul - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) - :: Ring_polynom.PEsub - (Ring_polynom.PEmul - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)) - (Ring_polynom.PEX Z 3)) (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEX Z 10)) (Ring_polynom.PEc 1%Z) - :: Ring_polynom.PEsub - (Ring_polynom.PEmul - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)) - (Ring_polynom.PEX Z 3)) (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEX Z 9)) (Ring_polynom.PEc 1%Z) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 7) - (Ring_polynom.PEX Z 7))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 8) (Ring_polynom.PEX Z 8))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 7) - (Ring_polynom.PEX Z 7))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 8) - (Ring_polynom.PEX Z 8)))) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 5) - (Ring_polynom.PEX Z 5))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 6) - (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 5) - (Ring_polynom.PEX Z 5))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 6) - (Ring_polynom.PEX Z 6)))) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 2) - (Ring_polynom.PEX Z 2))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) - (Ring_polynom.PEX Z 3))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 2) - (Ring_polynom.PEX Z 2))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) - (Ring_polynom.PEX Z 3)))) :: nil)%list ) in + (PEmul + (PEadd (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) (PEX Z 2)) + (PEX Z 5)) (PEX Z 3)) + (PEX Z 6))) + (PEsub (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) (PEX Z 2)) + (PEX Z 5)) (PEX Z 3)) + (PEX Z 6))) + :: PEsub + (PEmul + (PEadd (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) + (PEX Z 2)) (PEX Z 5)) + (PEX Z 3)) (PEX Z 6))) + (PEX Z 10)) (PEc 1%Z) + :: PEsub + (PEmul + (PEsub (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) + (PEX Z 2)) (PEX Z 5)) + (PEX Z 3)) (PEX Z 6))) + (PEX Z 9)) (PEc 1%Z) + :: PEsub + (PEadd + (PEmul (PEX Z 1) + (PEmul (PEX Z 7) + (PEX Z 7))) + (PEmul (PEX Z 8) (PEX Z 8))) + (PEadd (PEc 1%Z) + (PEmul + (PEmul (PEX Z 4) + (PEmul (PEX Z 7) + (PEX Z 7))) + (PEmul (PEX Z 8) + (PEX Z 8)))) + :: PEsub + (PEadd + (PEmul (PEX Z 1) + (PEmul (PEX Z 5) + (PEX Z 5))) + (PEmul (PEX Z 6) + (PEX Z 6))) + (PEadd (PEc 1%Z) + (PEmul + (PEmul (PEX Z 4) + (PEmul (PEX Z 5) + (PEX Z 5))) + (PEmul (PEX Z 6) + (PEX Z 6)))) + :: PEsub + (PEadd + (PEmul (PEX Z 1) + (PEmul (PEX Z 2) + (PEX Z 2))) + (PEmul (PEX Z 3) + (PEX Z 3))) + (PEadd (PEc 1%Z) + (PEmul + (PEmul (PEX Z 4) + (PEmul (PEX Z 2) + (PEX Z 2))) + (PEmul (PEX Z 3) + (PEX Z 3)))) :: nil)%list ) in NsatzTactic.nsatz_compute - (@cons _ (@Ring_polynom.PEc _ sugar) (@cons _ (@Ring_polynom.PEc _ nparams) (@cons _ (@Ring_polynom.PEpow _ reified_goal power) reified_givens))). + (@cons _ (@PEc _ sugar) (@cons _ (@PEc _ nparams) (@cons _ (@PEpow _ reified_goal power) reified_givens))). let sugar := constr:( 0%Z ) in let nparams := constr:( (-1)%Z ) in let reified_goal := constr:( - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) ) in + (PEsub (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) (PEX Z 2)) + (PEX Z 5)) (PEX Z 3)) + (PEX Z 6))) ) in let power := constr:( N.one ) in let reified_givens := constr:( - (Ring_polynom.PEmul - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) - :: Ring_polynom.PEadd - (Ring_polynom.PEmul - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)) - (Ring_polynom.PEX Z 3)) (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)) - (Ring_polynom.PEX Z 3)) (Ring_polynom.PEX Z 6)))) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 2) - (Ring_polynom.PEX Z 6)) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) - (Ring_polynom.PEX Z 5)))) (Ring_polynom.PEX Z 7)) - (Ring_polynom.PEsub - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) (Ring_polynom.PEX Z 6)) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)))) - (Ring_polynom.PEX Z 8)) - :: Ring_polynom.PEsub - (Ring_polynom.PEmul - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) (Ring_polynom.PEX Z 5)) - (Ring_polynom.PEX Z 3)) (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEX Z 10)) (Ring_polynom.PEc 1%Z) - :: Ring_polynom.PEsub - (Ring_polynom.PEmul - (Ring_polynom.PEsub (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEX Z 2)) - (Ring_polynom.PEX Z 5)) (Ring_polynom.PEX Z 3)) - (Ring_polynom.PEX Z 6))) (Ring_polynom.PEX Z 9)) - (Ring_polynom.PEc 1%Z) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 7) - (Ring_polynom.PEX Z 7))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 8) - (Ring_polynom.PEX Z 8))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 7) - (Ring_polynom.PEX Z 7))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 8) - (Ring_polynom.PEX Z 8)))) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 5) - (Ring_polynom.PEX Z 5))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 6) - (Ring_polynom.PEX Z 6))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 5) - (Ring_polynom.PEX Z 5))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 6) - (Ring_polynom.PEX Z 6)))) - :: Ring_polynom.PEsub - (Ring_polynom.PEadd - (Ring_polynom.PEmul (Ring_polynom.PEX Z 1) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 2) - (Ring_polynom.PEX Z 2))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) - (Ring_polynom.PEX Z 3))) - (Ring_polynom.PEadd (Ring_polynom.PEc 1%Z) - (Ring_polynom.PEmul - (Ring_polynom.PEmul (Ring_polynom.PEX Z 4) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 2) - (Ring_polynom.PEX Z 2))) - (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) - (Ring_polynom.PEX Z 3)))) :: nil)%list ) in + (PEmul + (PEadd (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) (PEX Z 2)) + (PEX Z 5)) (PEX Z 3)) + (PEX Z 6))) + (PEsub (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) (PEX Z 2)) + (PEX Z 5)) (PEX Z 3)) + (PEX Z 6))) + :: PEadd + (PEmul + (PEadd (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) + (PEX Z 2)) (PEX Z 5)) + (PEX Z 3)) (PEX Z 6))) + (PEsub (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) + (PEX Z 2)) (PEX Z 5)) + (PEX Z 3)) (PEX Z 6)))) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) + (PEadd + (PEmul (PEX Z 2) + (PEX Z 6)) + (PEmul (PEX Z 3) + (PEX Z 5)))) (PEX Z 7)) + (PEsub + (PEmul (PEX Z 3) (PEX Z 6)) + (PEmul + (PEmul (PEX Z 1) + (PEX Z 2)) (PEX Z 5)))) + (PEX Z 8)) + :: PEsub + (PEmul + (PEadd (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) + (PEX Z 2)) (PEX Z 5)) + (PEX Z 3)) (PEX Z 6))) + (PEX Z 10)) (PEc 1%Z) + :: PEsub + (PEmul + (PEsub (PEc 1%Z) + (PEmul + (PEmul + (PEmul + (PEmul (PEX Z 4) + (PEX Z 2)) + (PEX Z 5)) (PEX Z 3)) + (PEX Z 6))) (PEX Z 9)) + (PEc 1%Z) + :: PEsub + (PEadd + (PEmul (PEX Z 1) + (PEmul (PEX Z 7) + (PEX Z 7))) + (PEmul (PEX Z 8) + (PEX Z 8))) + (PEadd (PEc 1%Z) + (PEmul + (PEmul (PEX Z 4) + (PEmul (PEX Z 7) + (PEX Z 7))) + (PEmul (PEX Z 8) + (PEX Z 8)))) + :: PEsub + (PEadd + (PEmul (PEX Z 1) + (PEmul (PEX Z 5) + (PEX Z 5))) + (PEmul (PEX Z 6) + (PEX Z 6))) + (PEadd (PEc 1%Z) + (PEmul + (PEmul (PEX Z 4) + (PEmul (PEX Z 5) + (PEX Z 5))) + (PEmul (PEX Z 6) + (PEX Z 6)))) + :: PEsub + (PEadd + (PEmul (PEX Z 1) + (PEmul (PEX Z 2) + (PEX Z 2))) + (PEmul (PEX Z 3) + (PEX Z 3))) + (PEadd (PEc 1%Z) + (PEmul + (PEmul (PEX Z 4) + (PEmul (PEX Z 2) + (PEX Z 2))) + (PEmul (PEX Z 3) + (PEX Z 3)))) :: nil)%list ) in NsatzTactic.nsatz_compute - (@cons _ (@Ring_polynom.PEc _ sugar) (@cons _ (@Ring_polynom.PEc _ nparams) (@cons _ (@Ring_polynom.PEpow _ reified_goal power) reified_givens))). + (@cons _ (@PEc _ sugar) (@cons _ (@PEc _ nparams) (@cons _ (@PEpow _ reified_goal power) reified_givens))). Abort. diff --git a/theories/setoid_ring/Cring.v b/theories/setoid_ring/Cring.v index b8b30a27c0..afbbf1a159 100644 --- a/theories/setoid_ring/Cring.v +++ b/theories/setoid_ring/Cring.v @@ -143,7 +143,7 @@ Ltac cring_simplify_aux lterm fv lexpr hyp := | ?t0::?lterm => match lexpr with | ?e::?le => - let t := constr:(@Ring_polynom.norm_subst + let t := constr:(@ring_checker.norm_subst Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Z.eqb Z.quotrem O nil e) in let te := constr:(@Ring_polynom.Pphi_dev diff --git a/theories/setoid_ring/Field_theory.v b/theories/setoid_ring/Field_theory.v index bfc6bb1de4..9a9c03c31d 100644 --- a/theories/setoid_ring/Field_theory.v +++ b/theories/setoid_ring/Field_theory.v @@ -1514,7 +1514,7 @@ Theorem PFcons0_fcons_inv: Proof. intros l a l1; induction l1 as [|e l1 IHl1]; simpl Fcons0. - simpl; now split. -- generalize (ring_correct O l nil a e). lazy zeta; simpl Peq. +- generalize (ring_correct O l nil a e); unfold ring_checker. lazy zeta; simpl Peq. case Peq; intros H; rewrite !PCond_cons; intros (H1,H2); repeat split; trivial. + now rewrite H. diff --git a/theories/setoid_ring/Ncring_polynom.v b/theories/setoid_ring/Ncring_polynom.v index c8f92fec10..e009c90fd4 100644 --- a/theories/setoid_ring/Ncring_polynom.v +++ b/theories/setoid_ring/Ncring_polynom.v @@ -421,17 +421,6 @@ Qed. (** Definition of polynomial expressions *) -(* - Inductive PExpr : Type := - | PEc : C -> PExpr - | PEX : positive -> PExpr - | PEadd : PExpr -> PExpr -> PExpr - | PEsub : PExpr -> PExpr -> PExpr - | PEmul : PExpr -> PExpr -> PExpr - | PEopp : PExpr -> PExpr - | PEpow : PExpr -> N -> PExpr. -*) - (** Specification of the power function *) Section POWER. Variable Cpow : Set. diff --git a/theories/setoid_ring/Ring_polynom.v b/theories/setoid_ring/Ring_polynom.v index 469f9c7b79..3d46fb0234 100644 --- a/theories/setoid_ring/Ring_polynom.v +++ b/theories/setoid_ring/Ring_polynom.v @@ -10,6 +10,7 @@ Set Implicit Arguments. +From Stdlib Require Export ring_checker. From Stdlib Require Import Setoid Morphisms. From Stdlib Require Import BinList BinPos BinNat BinInt. From Stdlib Require Export Ring_theory. @@ -99,404 +100,45 @@ Section MakeRingPol. match goal with |- ?t == _ => mul_permut_rec t end). - (* Definition of multivariable polynomials with coefficients in C : - Type [Pol] represents [X1 ... Xn]. - The representation is Horner's where a [n] variable polynomial - (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients - are polynomials with [n-1] variables (C[X2..Xn]). - There are several optimisations to make the repr compacter: - - [Pc c] is the constant polynomial of value c - == c*X1^0*..*Xn^0 - - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. - variable indices are shifted of j in Q. - == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - - [PX P i Q] is an optimised Horner form of P*X^i + Q - with P not the null polynomial - == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} - - In addition: - - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden - since they can be represented by the simpler form (PX P (i+j) Q) - - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - - (Pinj i (Pc c)) is (Pc c) - *) - - Inductive Pol : Type := - | Pc : C -> Pol - | Pinj : positive -> Pol -> Pol - | PX : Pol -> positive -> Pol -> Pol. - - Definition P0 := Pc cO. - Definition P1 := Pc cI. - - Fixpoint Peq (P P' : Pol) {struct P'} : bool := - match P, P' with - | Pc c, Pc c' => c ?=! c' - | Pinj j Q, Pinj j' Q' => - match 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. + (* Definition of multivariable polynomials with coefficients in C *) + + #[local] Notation Pol := (Pol C). + #[local] Notation P0 := (P0 cO). + #[local] Notation P1 := (P1 cI). + #[local] Notation Peq := (Peq ceqb). + #[local] Notation mkX := (mkX cO cI). + #[local] Notation mkPinj := (@mkPinj C). + #[local] Notation mkPX := (mkPX cO ceqb). + #[local] Notation Popp := (Popp copp). + #[local] Notation PaddC := (PaddC cadd). + #[local] Notation PsubC := (PsubC csub). + #[local] Notation Padd := (Padd cO cadd ceqb). + #[local] Notation PaddI := (PaddI cadd Padd). + #[local] Notation Psub := (Psub cO cadd csub copp ceqb). + #[local] Notation PsubI := (PsubI cadd copp Psub). + #[local] Notation PaddX := (PaddX cO ceqb Padd). + #[local] Notation PsubX := (PsubX cO copp ceqb Psub). + #[local] Notation PmulC_aux := (PmulC_aux cO cmul ceqb). + #[local] Notation PmulC := (PmulC cO cI cmul ceqb). + #[local] Notation Pmul := (Pmul cO cI cadd cmul ceqb). + #[local] Notation PmulI := (PmulI cO cI cmul ceqb Pmul). 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. (** 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 CFactor (P: Pol) (c: C) {struct P}: Pol * Pol := - match P with - | Pc c1 => let (q,r) := cdiv c1 c in (Pc r, Pc q) - | Pinj j1 P1 => - let (R,S) := CFactor P1 c in - (mkPinj j1 R, mkPinj j1 S) - | PX P1 i Q1 => - let (R1, S1) := CFactor P1 c in - let (R2, S2) := CFactor Q1 c in - (mkPX R1 i R2, mkPX S1 i S2) - end. - - Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol := - match P, M with - _, mon0 => if (ceqb c cI) then (Pc cO, P) else CFactor P c - | Pc _, _ => (P, Pc cO) - | Pinj j1 P1, zmon j2 M1 => - match j1 ?= j2 with - Eq => let (R,S) := MFactor P1 c M1 in - (mkPinj j1 R, mkPinj j1 S) - | Lt => let (R,S) := MFactor P1 c (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 c M in - let (R2, S2) := MFactor Q1 c 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 c (mkZmon xH M1) in - (mkPX R1 i Q1, S1) - | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in - (mkPX R1 i Q1, S1) - | Gt => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in - (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) - end - end. - - Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol := - let (c,M1) := cM1 in - let (Q1,R1) := MFactor P1 c 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) (cM1: C * Mon) (P2: Pol) (n: nat) : Pol := - match POneSubst P1 cM1 P2 with - Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end - | _ => P1 - end. - - Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol := - match POneSubst P1 cM1 P2 with - Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end - | _ => None - end. - - Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * 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 ((C * 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 ((C * 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. + #[local] Notation CFactor := (CFactor cO ceqb cdiv). + #[local] Notation MFactor := (MFactor cO cI ceqb cdiv). + #[local] Notation POneSubst := (POneSubst cO cI cadd cmul ceqb cdiv). + #[local] Notation PNSubst1 := (PNSubst1 cO cI cadd cmul ceqb cdiv). + #[local] Notation PNSubst := (PNSubst cO cI cadd cmul ceqb cdiv). + #[local] Notation PSubstL1 := (PSubstL1 cO cI cadd cmul ceqb cdiv). + #[local] Notation PSubstL := (PSubstL cO cI cadd cmul ceqb cdiv). + #[local] Notation PNSubstL := (PNSubstL cO cI cadd cmul ceqb cdiv). (** Evaluation of a polynomial towards R *) @@ -685,7 +327,7 @@ Section MakeRingPol. 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. + (PaddX P' k P) @ l == P@l + P'@l * (hd l)^k. Proof. intros IHP'. revert k l. induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros. @@ -736,7 +378,6 @@ Section MakeRingPol. - destruct P as [|p0 P|P2 p0 P3]; simpl; try reflexivity. + destruct p0; now apply PX_ext. + destr_pos_sub; intros ->; apply mkPX_ext; auto. - let p1 := match goal with |- PsubX _ _ ?p1 _ === _ => p1 end in revert p1. induction P2; simpl; intros; try reflexivity. destr_pos_sub; intros ->; now apply mkPX_ext. Qed. @@ -748,7 +389,7 @@ Section MakeRingPol. 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). + forall P p l, (PmulI P' p P) @ l == P @ l * P' @ (jump p l). Proof. intros IHP' P. induction P as [|p P IHP|? IHP1 ? ? IHP2];simpl;intros p0 l. @@ -914,19 +555,10 @@ Section MakeRingPol. (** Definition of polynomial expressions *) - Inductive PExpr : Type := - | PEO : PExpr - | PEI : PExpr - | 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. + #[local] Notation PExpr := (PExpr C). (** evaluation of polynomial expressions towards R *) - Definition mk_X j := mkPinj_pred j mkX. + Definition mk_X := mkX. (** evaluation of polynomial expressions towards R *) @@ -935,7 +567,7 @@ Section MakeRingPol. | PEO => rO | PEI => rI | PEc c => phi c - | PEX j => nth 0 j l + | PEX _ j => nth 0 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) @@ -956,20 +588,11 @@ Strategy expand [PEeval]. Hint Rewrite Padd_ok Psub_ok : Esimpl. +#[local] Notation Ppow_pos := (Ppow_pos cO cI cadd cmul ceqb). +#[local] Notation Ppow_N := (Ppow_N cO cI cadd cmul ceqb). + 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) -> @@ -999,29 +622,14 @@ Section POWER. Variable lmp:list (C*Mon*Pol). Let subst_l P := PNSubstL P lmp n n. Let Pmul_subst P1 P2 := subst_l (P1 ** P2). - Let Ppow_subst := Ppow_N subst_l. - - Fixpoint norm_aux (pe:PExpr) : Pol := - match pe with - | PEO => Pc cO - | PEI => Pc cI - | PEc c => Pc c - | PEX j => mk_X j - | PEadd (PEopp pe1) pe2 => (norm_aux pe2) -- (norm_aux pe1) - | PEadd pe1 (PEopp pe2) => (norm_aux pe1) -- (norm_aux pe2) - | PEadd pe1 pe2 => (norm_aux pe1) ++ (norm_aux pe2) - | PEsub pe1 pe2 => (norm_aux pe1) -- (norm_aux pe2) - | PEmul pe1 pe2 => (norm_aux pe1) ** (norm_aux pe2) - | PEopp pe1 => -- (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). + #[local] Notation norm_aux := (Pol_of_PExpr cO cI cadd cmul csub copp ceqb). + #[local] Notation norm_subst := (norm_subst cO cI cadd cmul csub copp ceqb cdiv n lmp). (** Internally, [norm_aux] is expanded in a large number of cases. To speed-up proofs, we use an alternative definition. *) - Definition get_PEopp pe := + Definition get_PEopp (pe : PExpr) := match pe with | PEopp pe' => Some pe' | _ => None @@ -1049,7 +657,7 @@ Section POWER. now destruct pe. Qed. - Arguments norm_aux !pe : simpl nomatch. + Arguments Pol_of_PExpr _ _ _ _ _ _ _ _ !pe : simpl nomatch. Lemma norm_aux_spec l pe : PEeval l pe == (norm_aux pe)@l. @@ -1069,7 +677,7 @@ Section POWER. - rewrite IHpe1, IHpe2. Esimpl. - rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - rewrite IHpe. Esimpl. - - rewrite Ppow_N_ok by reflexivity. + - rewrite (Ppow_N_ok id) by reflexivity. rewrite (rpow_pow_N pow_th). destruct n0 as [|p]; simpl; Esimpl. induction p as [p IHp|p IHp|];simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. @@ -1084,6 +692,7 @@ Section POWER. Qed. End NORM_SUBST_REC. + #[local] Notation norm_subst := (norm_subst cO cI cadd cmul csub copp ceqb cdiv). Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop := match lpe with @@ -1095,32 +704,9 @@ Section POWER. end end. - Fixpoint mon_of_pol (P:Pol) : option (C * Mon) := - match P with - | Pc c => if (c ?=! cO) then None else Some (c, mon0) - | Pinj j P => - match mon_of_pol P with - | None => None - | Some (c,m) => Some (c, mkZmon j m) - end - | PX P i Q => - if Peq Q P0 then - match mon_of_pol P with - | None => None - | Some (c,m) => Some (c, mkVmon i m) - end - else None - end. - - Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) := - match lpe with - | nil => nil - | (me,pe)::lpe => - match mon_of_pol (norm_subst 0 nil me) with - | None => mk_monpol_list lpe - | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe - end - end. + #[local] Notation mon_of_pol := (Mon_of_Pol cO ceqb). + #[local] Notation mk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv). + #[local] Notation ring_checker := (ring_checker cO cI cadd cmul csub copp ceqb cdiv). Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> forall l, [fst m] * Mphi l (snd m) == P@l. @@ -1177,8 +763,7 @@ Section POWER. Lemma ring_correct : forall n l lpe pe1 pe2, interp_PElist l lpe -> - (let lmp := mk_monpol_list lpe in - norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true -> + ring_checker n lpe pe1 pe2 = true -> PEeval l pe1 == PEeval l pe2. Proof. simpl;intros n l lpe pe1 pe2 **. @@ -1509,3 +1094,5 @@ End MakeRingPol. Arguments PEO {C}. Arguments PEI {C}. + +Notation norm_aux := Pol_of_PExpr. diff --git a/theories/setoid_ring/ring_checker.v b/theories/setoid_ring/ring_checker.v new file mode 100644 index 0000000000..8ef0738ea8 --- /dev/null +++ b/theories/setoid_ring/ring_checker.v @@ -0,0 +1 @@ +From micromega_plugin Require Export ring_checker. diff --git a/theories/setoid_ring/ring_eval.v b/theories/setoid_ring/ring_eval.v new file mode 100644 index 0000000000..7044caf939 --- /dev/null +++ b/theories/setoid_ring/ring_eval.v @@ -0,0 +1 @@ +From micromega_plugin Require Export ring_eval. From 502983c3b3d92769de4b969daf486a9900a5ca75 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Sat, 30 Aug 2025 19:03:56 +0200 Subject: [PATCH 06/12] Move field_checker.v to micromega-plugin --- subcomponents/field.v | 1 + theories/setoid_ring/Field_theory.v | 273 +++++---------------------- theories/setoid_ring/field_checker.v | 1 + theories/setoid_ring/field_eval.v | 1 + 4 files changed, 47 insertions(+), 229 deletions(-) create mode 100644 theories/setoid_ring/field_checker.v create mode 100644 theories/setoid_ring/field_eval.v diff --git a/subcomponents/field.v b/subcomponents/field.v index b95bcc6f26..6967748aca 100644 --- a/subcomponents/field.v +++ b/subcomponents/field.v @@ -1,2 +1,3 @@ From subcomponents Require ring. From Stdlib Require setoid_ring.Field. +From Stdlib Require setoid_ring.field_eval. diff --git a/theories/setoid_ring/Field_theory.v b/theories/setoid_ring/Field_theory.v index 9a9c03c31d..eff22b0e2f 100644 --- a/theories/setoid_ring/Field_theory.v +++ b/theories/setoid_ring/Field_theory.v @@ -10,6 +10,7 @@ From Corelib Require Import RelationClasses Setoid Morphisms. From Stdlib Require Import BinNat BinInt. +From Stdlib Require Export field_checker. From Stdlib.setoid_ring Require Import Ring_base Ring_polynom Ring_tac Ring_theory InitialRing. Set Implicit Arguments. @@ -553,23 +554,10 @@ Qed. ***************************************************************************) -#[local] Notation "a &&& b" := (if a then b else false) - (at level 40, left associativity). - (* equality test *) -Fixpoint PExpr_eq (e e' : PExpr C) {struct e} : bool := - match e, e' with - | PEc c, PEc c' => ceqb c c' - | PEX _ p, PEX _ p' => Pos.eqb p p' - | e1 + e2, e1' + e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' - | e1 - e2, e1' - e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' - | e1 * e2, e1' * e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2' - | - e, - e' => PExpr_eq e e' - | e ^ n, e' ^ n' => N.eqb n n' &&& PExpr_eq e e' - | _, _ => false - end%poly. - -Lemma if_true (a b : bool) : a &&& b = true -> a = true /\ b = true. +#[local] Notation PExpr_eq := (PExpr_eq ceqb). + +Lemma if_true (a b : bool) : andb a b = true -> a = true /\ b = true. Proof. destruct a, b; split; trivial. Qed. @@ -578,7 +566,7 @@ Theorem PExpr_eq_semi_ok e e' : PExpr_eq e e' = true -> (e === e')%poly. Proof. revert e'; induction e as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe|? IHe ?]; - intro e'; destruct e'; simpl; try discriminate. + intro e'; destruct e'; simpl; try reflexivity; try discriminate. - intros H l. now apply (morph_eq CRmorph). - case Pos.eqb_spec; intros; now subst. - intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2. @@ -598,15 +586,16 @@ Qed. (** Smart constructors for polynomial expression, with reduction of constants *) -Definition NPEadd e1 e2 := - match e1, e2 with - | PEc c1, PEc c2 => PEc (c1 + c2) - | PEc c, _ => if (c =? 0)%coef then e2 else e1 + e2 - | _, PEc c => if (c =? 0)%coef then e1 else e1 + e2 - (* Peut t'on factoriser ici ??? *) - | _, _ => (e1 + e2) - end%poly. +#[local] Notation NPEadd := (NPEadd cO cadd ceqb). +#[local] Notation NPEsub := (NPEsub cO csub ceqb). +#[local] Notation NPEopp := (NPEopp copp). +#[local] Notation NPEpow := (NPEpow cO cI (pow_pos cmul) ceqb). +#[local] Notation NPEmul := (NPEmul cO cI cmul (pow_pos cmul) ceqb). + Infix "++" := NPEadd (at level 60, right associativity). +Infix "--" := NPEsub (at level 50, left associativity). +Infix "^^" := NPEpow (at level 35, right associativity). +Infix "**" := NPEmul (at level 40, left associativity). Theorem NPEadd_ok e1 e2 : (e1 ++ e2 === e1 + e2)%poly. Proof. @@ -617,16 +606,6 @@ try apply eq_refl; try (ring [phi_0]). apply (morph_add CRmorph). Qed. -Definition NPEsub e1 e2 := - match e1, e2 with - | PEc c1, PEc c2 => PEc (c1 - c2) - | PEc c, _ => if (c =? 0)%coef then - e2 else e1 - e2 - | _, PEc c => if (c =? 0)%coef then e1 else e1 - e2 - (* Peut-on factoriser ici *) - | _, _ => e1 - e2 - end%poly. -Infix "--" := NPEsub (at level 50, left associativity). - Theorem NPEsub_ok e1 e2: (e1 -- e2 === e1 - e2)%poly. Proof. intros l. @@ -637,29 +616,11 @@ destruct e1, e2; simpl; try reflexivity; try case ceqb_spec; apply (morph_sub CRmorph). Qed. -Definition NPEopp e1 := - match e1 with PEc c1 => PEc (- c1) | _ => - e1 end%poly. - Theorem NPEopp_ok e : (NPEopp e === -e)%poly. Proof. intros l. destruct e; simpl; trivial. apply (morph_opp CRmorph). Qed. -Definition NPEpow x n := - match n with - | N0 => 1 - | Npos p => - if (p =? 1)%positive then x else - match x with - | PEc c => - if (c =? 1)%coef then 1 - else if (c =? 0)%coef then 0 - else PEc (pow_pos cmul c p) - | _ => x ^ n - end - end%poly. -Infix "^^" := NPEpow (at level 35, right associativity). - Theorem NPEpow_ok e n : (e ^^ n === e ^ n)%poly. Proof. intros l. unfold NPEpow; destruct n. @@ -673,16 +634,6 @@ Proof. * now rewrite pow_pos_cst. Qed. -Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := - match x, y with - | PEc c1, PEc c2 => PEc (c1 * c2) - | PEc c, _ => if (c =? 1)%coef then y else if (c =? 0)%coef then 0 else x * y - | _, PEc c => if (c =? 1)%coef then x else if (c =? 0)%coef then 0 else x * y - | e1 ^ n1, e2 ^ n2 => if (n1 =? n2)%N then (NPEmul e1 e2)^^n1 else x * y - | _, _ => x * y - end%poly. -Infix "**" := NPEmul (at level 40, left associativity). - Theorem NPEmul_ok e1 e2 : (e1 ** e2 === e1 * e2)%poly. Proof. intros l. @@ -697,16 +648,8 @@ revert e2; induction e1 as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe1 ? IHe2|? I destruct n; simpl; [ ring | apply pow_pos_mul_l ]. Qed. -(* simplification *) -Fixpoint PEsimp (e : PExpr C) : PExpr C := - match e with - | e1 + e2 => (PEsimp e1) ++ (PEsimp e2) - | e1 * e2 => (PEsimp e1) ** (PEsimp e2) - | e1 - e2 => (PEsimp e1) -- (PEsimp e2) - | - e1 => NPEopp (PEsimp e1) - | e1 ^ n1 => (PEsimp e1) ^^ n1 - | _ => e - end%poly. +#[local] Notation PEsimp := (PEsimp + cO cI cadd cmul csub copp (pow_pos cmul) ceqb). Theorem PEsimp_ok e : (PEsimp e === e)%poly. Proof. @@ -731,18 +674,7 @@ Qed. (* The input: syntax of a field expression *) -Inductive FExpr : Type := - | FEO : FExpr - | FEI : FExpr - | FEc: C -> FExpr - | FEX: positive -> FExpr - | FEadd: FExpr -> FExpr -> FExpr - | FEsub: FExpr -> FExpr -> FExpr - | FEmul: FExpr -> FExpr -> FExpr - | FEopp: FExpr -> FExpr - | FEinv: FExpr -> FExpr - | FEdiv: FExpr -> FExpr -> FExpr - | FEpow: FExpr -> N -> FExpr . +#[local] Notation FExpr := (FExpr C). Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := match pe with @@ -763,10 +695,7 @@ Strategy expand [FEeval]. (* The result of the normalisation *) -Record linear : Type := mk_linear { - num : PExpr C; - denum : PExpr C; - condition : list (PExpr C) }. +#[local] Notation linear := (linear C). (*************************************************************************** @@ -807,9 +736,7 @@ induction l1 as [|a l1 IHl1]. - simpl app. rewrite !PCond_cons, IHl1. symmetry; apply and_assoc. Qed. - -(* An unsatisfiable condition: issued when a division by zero is detected *) -Definition absurd_PCond := cons 0%poly nil. +#[local] Notation absurd_PCond := (absurd_PCond cO). Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond. Proof. @@ -825,35 +752,8 @@ Qed. ***************************************************************************) -Definition default_isIn e1 p1 e2 p2 := - if PExpr_eq e1 e2 then - match Z.pos_sub p1 p2 with - | Zpos p => Some (Npos p, 1%poly) - | Z0 => Some (N0, 1%poly) - | Zneg p => Some (N0, e2 ^^ Npos p) - end - else None. - -Fixpoint isIn e1 p1 e2 p2 {struct e2}: option (N * PExpr C) := - match e2 with - | e3 * e4 => - match isIn e1 p1 e3 p2 with - | Some (N0, e5) => Some (N0, e5 ** (e4 ^^ Npos p2)) - | Some (Npos p, e5) => - match isIn e1 p e4 p2 with - | Some (n, e6) => Some (n, e5 ** e6) - | None => Some (Npos p, e5 ** (e4 ^^ Npos p2)) - end - | None => - match isIn e1 p1 e4 p2 with - | Some (n, e5) => Some (n, (e3 ^^ Npos p2) ** e5) - | None => None - end - end - | e3 ^ N0 => None - | e3 ^ Npos p3 => isIn e1 p1 e3 (Pos.mul p3 p2) - | _ => default_isIn e1 p1 e2 p2 - end%poly. +#[local] Notation default_isIn := (default_isIn cO cI (pow_pos cmul) ceqb). +#[local] Notation isIn := (isIn cO cI cmul (pow_pos cmul) ceqb). Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. @@ -873,7 +773,7 @@ Fixpoint isIn e1 p1 e2 p2 {struct e2}: option (N * PExpr C) := | _ => True end. Proof. - unfold default_isIn. + unfold field_checker.default_isIn. case PExpr_eq_spec; trivial. intros EQ. rewrite Z.pos_sub_spec. case Pos.compare_spec;intros H; split; try reflexivity. @@ -900,7 +800,7 @@ Theorem isIn_ok e1 p1 e2 p2 : | _ => True end. Proof. -Opaque NPEpow. +Opaque field_checker.NPEpow. revert p1 p2. induction e2 as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe2_1 ? IHe2_2|? IHe|? IHe2 n]; intros p1 p2; try refine (default_isIn_ok e1 _ p1 p2); simpl isIn. @@ -949,33 +849,14 @@ induction e2 as [| |?|?|? IHe1 ? IHe2|? IHe1 ? IHe2|? IHe2_1 ? IHe2_2|? IHe|? IH now rewrite <- PEpow_mul_r. Qed. -Record rsplit : Type := mk_rsplit { - rsplit_left : PExpr C; - rsplit_common : PExpr C; - rsplit_right : PExpr C}. - (* Stupid name clash *) -Notation left := rsplit_left. -Notation right := rsplit_right. -Notation common := rsplit_common. - -Fixpoint split_aux e1 p e2 {struct e1}: rsplit := - match e1 with - | e3 * e4 => - let r1 := split_aux e3 p e2 in - let r2 := split_aux e4 p (right r1) in - mk_rsplit (left r1 ** left r2) - (common r1 ** common r2) - (right r2) - | e3 ^ N0 => mk_rsplit 1 1 e2 - | e3 ^ Npos p3 => split_aux e3 (Pos.mul p3 p) e2 - | _ => - match isIn e1 p e2 1 with - | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3 - | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3 - | None => mk_rsplit (e1 ^^ Npos p) 1 e2 - end - end%poly. +Notation rsplit := (rsplit C). +Notation left := (@rsplit_left C). +Notation right := (@rsplit_right C). +Notation common := (@rsplit_common C). + +#[local] Notation split_aux := (split_aux cO cI cmul (pow_pos cmul) ceqb). +#[local] Notation split := (field_checker.split cO cI cmul (pow_pos cmul) ceqb). Lemma split_aux_ok1 e1 p e2 : (let res := match isIn e1 p e2 1 with @@ -987,7 +868,7 @@ Lemma split_aux_ok1 e1 p e2 : e1 ^ Npos p === left res * common res /\ e2 === right res * common res)%poly. Proof. - Opaque NPEpow NPEmul. + Opaque field_checker.NPEpow field_checker.NPEmul. intros res. unfold res;clear res; generalize (isIn_ok e1 p e2 xH). destruct (isIn e1 p e2 1) as [([|p'],e')|]; simpl. - intros (H1,H2); split; npe_simpl. @@ -1018,8 +899,6 @@ intro e1;induction e1 as [| |?|?|? IHe1_1 ? IHe1_2|? IHe1_1 ? IHe1_2|e1_1 IHe1_1 + rewrite <- PEpow_mul_r. simpl. apply IHe1. Qed. -Definition split e1 e2 := split_aux e1 xH e2. - Theorem split_ok_l e1 e2 : (e1 === left (split e1 e2) * common (split e1 e2))%poly. Proof. @@ -1046,54 +925,8 @@ Proof. now rewrite H, rmul_0_l. Qed. -Fixpoint Fnorm (e : FExpr) : linear := - match e with - | FEO => mk_linear 0 1 nil - | FEI => mk_linear 1 1 nil - | FEc c => mk_linear (PEc c) 1 nil - | FEX x => mk_linear (PEX C x) 1 nil - | FEadd e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s := split (denum x) (denum y) in - mk_linear - ((num x ** right s) ++ (num y ** left s)) - (left s ** (right s ** common s)) - (condition x ++ condition y)%list - | FEsub e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s := split (denum x) (denum y) in - mk_linear - ((num x ** right s) -- (num y ** left s)) - (left s ** (right s ** common s)) - (condition x ++ condition y)%list - | FEmul e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s1 := split (num x) (denum y) in - let s2 := split (num y) (denum x) in - mk_linear (left s1 ** left s2) - (right s2 ** right s1) - (condition x ++ condition y)%list - | FEopp e1 => - let x := Fnorm e1 in - mk_linear (NPEopp (num x)) (denum x) (condition x) - | FEinv e1 => - let x := Fnorm e1 in - mk_linear (denum x) (num x) (num x :: condition x) - | FEdiv e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s1 := split (num x) (num y) in - let s2 := split (denum x) (denum y) in - mk_linear (left s1 ** right s2) - (left s2 ** right s1) - (num y :: condition x ++ condition y)%list - | FEpow e1 n => - let x := Fnorm e1 in - mk_linear ((num x)^^n) ((denum x)^^n) (condition x) - end. +#[local] Notation Fnorm := (Fnorm + cO cI cadd cmul csub copp (pow_pos cmul) ceqb). (* Example *) (* @@ -1459,11 +1292,7 @@ Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C). Hypothesis PCond_fcons_inv : forall l a l1, PCond l (Fcons a l1) -> ~ a @ l == 0 /\ PCond l l1. -Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) := - match l with - | nil => m - | cons a l1 => Fcons a (Fapp l1 m) - end. +#[local] Notation Fapp := (Fapp Fcons). Lemma fcons_ok : forall l l1, (forall lock, lock = PCond l -> lock (Fapp l1 nil)) -> PCond l l1. @@ -1500,14 +1329,7 @@ intros l a l1; induction l1 as [|e l1 IHl1]; simpl Fcons. + now apply IHl1. Qed. -(* equality of normal forms rather than syntactic equality *) -Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := - match l with - nil => cons e nil - | cons a l1 => - if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l - else cons a (Fcons0 e l1) - end. +#[local] Notation Fcons0 := (Fcons0 cO cI cadd cmul csub copp ceqb). Theorem PFcons0_fcons_inv: forall l a l1, PCond l (Fcons0 a l1) -> ~ a @ l == 0 /\ PCond l l1. @@ -1515,6 +1337,8 @@ Proof. intros l a l1; induction l1 as [|e l1 IHl1]; simpl Fcons0. - simpl; now split. - generalize (ring_correct O l nil a e); unfold ring_checker. lazy zeta; simpl Peq. + set (na := norm_aux _ _ _ _ _ _ _ a); change na with (Nnorm 0 nil a). + set (ne := norm_aux _ _ _ _ _ _ _ e); change ne with (Nnorm 0 nil e). case Peq; intros H; rewrite !PCond_cons; intros (H1,H2); repeat split; trivial. + now rewrite H. @@ -1522,13 +1346,7 @@ intros l a l1; induction l1 as [|e l1 IHl1]; simpl Fcons0. + now apply IHl1. Qed. -(* split factorized denominators *) -Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := - match e with - PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l) - | PEpow e1 _ => Fcons00 e1 l - | _ => Fcons0 e l - end. +#[local] Notation Fcons00 := (Fcons00 cO cI cadd cmul csub copp ceqb). Theorem PFcons00_fcons_inv: forall l a l1, PCond l (Fcons00 a l1) -> ~ a @ l == 0 /\ PCond l l1. @@ -1563,14 +1381,7 @@ destruct (ceqb c1 c2); constructor. - intro E. specialize (H' E). discriminate. Qed. -Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := - match e with - | PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) - | PEpow e _ => Fcons1 e l - | PEopp e => if (-(1) =? 0)%coef then absurd_PCond else Fcons1 e l - | PEc c => if (c =? 0)%coef then absurd_PCond else l - | _ => Fcons0 e l - end. +#[local] Notation Fcons1 := (Fcons1 cO cI cadd cmul csub copp ceqb). Theorem PFcons1_fcons_inv: forall l a l1, PCond l (Fcons1 a l1) -> ~ a @ l == 0 /\ PCond l l1. @@ -1594,7 +1405,8 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail). - intros ? H ? ? H0. destruct (H _ H0);split;trivial. apply PEpow_nz; trivial. Qed. -Definition Fcons2 e l := Fcons1 (PEsimp e) l. +#[local] Notation Fcons2 := (Fcons2 + cO cI cadd cmul csub copp (pow_pos cmul) ceqb). Theorem PFcons2_fcons_inv: forall l a l1, PCond l (Fcons2 a l1) -> ~ a @ l == 0 /\ PCond l l1. @@ -1825,5 +1637,8 @@ End Field. End Complete. +Notation Fnorm := (fun cO cI cadd cmul csub copp ceqb => + Fnorm cO cI cadd cmul csub copp (pow_pos cmul) ceqb). + Arguments FEO {C}. Arguments FEI {C}. diff --git a/theories/setoid_ring/field_checker.v b/theories/setoid_ring/field_checker.v new file mode 100644 index 0000000000..068be6c950 --- /dev/null +++ b/theories/setoid_ring/field_checker.v @@ -0,0 +1 @@ +From micromega_plugin Require Export field_checker. diff --git a/theories/setoid_ring/field_eval.v b/theories/setoid_ring/field_eval.v new file mode 100644 index 0000000000..878b3b82ff --- /dev/null +++ b/theories/setoid_ring/field_eval.v @@ -0,0 +1 @@ +From micromega_plugin Require Export field_eval. From 74474e1f7de84054c7d2d45261d9b669f0168ac1 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Sun, 10 Aug 2025 16:03:16 +0200 Subject: [PATCH 07/12] Remove rtyp Was purely redundant with eKind --- theories/micromega/QMicromega.v | 5 +- theories/micromega/RMicromega.v | 7 +-- theories/micromega/Tauto.v | 93 ++++++++++++++++----------------- theories/micromega/ZMicromega.v | 4 +- 4 files changed, 55 insertions(+), 54 deletions(-) diff --git a/theories/micromega/QMicromega.v b/theories/micromega/QMicromega.v index c823961e09..0cca873d1b 100644 --- a/theories/micromega/QMicromega.v +++ b/theories/micromega/QMicromega.v @@ -14,6 +14,7 @@ (* *) (************************************************************************) +From Stdlib Require Import micromega.Tauto. From Stdlib Require Import OrderedRing. From Stdlib Require Import RingMicromega. From Stdlib Require Import Refl. @@ -153,8 +154,8 @@ Proof. - apply Qlt_bool_iff. Qed. -Definition Qeval_op2 (k:Tauto.kind) : Op2 -> Q -> Q -> Tauto.rtyp k:= - if k as k0 return (Op2 -> Q -> Q -> Tauto.rtyp k0) +Definition Qeval_op2 (k:kind) : Op2 -> Q -> Q -> eKind k:= + if k as k0 return (Op2 -> Q -> Q -> eKind k0) then Qeval_pop2 else Qeval_bop2. diff --git a/theories/micromega/RMicromega.v b/theories/micromega/RMicromega.v index 20be99ead1..cdd0af4e8b 100644 --- a/theories/micromega/RMicromega.v +++ b/theories/micromega/RMicromega.v @@ -14,6 +14,7 @@ (* *) (************************************************************************) +From Stdlib Require Import micromega.Tauto. From Stdlib Require Import OrderedRing. From Stdlib Require Import QMicromega RingMicromega. From Stdlib Require Import Refl. @@ -419,8 +420,8 @@ Proof. - apply Rlt_not_le in H. tauto. Qed. -Definition Reval_op2 (k: Tauto.kind) : Op2 -> R -> R -> Tauto.rtyp k:= - if k as k0 return (Op2 -> R -> R -> Tauto.rtyp k0) +Definition Reval_op2 (k: kind) : Op2 -> R -> R -> eKind k:= + if k as k0 return (Op2 -> R -> R -> eKind k0) then Reval_pop2 else Reval_bop2. Lemma Reval_op2_hold : forall b op q1 q2, @@ -526,7 +527,7 @@ Proof. unfold RTautoChecker. intros TC env. apply tauto_checker_sound with (eval:=QReval_formula) (eval':= Qeval_nformula) (env := env) in TC. - - change (eval_f e_rtyp (QReval_formula env)) + - change (eval_f e_eKind (QReval_formula env)) with (eval_bf (QReval_formula env)) in TC. rewrite eval_bf_map in TC. diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index 3790039c1c..594bbc5ab7 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -29,6 +29,9 @@ Inductive kind : Type := Register isProp as micromega.kind.isProp. Register isBool as micromega.kind.isBool. +Definition eKind (k: kind) := if k then Prop else bool. +Register eKind as micromega.eKind. + Inductive Trace (A : Type) := | null : Trace A | push : A -> Trace A -> Trace A @@ -127,42 +130,40 @@ Section S. | NOT f => collect_annot f end. - Definition rtyp (k: kind) : Type := if k then Prop else bool. - - Variable ex : forall (k: kind), TX k -> rtyp k. (* [ex] will be the identity *) + Variable ex : forall (k: kind), TX k -> eKind k. (* [ex] will be the identity *) Section EVAL. - Variable ea : forall (k: kind), TA -> rtyp k. + Variable ea : forall (k: kind), TA -> eKind k. - Definition eTT (k: kind) : rtyp k := - if k as k' return rtyp k' then True else true. + Definition eTT (k: kind) : eKind k := + if k as k' return eKind k' then True else true. - Definition eFF (k: kind) : rtyp k := - if k as k' return rtyp k' then False else false. + Definition eFF (k: kind) : eKind k := + if k as k' return eKind k' then False else false. - Definition eAND (k: kind) : rtyp k -> rtyp k -> rtyp k := - if k as k' return rtyp k' -> rtyp k' -> rtyp k' + Definition eAND (k: kind) : eKind k -> eKind k -> eKind k := + if k as k' return eKind k' -> eKind k' -> eKind k' then and else andb. - Definition eOR (k: kind) : rtyp k -> rtyp k -> rtyp k := - if k as k' return rtyp k' -> rtyp k' -> rtyp k' + Definition eOR (k: kind) : eKind k -> eKind k -> eKind k := + if k as k' return eKind k' -> eKind k' -> eKind k' then or else orb. - Definition eIMPL (k: kind) : rtyp k -> rtyp k -> rtyp k := - if k as k' return rtyp k' -> rtyp k' -> rtyp k' + Definition eIMPL (k: kind) : eKind k -> eKind k -> eKind k := + if k as k' return eKind k' -> eKind k' -> eKind k' then (fun x y => x -> y) else implb. - Definition eIFF (k: kind) : rtyp k -> rtyp k -> rtyp k := - if k as k' return rtyp k' -> rtyp k' -> rtyp k' + Definition eIFF (k: kind) : eKind k -> eKind k -> eKind k := + if k as k' return eKind k' -> eKind k' -> eKind k' then iff else eqb. - Definition eNOT (k: kind) : rtyp k -> rtyp k := - if k as k' return rtyp k' -> rtyp k' + Definition eNOT (k: kind) : eKind k -> eKind k := + if k as k' return eKind k' -> eKind k' then not else negb. - Fixpoint eval_f (k: kind) (f:GFormula k) {struct f}: rtyp k := - match f in GFormula k' return rtyp k' with + Fixpoint eval_f (k: kind) (f:GFormula k) {struct f}: eKind k := + match f in GFormula k' return eKind k' with | TT tk => eTT tk | FF tk => eFF tk | A k a _ => ea k a @@ -177,7 +178,7 @@ Section S. Lemma eval_f_rew : forall k (f:GFormula k), eval_f f = - match f in GFormula k' return rtyp k' with + match f in GFormula k' return eKind k' with | TT tk => eTT tk | FF tk => eFF tk | A k a _ => ea k a @@ -196,29 +197,29 @@ Section S. End EVAL. - Definition hold (k: kind) : rtyp k -> Prop := - if k as k0 return (rtyp k0 -> Prop) then fun x => x else is_true. + Definition hold (k: kind) : eKind k -> Prop := + if k as k0 return (eKind k0 -> Prop) then fun x => x else is_true. - Definition eiff (k: kind) : rtyp k -> rtyp k -> Prop := - if k as k' return rtyp k' -> rtyp k' -> Prop then iff else @eq bool. + Definition eiff (k: kind) : eKind k -> eKind k -> Prop := + if k as k' return eKind k' -> eKind k' -> Prop then iff else @eq bool. - Lemma eiff_refl (k: kind) (x : rtyp k) : + Lemma eiff_refl (k: kind) (x : eKind k) : eiff k x x. Proof. destruct k ; simpl; tauto. Qed. - Lemma eiff_sym k (x y : rtyp k) : eiff k x y -> eiff k y x. + Lemma eiff_sym k (x y : eKind k) : eiff k x y -> eiff k y x. Proof. destruct k ; simpl; intros ; intuition. Qed. - Lemma eiff_trans k (x y z : rtyp k) : eiff k x y -> eiff k y z -> eiff k x z. + Lemma eiff_trans k (x y z : eKind k) : eiff k x y -> eiff k y z -> eiff k x z. Proof. destruct k ; simpl; intros ; intuition congruence. Qed. - Lemma hold_eiff (k: kind) (x y : rtyp k) : + Lemma hold_eiff (k: kind) (x y : eKind k) : (hold k x <-> hold k y) <-> eiff k x y. Proof. destruct k ; simpl. @@ -266,7 +267,7 @@ Section S. Qed. Lemma eval_f_morph : - forall (ev ev' : forall (k: kind), TA -> rtyp k), + forall (ev ev' : forall (k: kind), TA -> eKind k), (forall k a, eiff k (ev k a) (ev' k a)) -> forall (k: kind)(f : GFormula k), (eiff k (eval_f ev f) (eval_f ev' f)). @@ -293,8 +294,6 @@ End S. Hint Extern 2 (subrelation (eiff _) _) => progress cbn : typeclass_instances. (** Typical boolean formulae *) -Definition eKind (k: kind) := if k then Prop else bool. -Register eKind as micromega.eKind. Definition BFormula (A : Type) := @GFormula A eKind unit unit. @@ -1713,13 +1712,13 @@ Section S. } Qed. - Variable eval : Env -> forall (k: kind), Term -> rtyp k. + Variable eval : Env -> forall (k: kind), Term -> eKind k. Variable normalise_correct : forall env b t tg, eval_cnf env (normalise t tg) -> hold b (eval env b t). Variable negate_correct : forall env b t tg, eval_cnf env (negate t tg) -> hold b (eNOT b (eval env b t)). - Definition e_rtyp (k: kind) (x : rtyp k) : rtyp k := x. + Definition e_eKind (k: kind) (x : eKind k) : eKind k := x. Lemma hold_eTT : forall k, hold k (eTT k). Proof. @@ -1795,13 +1794,13 @@ Section S. (f2 : GFormula k) (IHf1 : forall (pol : bool) (env : Env), eval_cnf env (xcnf pol f1) -> - hold k (eval_f e_rtyp (eval env) (if pol then f1 else NOT f1))) + hold k (eval_f e_eKind (eval env) (if pol then f1 else NOT f1))) (IHf2 : forall (pol : bool) (env : Env), eval_cnf env (xcnf pol f2) -> - hold k (eval_f e_rtyp (eval env) (if pol then f2 else NOT f2))), + hold k (eval_f e_eKind (eval env) (if pol then f2 else NOT f2))), forall (pol : bool) (env : Env), eval_cnf env (xcnf pol (IMPL f1 o f2)) -> - hold k (eval_f e_rtyp (eval env) (if pol then IMPL f1 o f2 else NOT (IMPL f1 o f2))). + hold k (eval_f e_eKind (eval env) (if pol then IMPL f1 o f2 else NOT (IMPL f1 o f2))). Proof. simpl; intros k f1 o f2 IHf1 IHf2 pol env H. unfold mk_impl in H. destruct pol. @@ -1851,16 +1850,16 @@ Section S. Lemma xcnf_iff : forall (k : kind) - (f1 f2 : @GFormula Term rtyp Annot unit k) + (f1 f2 : @GFormula Term eKind Annot unit k) (IHf1 : forall (pol : bool) (env : Env), eval_cnf env (xcnf pol f1) -> - hold k (eval_f e_rtyp (eval env) (if pol then f1 else NOT f1))) + hold k (eval_f e_eKind (eval env) (if pol then f1 else NOT f1))) (IHf2 : forall (pol : bool) (env : Env), eval_cnf env (xcnf pol f2) -> - hold k (eval_f e_rtyp (eval env) (if pol then f2 else NOT f2))), + hold k (eval_f e_eKind (eval env) (if pol then f2 else NOT f2))), forall (pol : bool) (env : Env), eval_cnf env (xcnf pol (IFF f1 f2)) -> - hold k (eval_f e_rtyp (eval env) (if pol then IFF f1 f2 else NOT (IFF f1 f2))). + hold k (eval_f e_eKind (eval env) (if pol then IFF f1 f2 else NOT (IFF f1 f2))). Proof. simpl. intros k f1 f2 IHf1 IHf2 pol env H. @@ -1890,8 +1889,8 @@ Section S. tauto. Qed. - Lemma xcnf_correct : forall (k: kind) (f : @GFormula Term rtyp Annot unit k) pol env, - eval_cnf env (xcnf pol f) -> hold k (eval_f e_rtyp (eval env) (if pol then f else NOT f)). + Lemma xcnf_correct : forall (k: kind) (f : @GFormula Term eKind Annot unit k) pol env, + eval_cnf env (xcnf pol f) -> hold k (eval_f e_eKind (eval env) (if pol then f else NOT f)). Proof. intros k f; induction f as [| | | |? ? IHf1 ? IHf2|? ? IHf1 ? IHf2|? ? IHf @@ -2053,19 +2052,19 @@ Section S. tauto. Qed. - Definition tauto_checker (f:@GFormula Term rtyp Annot unit isProp) (w:list Witness) : bool := + Definition tauto_checker (f:@GFormula Term eKind Annot unit isProp) (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 e_rtyp (eval env) t. + Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f e_eKind (eval env) t. Proof. unfold tauto_checker. intros t w H env. - change (eval_f e_rtyp (eval env) t) with (eval_f e_rtyp (eval env) (if true then t else TT isProp)). + change (eval_f e_eKind (eval env) t) with (eval_f e_eKind (eval env) (if true then t else TT isProp)). apply (xcnf_correct t true). eapply cnf_checker_sound ; eauto. Qed. - Definition eval_bf {A : Type} (ea : forall (k: kind), A -> rtyp k) (k: kind) (f: BFormula A k) := eval_f e_rtyp ea f. + Definition eval_bf {A : Type} (ea : forall (k: kind), A -> eKind k) (k: kind) (f: BFormula A k) := eval_f e_eKind ea f. Lemma eval_bf_map : forall T U (fct: T-> U) env (k: kind) (f:BFormula T k) , eval_bf env (map_bformula fct f) = eval_bf (fun b x => env b (fct x)) f. diff --git a/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v index f27aafa120..102f0d1095 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -180,8 +180,8 @@ Proof. - rewrite <- Z.gtb_gt; tauto. Qed. -Definition Zeval_op2 (k: Tauto.kind) : Op2 -> Z -> Z -> Tauto.rtyp k:= - if k as k0 return (Op2 -> Z -> Z -> Tauto.rtyp k0) +Definition Zeval_op2 (k: kind) : Op2 -> Z -> Z -> eKind k:= + if k as k0 return (Op2 -> Z -> Z -> eKind k0) then Zeval_pop2 else Zeval_bop2. From f86335968885362e3171ba927eae63c84dcb62f1 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 6 Aug 2025 10:47:03 +0200 Subject: [PATCH 08/12] Factor common defs with ring --- .gitignore | 1 - test-suite/micromega/witness_tactics.v | 54 - test-suite/output/InfoMicromega.v | 2 +- test-suite/output/MExtraction.out | 2603 ------------------------ test-suite/output/MExtraction.v | 68 - theories/micromega/EnvRing.v | 395 +--- theories/micromega/Lia.v | 3 +- theories/micromega/Lqa.v | 3 +- theories/micromega/Lra.v | 3 +- theories/micromega/Psatz.v | 3 +- theories/micromega/QMicromega.v | 74 +- theories/micromega/RMicromega.v | 38 +- theories/micromega/RingMicromega.v | 324 +-- theories/micromega/Tauto.v | 367 +--- theories/micromega/ZMicromega.v | 112 +- theories/micromega/Zify.v | 2 +- theories/micromega/ZifyInst.v | 2 +- 17 files changed, 243 insertions(+), 3811 deletions(-) delete mode 100644 test-suite/micromega/witness_tactics.v delete mode 100644 test-suite/output/MExtraction.out delete mode 100644 test-suite/output/MExtraction.v diff --git a/.gitignore b/.gitignore index 84f86a2ac4..1580471939 100644 --- a/.gitignore +++ b/.gitignore @@ -84,7 +84,6 @@ test-suite/coq-makefile/merlin1/.merlin test-suite/coqdoc/Coqdoc.* test-suite/coqdoc/index.html test-suite/coqdoc/coqdoc.css -test-suite/output/MExtraction.out test-suite/output/*.out.real test-suite/oUnit-anon.cache test-suite/redirect_test.out diff --git a/test-suite/micromega/witness_tactics.v b/test-suite/micromega/witness_tactics.v deleted file mode 100644 index c4c12066e5..0000000000 --- a/test-suite/micromega/witness_tactics.v +++ /dev/null @@ -1,54 +0,0 @@ -From Stdlib Require Import ZArith QArith. -From Stdlib.micromega Require Import RingMicromega EnvRing Tauto. -From Stdlib.micromega Require Import ZMicromega QMicromega. - -Declare ML Module "rocq-runtime.plugins.micromega". - -Goal True. -Proof. -pose (ff := - IMPL - (EQ - (A isBool - {| - Flhs := PEadd (PEX 1) (PEmul (PEc 2%Q) (PEX 2)); - Fop := OpLe; - Frhs := PEc 3%Q - |} tt) (TT isBool)) None - (IMPL - (EQ - (A isBool - {| - Flhs := PEadd (PEmul (PEc 2%Q) (PEX 1)) (PEX 2); - Fop := OpLe; - Frhs := PEc 3%Q - |} tt) (TT isBool)) None - (EQ - (A isBool - {| Flhs := PEadd (PEX 1) (PEX 2); Fop := OpLe; Frhs := PEc 2%Q |} tt) - (TT isBool))) : BFormula (Formula Q) isProp). -let ff' := eval unfold ff in ff in wlra_Q wit0 ff'. -Check eq_refl : wit0 = (PsatzAdd (PsatzIn Q 2) - (PsatzAdd (PsatzIn Q 1) (PsatzMulE (PsatzC 3%Q) (PsatzIn Q 0))) :: nil)%list. -let ff' := eval unfold ff in ff in wlia wit1 ff'. -Check eq_refl : wit1 = (RatProof (PsatzAdd (PsatzIn Z 2) (PsatzAdd (PsatzIn Z 1) - (PsatzIn Z 0))) DoneProof :: nil)%list. -let ff' := eval unfold ff in ff in wnia wit4 ff'. -Check eq_refl : wit4 = (RatProof (PsatzAdd (PsatzIn Z 2) (PsatzAdd (PsatzIn Z 1) - (PsatzIn Z 0))) DoneProof :: nil)%list. -let ff' := eval unfold ff in ff in wnra_Q wit5 ff'. -Check eq_refl : wit5 = (PsatzAdd (PsatzIn Q 2) - (PsatzAdd (PsatzIn Q 1) (PsatzMulE (PsatzC 3%Q) (PsatzIn Q 0))) :: nil)%list. -Fail let ff' := eval unfold ff in ff in wsos_Q wit6 ff'. -Fail let ff' := eval unfold ff in ff in wsos_Z wit6 ff'. -(* Requires Csdp, not in CI -let ff' := eval unfold ff in ff in wpsatz_Z 3 wit2 ff'. -Check eq_refl : wit2 = (RatProof (PsatzAdd (PsatzC 1) - (PsatzAdd (PsatzIn Z 2) (PsatzAdd (PsatzIn Z 1) (PsatzIn Z 0)))) DoneProof - :: nil)%list. -let ff' := eval unfold ff in ff in wpsatz_Q 3 wit3 ff'. -Check eq_refl : wit3 = (PsatzAdd (PsatzIn Q 0) - (PsatzAdd (PsatzMulE (PsatzIn Q 2) (PsatzC (1 # 2))) - (PsatzAdd (PsatzMulE (PsatzIn Q 1) (PsatzC (1 # 2))) - (PsatzMulE (PsatzIn Q 0) (PsatzC (1 # 2))))) :: nil)%list. *) -Abort. diff --git a/test-suite/output/InfoMicromega.v b/test-suite/output/InfoMicromega.v index 094245f16d..795b5ac4db 100644 --- a/test-suite/output/InfoMicromega.v +++ b/test-suite/output/InfoMicromega.v @@ -1,7 +1,7 @@ From Stdlib Require Import Reals Lra. Open Scope R_scope. -Set Info Micromega. +Set Micromega Info. Goal forall (x y z:R), x + y > 0 -> x - y > 0 -> x + z = 0 -> x < 0 -> False. Proof. diff --git a/test-suite/output/MExtraction.out b/test-suite/output/MExtraction.out deleted file mode 100644 index a1ab5d3224..0000000000 --- a/test-suite/output/MExtraction.out +++ /dev/null @@ -1,2603 +0,0 @@ - -type __ = Obj.t - -type unit0 = -| Tt - -(** val negb : bool -> bool **) - -let negb = function -| true -> false -| false -> true - -type nat = -| O -| S of nat - -type ('a, 'b) sum = -| Inl of 'a -| Inr of 'b - -(** val fst : ('a1 * 'a2) -> 'a1 **) - -let fst = function -| x,_ -> x - -(** val snd : ('a1 * 'a2) -> 'a2 **) - -let snd = function -| _,y -> y - -(** val app : 'a1 list -> 'a1 list -> 'a1 list **) - -let rec app l m = - match l with - | [] -> m - | a::l1 -> a::(app l1 m) - -type comparison = -| Eq -| Lt -| Gt - -(** val compOpp : comparison -> comparison **) - -let compOpp = function -| Eq -> Eq -| Lt -> Gt -| Gt -> Lt - -module Coq__1 = struct - (** val add : nat -> nat -> nat **) - - let rec add n0 m = - match n0 with - | O -> m - | S p -> S (add p m) -end -include Coq__1 - -(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) - -let rec map f = function -| [] -> [] -| a::l0 -> (f a)::(map f l0) - -(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) - -let rec nth n0 l default = - match n0 with - | O -> (match l with - | [] -> default - | x::_ -> x) - | S m -> (match l with - | [] -> default - | _::l' -> nth m l' default) - -(** val rev_append : 'a1 list -> 'a1 list -> 'a1 list **) - -let rec rev_append l l' = - match l with - | [] -> l' - | a::l0 -> rev_append l0 (a::l') - -(** val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 **) - -let rec fold_left f l a0 = - match l with - | [] -> a0 - | b::l0 -> fold_left f l0 (f a0 b) - -(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) - -let rec fold_right f a0 = function -| [] -> a0 -| b::l0 -> f b (fold_right f a0 l0) - -type positive = -| XI of positive -| XO of positive -| XH - -type n = -| N0 -| Npos of positive - -type z = -| Z0 -| Zpos of positive -| Zneg of positive - -module Pos = - struct - (** val succ : positive -> positive **) - - let rec succ = function - | XI p -> XO (succ p) - | XO p -> XI p - | XH -> XO XH - - (** val add : positive -> positive -> positive **) - - let rec add x y = - match x with - | XI p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XO p -> - (match y with - | XI q0 -> XI (add p q0) - | XO q0 -> XO (add p q0) - | XH -> XI p) - | XH -> (match y with - | XI q0 -> XO (succ q0) - | XO q0 -> XI q0 - | XH -> XO XH) - - (** val add_carry : positive -> positive -> positive **) - - and add_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> XI (add_carry p q0) - | XO q0 -> XO (add_carry p q0) - | XH -> XI (succ p)) - | XO p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XH -> - (match y with - | XI q0 -> XI (succ q0) - | XO q0 -> XO (succ q0) - | XH -> XI XH) - - (** val pred_double : positive -> positive **) - - let rec pred_double = function - | XI p -> XI (XO p) - | XO p -> XI (pred_double p) - | XH -> XH - - type mask = - | IsNul - | IsPos of positive - | IsNeg - - (** val mul : positive -> positive -> positive **) - - let rec mul x y = - match x with - | XI p -> add y (XO (mul p y)) - | XO p -> XO (mul p y) - | XH -> y - - (** val iter : ('a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) - - let rec iter f x = function - | XI n' -> f (iter f (iter f x n') n') - | XO n' -> iter f (iter f x n') n' - | XH -> f x - - (** val compare_cont : comparison -> positive -> positive -> comparison **) - - let rec compare_cont r x y = - match x with - | XI p -> - (match y with - | XI q0 -> compare_cont r p q0 - | XO q0 -> compare_cont Gt p q0 - | XH -> Gt) - | XO p -> - (match y with - | XI q0 -> compare_cont Lt p q0 - | XO q0 -> compare_cont r p q0 - | XH -> Gt) - | XH -> (match y with - | XH -> r - | _ -> Lt) - - (** val compare : positive -> positive -> comparison **) - - let compare = - compare_cont Eq - - (** val eqb : positive -> positive -> bool **) - - let rec eqb p q0 = - match p with - | XI p2 -> (match q0 with - | XI q1 -> eqb p2 q1 - | _ -> false) - | XO p2 -> (match q0 with - | XO q1 -> eqb p2 q1 - | _ -> false) - | XH -> (match q0 with - | XH -> true - | _ -> false) - - (** val of_succ_nat : nat -> positive **) - - let rec of_succ_nat = function - | O -> XH - | S x -> succ (of_succ_nat x) - end - -module Coq_Pos = - struct - (** val succ : positive -> positive **) - - let rec succ = function - | XI p -> XO (succ p) - | XO p -> XI p - | XH -> XO XH - - (** val add : positive -> positive -> positive **) - - let rec add x y = - match x with - | XI p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XO p -> - (match y with - | XI q0 -> XI (add p q0) - | XO q0 -> XO (add p q0) - | XH -> XI p) - | XH -> (match y with - | XI q0 -> XO (succ q0) - | XO q0 -> XI q0 - | XH -> XO XH) - - (** val add_carry : positive -> positive -> positive **) - - and add_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> XI (add_carry p q0) - | XO q0 -> XO (add_carry p q0) - | XH -> XI (succ p)) - | XO p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XH -> - (match y with - | XI q0 -> XI (succ q0) - | XO q0 -> XO (succ q0) - | XH -> XI XH) - - (** val pred_double : positive -> positive **) - - let rec pred_double = function - | XI p -> XI (XO p) - | XO p -> XI (pred_double p) - | XH -> XH - - type mask = Pos.mask = - | IsNul - | IsPos of positive - | IsNeg - - (** val succ_double_mask : mask -> mask **) - - let succ_double_mask = function - | IsNul -> IsPos XH - | IsPos p -> IsPos (XI p) - | IsNeg -> IsNeg - - (** val double_mask : mask -> mask **) - - let double_mask = function - | IsPos p -> IsPos (XO p) - | x0 -> x0 - - (** val double_pred_mask : positive -> mask **) - - let double_pred_mask = function - | XI p -> IsPos (XO (XO p)) - | XO p -> IsPos (XO (pred_double p)) - | XH -> IsNul - - (** val sub_mask : positive -> positive -> mask **) - - let rec sub_mask x y = - match x with - | XI p -> - (match y with - | XI q0 -> double_mask (sub_mask p q0) - | XO q0 -> succ_double_mask (sub_mask p q0) - | XH -> IsPos (XO p)) - | XO p -> - (match y with - | XI q0 -> succ_double_mask (sub_mask_carry p q0) - | XO q0 -> double_mask (sub_mask p q0) - | XH -> IsPos (pred_double p)) - | XH -> (match y with - | XH -> IsNul - | _ -> IsNeg) - - (** val sub_mask_carry : positive -> positive -> mask **) - - and sub_mask_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> succ_double_mask (sub_mask_carry p q0) - | XO q0 -> double_mask (sub_mask p q0) - | XH -> IsPos (pred_double p)) - | XO p -> - (match y with - | XI q0 -> double_mask (sub_mask_carry p q0) - | XO q0 -> succ_double_mask (sub_mask_carry p q0) - | XH -> double_pred_mask p) - | XH -> IsNeg - - (** val sub : positive -> positive -> positive **) - - let sub x y = - match sub_mask x y with - | IsPos z0 -> z0 - | _ -> XH - - (** val mul : positive -> positive -> positive **) - - let rec mul x y = - match x with - | XI p -> add y (XO (mul p y)) - | XO p -> XO (mul p y) - | XH -> y - - (** val compare_cont : comparison -> positive -> positive -> comparison **) - - let rec compare_cont r x y = - match x with - | XI p -> - (match y with - | XI q0 -> compare_cont r p q0 - | XO q0 -> compare_cont Gt p q0 - | XH -> Gt) - | XO p -> - (match y with - | XI q0 -> compare_cont Lt p q0 - | XO q0 -> compare_cont r p q0 - | XH -> Gt) - | XH -> (match y with - | XH -> r - | _ -> Lt) - - (** val compare : positive -> positive -> comparison **) - - let compare = - compare_cont Eq - - (** val leb : positive -> positive -> bool **) - - let leb x y = - match compare x y with - | Gt -> false - | _ -> true - - (** val size_nat : positive -> nat **) - - let rec size_nat = function - | XI p2 -> S (size_nat p2) - | XO p2 -> S (size_nat p2) - | XH -> S O - - (** val max : positive -> positive -> positive **) - - let max p p' = - match compare p p' with - | Gt -> p - | _ -> p' - - (** val gcdn : nat -> positive -> positive -> positive **) - - let rec gcdn n0 a b = - match n0 with - | O -> XH - | S n1 -> - (match a with - | XI a' -> - (match b with - | XI b' -> - (match compare a' b' with - | Eq -> a - | Lt -> gcdn n1 (sub b' a') a - | Gt -> gcdn n1 (sub a' b') b) - | XO b0 -> gcdn n1 a b0 - | XH -> XH) - | XO a0 -> - (match b with - | XI _ -> gcdn n1 a0 b - | XO b0 -> XO (gcdn n1 a0 b0) - | XH -> XH) - | XH -> XH) - - (** val gcd : positive -> positive -> positive **) - - let gcd a b = - gcdn (Coq__1.add (size_nat a) (size_nat b)) a b - end - -module N = - struct - (** val of_nat : nat -> n **) - - let of_nat = function - | O -> N0 - | S n' -> Npos (Pos.of_succ_nat n') - end - -module Z = - struct - (** val double : z -> z **) - - let double = function - | Z0 -> Z0 - | Zpos p -> Zpos (XO p) - | Zneg p -> Zneg (XO p) - - (** val succ_double : z -> z **) - - let succ_double = function - | Z0 -> Zpos XH - | Zpos p -> Zpos (XI p) - | Zneg p -> Zneg (Pos.pred_double p) - - (** val pred_double : z -> z **) - - let pred_double = function - | Z0 -> Zneg XH - | Zpos p -> Zpos (Pos.pred_double p) - | Zneg p -> Zneg (XI p) - - (** val pos_sub : positive -> positive -> z **) - - let rec pos_sub x y = - match x with - | XI p -> - (match y with - | XI q0 -> double (pos_sub p q0) - | XO q0 -> succ_double (pos_sub p q0) - | XH -> Zpos (XO p)) - | XO p -> - (match y with - | XI q0 -> pred_double (pos_sub p q0) - | XO q0 -> double (pos_sub p q0) - | XH -> Zpos (Pos.pred_double p)) - | XH -> - (match y with - | XI q0 -> Zneg (XO q0) - | XO q0 -> Zneg (Pos.pred_double q0) - | XH -> Z0) - - (** val add : z -> z -> z **) - - let add x y = - match x with - | Z0 -> y - | Zpos x' -> - (match y with - | Z0 -> x - | Zpos y' -> Zpos (Pos.add x' y') - | Zneg y' -> pos_sub x' y') - | Zneg x' -> - (match y with - | Z0 -> x - | Zpos y' -> pos_sub y' x' - | Zneg y' -> Zneg (Pos.add x' y')) - - (** val opp : z -> z **) - - let opp = function - | Z0 -> Z0 - | Zpos x0 -> Zneg x0 - | Zneg x0 -> Zpos x0 - - (** val sub : z -> z -> z **) - - let sub m n0 = - add m (opp n0) - - (** val mul : z -> z -> z **) - - let mul x y = - match x with - | Z0 -> Z0 - | Zpos x' -> - (match y with - | Z0 -> Z0 - | Zpos y' -> Zpos (Pos.mul x' y') - | Zneg y' -> Zneg (Pos.mul x' y')) - | Zneg x' -> - (match y with - | Z0 -> Z0 - | Zpos y' -> Zneg (Pos.mul x' y') - | Zneg y' -> Zpos (Pos.mul x' y')) - - (** val pow_pos : z -> positive -> z **) - - let pow_pos z0 = - Pos.iter (mul z0) (Zpos XH) - - (** val pow : z -> z -> z **) - - let pow x = function - | Z0 -> Zpos XH - | Zpos p -> pow_pos x p - | Zneg _ -> Z0 - - (** val compare : z -> z -> comparison **) - - let compare x y = - match x with - | Z0 -> (match y with - | Z0 -> Eq - | Zpos _ -> Lt - | Zneg _ -> Gt) - | Zpos x' -> (match y with - | Zpos y' -> Pos.compare x' y' - | _ -> Gt) - | Zneg x' -> - (match y with - | Zneg y' -> compOpp (Pos.compare x' y') - | _ -> Lt) - - (** val leb : z -> z -> bool **) - - let leb x y = - match compare x y with - | Gt -> false - | _ -> true - - (** val ltb : z -> z -> bool **) - - let ltb x y = - match compare x y with - | Lt -> true - | _ -> false - - (** val eqb : z -> z -> bool **) - - let eqb x y = - match x with - | Z0 -> (match y with - | Z0 -> true - | _ -> false) - | Zpos p -> (match y with - | Zpos q0 -> Pos.eqb p q0 - | _ -> false) - | Zneg p -> (match y with - | Zneg q0 -> Pos.eqb p q0 - | _ -> false) - - (** val max : z -> z -> z **) - - let max n0 m = - match compare n0 m with - | Lt -> m - | _ -> n0 - - (** val of_nat : nat -> z **) - - let of_nat = function - | O -> Z0 - | S n1 -> Zpos (Pos.of_succ_nat n1) - - (** val of_N : n -> z **) - - let of_N = function - | N0 -> Z0 - | Npos p -> Zpos p - - (** val pos_div_eucl : positive -> z -> z * z **) - - let rec pos_div_eucl a b = - match a with - | XI a' -> - let q0,r = pos_div_eucl a' b in - let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in - if ltb r' b - then (mul (Zpos (XO XH)) q0),r' - else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) - | XO a' -> - let q0,r = pos_div_eucl a' b in - let r' = mul (Zpos (XO XH)) r in - if ltb r' b - then (mul (Zpos (XO XH)) q0),r' - else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) - | XH -> if leb (Zpos (XO XH)) b then Z0,(Zpos XH) else (Zpos XH),Z0 - - (** val div_eucl : z -> z -> z * z **) - - let div_eucl a b = - match a with - | Z0 -> Z0,Z0 - | Zpos a' -> - (match b with - | Z0 -> Z0,a - | Zpos _ -> pos_div_eucl a' b - | Zneg b' -> - let q0,r = pos_div_eucl a' (Zpos b') in - (match r with - | Z0 -> (opp q0),Z0 - | _ -> (opp (add q0 (Zpos XH))),(add b r))) - | Zneg a' -> - (match b with - | Z0 -> Z0,a - | Zpos _ -> - let q0,r = pos_div_eucl a' b in - (match r with - | Z0 -> (opp q0),Z0 - | _ -> (opp (add q0 (Zpos XH))),(sub b r)) - | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in q0,(opp r)) - - (** val div : z -> z -> z **) - - let div a b = - let q0,_ = div_eucl a b in q0 - - (** val gtb : z -> z -> bool **) - - let gtb x y = - match compare x y with - | Gt -> true - | _ -> false - - (** val abs : z -> z **) - - let abs = function - | Zneg p -> Zpos p - | x -> x - - (** val to_N : z -> n **) - - let to_N = function - | Zpos p -> Npos p - | _ -> N0 - - (** val gcd : z -> z -> z **) - - let gcd a b = - match a with - | Z0 -> abs b - | Zpos a0 -> - (match b with - | Z0 -> abs a - | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) - | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) - | Zneg a0 -> - (match b with - | Z0 -> abs a - | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) - | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) - end - -(** val pow_pos0 : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) - -let rec pow_pos0 rmul x = function -| XI i0 -> let p = pow_pos0 rmul x i0 in rmul x (rmul p p) -| XO i0 -> let p = pow_pos0 rmul x i0 in rmul p p -| XH -> x - -type kind = -| IsProp -| IsBool - -type 'a trace = -| Null -| Push of 'a * 'a trace -| Merge of 'a trace * 'a trace - -type ('tA, 'tX, 'aA, 'aF) gFormula = -| TT of kind -| FF of kind -| X of kind * 'tX -| A of kind * 'tA * 'aA -| AND of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula -| OR of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula -| NOT of kind * ('tA, 'tX, 'aA, 'aF) gFormula -| IMPL of kind * ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option - * ('tA, 'tX, 'aA, 'aF) gFormula -| IFF of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula -| EQ of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula - -(** val mapX : - (kind -> 'a2 -> 'a2) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, - 'a2, 'a3, 'a4) gFormula **) - -let rec mapX f _ = function -| X (k0, x) -> X (k0, (f k0 x)) -| AND (k0, f1, f2) -> AND (k0, (mapX f k0 f1), (mapX f k0 f2)) -| OR (k0, f1, f2) -> OR (k0, (mapX f k0 f1), (mapX f k0 f2)) -| NOT (k0, f1) -> NOT (k0, (mapX f k0 f1)) -| IMPL (k0, f1, o, f2) -> IMPL (k0, (mapX f k0 f1), o, (mapX f k0 f2)) -| IFF (k0, f1, f2) -> IFF (k0, (mapX f k0 f1), (mapX f k0 f2)) -| EQ (f1, f2) -> EQ ((mapX f IsBool f1), (mapX f IsBool f2)) -| x -> x - -(** val foldA : - ('a5 -> 'a3 -> 'a5) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 **) - -let rec foldA f _ f0 acc = - match f0 with - | A (_, _, an) -> f acc an - | AND (k0, f1, f2) -> foldA f k0 f1 (foldA f k0 f2 acc) - | OR (k0, f1, f2) -> foldA f k0 f1 (foldA f k0 f2 acc) - | NOT (k0, f1) -> foldA f k0 f1 acc - | IMPL (k0, f1, _, f2) -> foldA f k0 f1 (foldA f k0 f2 acc) - | IFF (k0, f1, f2) -> foldA f k0 f1 (foldA f k0 f2 acc) - | EQ (f1, f2) -> foldA f IsBool f1 (foldA f IsBool f2 acc) - | _ -> acc - -(** val cons_id : 'a1 option -> 'a1 list -> 'a1 list **) - -let cons_id id l = - match id with - | Some id0 -> id0::l - | None -> l - -(** val ids_of_formula : kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list **) - -let rec ids_of_formula _ = function -| IMPL (k0, _, id, f') -> cons_id id (ids_of_formula k0 f') -| _ -> [] - -(** val collect_annot : kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list **) - -let rec collect_annot _ = function -| A (_, _, a) -> a::[] -| AND (k0, f1, f2) -> app (collect_annot k0 f1) (collect_annot k0 f2) -| OR (k0, f1, f2) -> app (collect_annot k0 f1) (collect_annot k0 f2) -| NOT (k0, f0) -> collect_annot k0 f0 -| IMPL (k0, f1, _, f2) -> app (collect_annot k0 f1) (collect_annot k0 f2) -| IFF (k0, f1, f2) -> app (collect_annot k0 f1) (collect_annot k0 f2) -| EQ (f1, f2) -> app (collect_annot IsBool f1) (collect_annot IsBool f2) -| _ -> [] - -type rtyp = __ - -type eKind = __ - -type 'a bFormula = ('a, eKind, unit0, unit0) gFormula - -(** val map_bformula : - kind -> ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, - 'a5) gFormula **) - -let rec map_bformula _ fct = function -| TT k -> TT k -| FF k -> FF k -| X (k, p) -> X (k, p) -| A (k, a, t0) -> A (k, (fct a), t0) -| AND (k0, f1, f2) -> - AND (k0, (map_bformula k0 fct f1), (map_bformula k0 fct f2)) -| OR (k0, f1, f2) -> - OR (k0, (map_bformula k0 fct f1), (map_bformula k0 fct f2)) -| NOT (k0, f0) -> NOT (k0, (map_bformula k0 fct f0)) -| IMPL (k0, f1, a, f2) -> - IMPL (k0, (map_bformula k0 fct f1), a, (map_bformula k0 fct f2)) -| IFF (k0, f1, f2) -> - IFF (k0, (map_bformula k0 fct f1), (map_bformula k0 fct f2)) -| EQ (f1, f2) -> - EQ ((map_bformula IsBool fct f1), (map_bformula IsBool fct f2)) - -type ('x, 'annot) clause = ('x * 'annot) list - -type ('x, 'annot) cnf = ('x, 'annot) clause list - -(** val cnf_tt : ('a1, 'a2) cnf **) - -let cnf_tt = - [] - -(** val cnf_ff : ('a1, 'a2) cnf **) - -let cnf_ff = - []::[] - -(** val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) - clause -> ('a1, 'a2) clause option **) - -let rec add_term unsat deduce t0 = function -| [] -> - (match deduce (fst t0) (fst t0) with - | Some u -> if unsat u then None else Some (t0::[]) - | None -> Some (t0::[])) -| t'::cl0 -> - (match deduce (fst t0) (fst t') with - | Some u -> - if unsat u - then None - else (match add_term unsat deduce t0 cl0 with - | Some cl' -> Some (t'::cl') - | None -> None) - | None -> - (match add_term unsat deduce t0 cl0 with - | Some cl' -> Some (t'::cl') - | None -> None)) - -(** val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, - 'a2) clause -> ('a1, 'a2) clause option **) - -let rec or_clause unsat deduce cl1 cl2 = - match cl1 with - | [] -> Some cl2 - | t0::cl -> - (match add_term unsat deduce t0 cl2 with - | Some cl' -> or_clause unsat deduce cl cl' - | None -> None) - -(** val xor_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf **) - -let xor_clause_cnf unsat deduce t0 f = - fold_left (fun acc e -> - match or_clause unsat deduce t0 e with - | Some cl -> cl::acc - | None -> acc) f [] - -(** val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf **) - -let or_clause_cnf unsat deduce t0 f = - match t0 with - | [] -> f - | _::_ -> xor_clause_cnf unsat deduce t0 f - -(** val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf **) - -let rec or_cnf unsat deduce f f' = - match f with - | [] -> cnf_tt - | e::rst -> - rev_append (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') - -(** val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) - -let and_cnf = - rev_append - -type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula - -(** val is_cnf_tt : ('a1, 'a2) cnf -> bool **) - -let is_cnf_tt = function -| [] -> true -| _::_ -> false - -(** val is_cnf_ff : ('a1, 'a2) cnf -> bool **) - -let is_cnf_ff = function -| [] -> false -| c0::l -> - (match c0 with - | [] -> (match l with - | [] -> true - | _::_ -> false) - | _::_ -> false) - -(** val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) - -let and_cnf_opt f1 f2 = - if if is_cnf_ff f1 then true else is_cnf_ff f2 - then cnf_ff - else if is_cnf_tt f2 then f1 else and_cnf f1 f2 - -(** val or_cnf_opt : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf **) - -let or_cnf_opt unsat deduce f1 f2 = - if if is_cnf_tt f1 then true else is_cnf_tt f2 - then cnf_tt - else if is_cnf_ff f2 then f1 else or_cnf unsat deduce f1 f2 - -(** val mk_and : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, - 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf **) - -let mk_and unsat deduce rEC k pol0 f1 f2 = - if pol0 - then and_cnf_opt (rEC pol0 k f1) (rEC pol0 k f2) - else or_cnf_opt unsat deduce (rEC pol0 k f1) (rEC pol0 k f2) - -(** val mk_or : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, - 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf **) - -let mk_or unsat deduce rEC k pol0 f1 f2 = - if pol0 - then or_cnf_opt unsat deduce (rEC pol0 k f1) (rEC pol0 k f2) - else and_cnf_opt (rEC pol0 k f1) (rEC pol0 k f2) - -(** val mk_impl : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, - 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf **) - -let mk_impl unsat deduce rEC k pol0 f1 f2 = - if pol0 - then or_cnf_opt unsat deduce (rEC (negb pol0) k f1) (rEC pol0 k f2) - else and_cnf_opt (rEC (negb pol0) k f1) (rEC pol0 k f2) - -(** val mk_iff : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, - 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf **) - -let mk_iff unsat deduce rEC k pol0 f1 f2 = - or_cnf_opt unsat deduce - (and_cnf_opt (rEC (negb pol0) k f1) (rEC false k f2)) - (and_cnf_opt (rEC pol0 k f1) (rEC true k f2)) - -(** val is_bool : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool option **) - -let is_bool _ = function -| TT _ -> Some true -| FF _ -> Some false -| _ -> None - -(** val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) - cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> kind -> ('a1, 'a3, 'a4, - 'a5) tFormula -> ('a2, 'a3) cnf **) - -let rec xcnf unsat deduce normalise1 negate0 pol0 _ = function -| TT _ -> if pol0 then cnf_tt else cnf_ff -| FF _ -> if pol0 then cnf_ff else cnf_tt -| X (_, _) -> cnf_ff -| A (_, x, t0) -> if pol0 then normalise1 x t0 else negate0 x t0 -| AND (k0, e1, e2) -> - mk_and unsat deduce (fun x x0 x1 -> - xcnf unsat deduce normalise1 negate0 x x0 x1) k0 pol0 e1 e2 -| OR (k0, e1, e2) -> - mk_or unsat deduce (fun x x0 x1 -> - xcnf unsat deduce normalise1 negate0 x x0 x1) k0 pol0 e1 e2 -| NOT (k0, e) -> xcnf unsat deduce normalise1 negate0 (negb pol0) k0 e -| IMPL (k0, e1, _, e2) -> - mk_impl unsat deduce (fun x x0 x1 -> - xcnf unsat deduce normalise1 negate0 x x0 x1) k0 pol0 e1 e2 -| IFF (k0, e1, e2) -> - (match is_bool k0 e2 with - | Some isb -> - xcnf unsat deduce normalise1 negate0 (if isb then pol0 else negb pol0) - k0 e1 - | None -> - mk_iff unsat deduce (fun x x0 x1 -> - xcnf unsat deduce normalise1 negate0 x x0 x1) k0 pol0 e1 e2) -| EQ (e1, e2) -> - (match is_bool IsBool e2 with - | Some isb -> - xcnf unsat deduce normalise1 negate0 (if isb then pol0 else negb pol0) - IsBool e1 - | None -> - mk_iff unsat deduce (fun x x0 x1 -> - xcnf unsat deduce normalise1 negate0 x x0 x1) IsBool pol0 e1 e2) - -(** val radd_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) - clause -> (('a1, 'a2) clause, 'a2 trace) sum **) - -let rec radd_term unsat deduce t0 = function -| [] -> - (match deduce (fst t0) (fst t0) with - | Some u -> if unsat u then Inr (Push ((snd t0), Null)) else Inl (t0::[]) - | None -> Inl (t0::[])) -| t'::cl0 -> - (match deduce (fst t0) (fst t') with - | Some u -> - if unsat u - then Inr (Push ((snd t0), (Push ((snd t'), Null)))) - else (match radd_term unsat deduce t0 cl0 with - | Inl cl' -> Inl (t'::cl') - | Inr l -> Inr l) - | None -> - (match radd_term unsat deduce t0 cl0 with - | Inl cl' -> Inl (t'::cl') - | Inr l -> Inr l)) - -(** val ror_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, - 'a2) clause -> (('a1, 'a2) clause, 'a2 trace) sum **) - -let rec ror_clause unsat deduce cl1 cl2 = - match cl1 with - | [] -> Inl cl2 - | t0::cl -> - (match radd_term unsat deduce t0 cl2 with - | Inl cl' -> ror_clause unsat deduce cl cl' - | Inr l -> Inr l) - -(** val xror_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, - 'a2) clause list -> ('a1, 'a2) clause list * 'a2 trace **) - -let xror_clause_cnf unsat deduce t0 f = - fold_left (fun pat e -> - let acc,tg = pat in - (match ror_clause unsat deduce t0 e with - | Inl cl -> (cl::acc),tg - | Inr l -> acc,(Merge (tg, l)))) - f ([],Null) - -(** val ror_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, - 'a2) clause list -> ('a1, 'a2) clause list * 'a2 trace **) - -let ror_clause_cnf unsat deduce t0 f = - match t0 with - | [] -> f,Null - | _::_ -> xror_clause_cnf unsat deduce t0 f - -(** val ror_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> - ('a1, 'a2) clause list -> ('a1, 'a2) cnf * 'a2 trace **) - -let rec ror_cnf unsat deduce f f' = - match f with - | [] -> cnf_tt,Null - | e::rst -> - let rst_f',t0 = ror_cnf unsat deduce rst f' in - let e_f',t' = ror_clause_cnf unsat deduce e f' in - (rev_append rst_f' e_f'),(Merge (t0, t')) - -(** val ror_cnf_opt : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf * 'a2 trace **) - -let ror_cnf_opt unsat deduce f1 f2 = - if is_cnf_tt f1 - then cnf_tt,Null - else if is_cnf_tt f2 - then cnf_tt,Null - else if is_cnf_ff f2 then f1,Null else ror_cnf unsat deduce f1 f2 - -(** val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 trace **) - -let ratom c a = - if if is_cnf_ff c then true else is_cnf_tt c - then c,(Push (a, Null)) - else c,Null - -(** val rxcnf_and : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> - ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf * 'a3 trace **) - -let rxcnf_and unsat deduce rXCNF polarity k e1 e2 = - let e3,t1 = rXCNF polarity k e1 in - let e4,t2 = rXCNF polarity k e2 in - if polarity - then (and_cnf_opt e3 e4),(Merge (t1, t2)) - else let f',t' = ror_cnf_opt unsat deduce e3 e4 in - f',(Merge (t1, (Merge (t2, t')))) - -(** val rxcnf_or : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> - ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf * 'a3 trace **) - -let rxcnf_or unsat deduce rXCNF polarity k e1 e2 = - let e3,t1 = rXCNF polarity k e1 in - let e4,t2 = rXCNF polarity k e2 in - if polarity - then let f',t' = ror_cnf_opt unsat deduce e3 e4 in - f',(Merge (t1, (Merge (t2, t')))) - else (and_cnf_opt e3 e4),(Merge (t1, t2)) - -(** val rxcnf_impl : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> - ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf * 'a3 trace **) - -let rxcnf_impl unsat deduce rXCNF polarity k e1 e2 = - let e3,t1 = rXCNF (negb polarity) k e1 in - if polarity - then if is_cnf_tt e3 - then e3,t1 - else if is_cnf_ff e3 - then rXCNF polarity k e2 - else let e4,t2 = rXCNF polarity k e2 in - let f',t' = ror_cnf_opt unsat deduce e3 e4 in - f',(Merge (t1, (Merge (t2, t')))) - else let e4,t2 = rXCNF polarity k e2 in (and_cnf_opt e3 e4),(Merge (t1, t2)) - -(** val rxcnf_iff : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, - 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> - ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf * 'a3 trace **) - -let rxcnf_iff unsat deduce rXCNF polarity k e1 e2 = - let c1,t1 = rXCNF (negb polarity) k e1 in - let c2,t2 = rXCNF false k e2 in - let c3,t3 = rXCNF polarity k e1 in - let c4,t4 = rXCNF true k e2 in - let f',t' = ror_cnf_opt unsat deduce (and_cnf_opt c1 c2) (and_cnf_opt c3 c4) - in - f',(Merge (t1, (Merge (t2, (Merge (t3, (Merge (t4, t')))))))) - -(** val rxcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) - cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> kind -> ('a1, 'a3, 'a4, - 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 trace **) - -let rec rxcnf unsat deduce normalise1 negate0 polarity _ = function -| TT _ -> if polarity then cnf_tt,Null else cnf_ff,Null -| FF _ -> if polarity then cnf_ff,Null else cnf_tt,Null -| X (_, _) -> cnf_ff,Null -| A (_, x, t0) -> - ratom (if polarity then normalise1 x t0 else negate0 x t0) t0 -| AND (k0, e1, e2) -> - rxcnf_and unsat deduce (fun x x0 x1 -> - rxcnf unsat deduce normalise1 negate0 x x0 x1) polarity k0 e1 e2 -| OR (k0, e1, e2) -> - rxcnf_or unsat deduce (fun x x0 x1 -> - rxcnf unsat deduce normalise1 negate0 x x0 x1) polarity k0 e1 e2 -| NOT (k0, e) -> rxcnf unsat deduce normalise1 negate0 (negb polarity) k0 e -| IMPL (k0, e1, _, e2) -> - rxcnf_impl unsat deduce (fun x x0 x1 -> - rxcnf unsat deduce normalise1 negate0 x x0 x1) polarity k0 e1 e2 -| IFF (k0, e1, e2) -> - rxcnf_iff unsat deduce (fun x x0 x1 -> - rxcnf unsat deduce normalise1 negate0 x x0 x1) polarity k0 e1 e2 -| EQ (e1, e2) -> - rxcnf_iff unsat deduce (fun x x0 x1 -> - rxcnf unsat deduce normalise1 negate0 x x0 x1) polarity IsBool e1 e2 - -type ('term, 'annot, 'tX) to_constrT = { mkTT : (kind -> 'tX); - mkFF : (kind -> 'tX); - mkA : (kind -> 'term -> 'annot -> - 'tX); - mkAND : (kind -> 'tX -> 'tX -> 'tX); - mkOR : (kind -> 'tX -> 'tX -> 'tX); - mkIMPL : (kind -> 'tX -> 'tX -> 'tX); - mkIFF : (kind -> 'tX -> 'tX -> 'tX); - mkNOT : (kind -> 'tX -> 'tX); - mkEQ : ('tX -> 'tX -> 'tX) } - -(** val aformula : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 **) - -let rec aformula to_constr _ = function -| TT b -> to_constr.mkTT b -| FF b -> to_constr.mkFF b -| X (_, p) -> p -| A (b, x, t0) -> to_constr.mkA b x t0 -| AND (k0, f1, f2) -> - to_constr.mkAND k0 (aformula to_constr k0 f1) (aformula to_constr k0 f2) -| OR (k0, f1, f2) -> - to_constr.mkOR k0 (aformula to_constr k0 f1) (aformula to_constr k0 f2) -| NOT (k0, f0) -> to_constr.mkNOT k0 (aformula to_constr k0 f0) -| IMPL (k0, f1, _, f2) -> - to_constr.mkIMPL k0 (aformula to_constr k0 f1) (aformula to_constr k0 f2) -| IFF (k0, f1, f2) -> - to_constr.mkIFF k0 (aformula to_constr k0 f1) (aformula to_constr k0 f2) -| EQ (f1, f2) -> - to_constr.mkEQ (aformula to_constr IsBool f1) (aformula to_constr IsBool f2) - -(** val is_X : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option **) - -let is_X _ = function -| X (_, p) -> Some p -| _ -> None - -(** val abs_and : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> - ('a1, 'a2, 'a3, 'a4) tFormula -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> - ('a1, 'a3, 'a2, 'a4) gFormula **) - -let abs_and to_constr k f1 f2 c = - match is_X k f1 with - | Some _ -> X (k, (aformula to_constr k (c k f1 f2))) - | None -> - (match is_X k f2 with - | Some _ -> X (k, (aformula to_constr k (c k f1 f2))) - | None -> c k f1 f2) - -(** val abs_or : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> - ('a1, 'a2, 'a3, 'a4) tFormula -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> - ('a1, 'a3, 'a2, 'a4) gFormula **) - -let abs_or to_constr k f1 f2 c = - match is_X k f1 with - | Some _ -> - (match is_X k f2 with - | Some _ -> X (k, (aformula to_constr k (c k f1 f2))) - | None -> c k f1 f2) - | None -> c k f1 f2 - -(** val abs_not : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> - (kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> ('a1, 'a3, 'a2, 'a4) gFormula **) - -let abs_not to_constr k f1 c = - match is_X k f1 with - | Some _ -> X (k, (aformula to_constr k (c k f1))) - | None -> c k f1 - -(** val mk_arrow : - 'a4 option -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, - 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula **) - -let mk_arrow o k f1 f2 = - match o with - | Some _ -> - (match is_X k f1 with - | Some _ -> f2 - | None -> IMPL (k, f1, o, f2)) - | None -> IMPL (k, f1, None, f2) - -(** val abst_simpl : - ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> kind -> ('a1, 'a2, 'a3, - 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula **) - -let rec abst_simpl to_constr needA _ = function -| A (k, x, t0) -> - if needA t0 then A (k, x, t0) else X (k, (to_constr.mkA k x t0)) -| AND (k0, f1, f2) -> - AND (k0, (abst_simpl to_constr needA k0 f1), - (abst_simpl to_constr needA k0 f2)) -| OR (k0, f1, f2) -> - OR (k0, (abst_simpl to_constr needA k0 f1), - (abst_simpl to_constr needA k0 f2)) -| NOT (k0, f0) -> NOT (k0, (abst_simpl to_constr needA k0 f0)) -| IMPL (k0, f1, o, f2) -> - IMPL (k0, (abst_simpl to_constr needA k0 f1), o, - (abst_simpl to_constr needA k0 f2)) -| IFF (k0, f1, f2) -> - IFF (k0, (abst_simpl to_constr needA k0 f1), - (abst_simpl to_constr needA k0 f2)) -| EQ (f1, f2) -> - EQ ((abst_simpl to_constr needA IsBool f1), - (abst_simpl to_constr needA IsBool f2)) -| x -> x - -(** val abst_and : - ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) - tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, - 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, - 'a4) tFormula **) - -let abst_and to_constr rEC pol0 k f1 f2 = - if pol0 - then abs_and to_constr k (rEC pol0 k f1) (rEC pol0 k f2) (fun x x0 x1 -> - AND (x, x0, x1)) - else abs_or to_constr k (rEC pol0 k f1) (rEC pol0 k f2) (fun x x0 x1 -> AND - (x, x0, x1)) - -(** val abst_or : - ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) - tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, - 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, - 'a4) tFormula **) - -let abst_or to_constr rEC pol0 k f1 f2 = - if pol0 - then abs_or to_constr k (rEC pol0 k f1) (rEC pol0 k f2) (fun x x0 x1 -> OR - (x, x0, x1)) - else abs_and to_constr k (rEC pol0 k f1) (rEC pol0 k f2) (fun x x0 x1 -> OR - (x, x0, x1)) - -(** val abst_impl : - ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) - tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> 'a4 option -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> - ('a1, 'a2, 'a3, 'a4) tFormula **) - -let abst_impl to_constr rEC pol0 o k f1 f2 = - if pol0 - then abs_or to_constr k (rEC (negb pol0) k f1) (rEC pol0 k f2) (mk_arrow o) - else abs_and to_constr k (rEC (negb pol0) k f1) (rEC pol0 k f2) (mk_arrow o) - -(** val or_is_X : - kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> - bool **) - -let or_is_X k f1 f2 = - match is_X k f1 with - | Some _ -> true - | None -> (match is_X k f2 with - | Some _ -> true - | None -> false) - -(** val abs_iff : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> - ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, - 'a2, 'a3, 'a4) tFormula -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, - 'a2, 'a3, 'a4) tFormula **) - -let abs_iff to_constr k nf1 ff2 f1 tf2 r def = - if (&&) (or_is_X k nf1 ff2) (or_is_X k f1 tf2) - then X (r, (aformula to_constr r def)) - else def - -(** val abst_iff : - ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, - 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> - ('a1, 'a2, 'a3, 'a4) tFormula **) - -let abst_iff to_constr needA rEC pol0 k f1 f2 = - abs_iff to_constr k (rEC (negb pol0) k f1) (rEC false k f2) (rEC pol0 k f1) - (rEC true k f2) k (IFF (k, (abst_simpl to_constr needA k f1), - (abst_simpl to_constr needA k f2))) - -(** val abst_eq : - ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, - 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> - ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, - 'a2, 'a3, 'a4) tFormula **) - -let abst_eq to_constr needA rEC pol0 f1 f2 = - abs_iff to_constr IsBool (rEC (negb pol0) IsBool f1) (rEC false IsBool f2) - (rEC pol0 IsBool f1) (rEC true IsBool f2) IsProp (EQ - ((abst_simpl to_constr needA IsBool f1), - (abst_simpl to_constr needA IsBool f2))) - -(** val abst_form : - ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> kind -> ('a1, 'a2, - 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula **) - -let rec abst_form to_constr needA pol0 _ = function -| TT k -> if pol0 then TT k else X (k, (to_constr.mkTT k)) -| FF k -> if pol0 then X (k, (to_constr.mkFF k)) else FF k -| X (k, p) -> X (k, p) -| A (k, x, t0) -> - if needA t0 then A (k, x, t0) else X (k, (to_constr.mkA k x t0)) -| AND (k0, f1, f2) -> - abst_and to_constr (abst_form to_constr needA) pol0 k0 f1 f2 -| OR (k0, f1, f2) -> - abst_or to_constr (abst_form to_constr needA) pol0 k0 f1 f2 -| NOT (k0, f0) -> - abs_not to_constr k0 (abst_form to_constr needA (negb pol0) k0 f0) - (fun x x0 -> NOT (x, x0)) -| IMPL (k0, f1, o, f2) -> - abst_impl to_constr (abst_form to_constr needA) pol0 o k0 f1 f2 -| IFF (k0, f1, f2) -> - abst_iff to_constr needA (abst_form to_constr needA) pol0 k0 f1 f2 -| EQ (f1, f2) -> - abst_eq to_constr needA (abst_form to_constr needA) pol0 f1 f2 - -(** val cnf_checker : - (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool **) - -let rec cnf_checker checker f l = - match f with - | [] -> true - | e::f0 -> - (match l with - | [] -> false - | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false) - -(** val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) - cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> - bool) -> ('a1, rtyp, 'a3, unit0) gFormula -> 'a4 list -> bool **) - -let tauto_checker unsat deduce normalise1 negate0 checker f w = - cnf_checker checker (xcnf unsat deduce normalise1 negate0 true IsProp f) w - -type 'c pExpr = -| PEc of 'c -| PEX of positive -| PEadd of 'c pExpr * 'c pExpr -| PEsub of 'c pExpr * 'c pExpr -| PEmul of 'c pExpr * 'c pExpr -| PEopp of 'c pExpr -| PEpow of 'c pExpr * n - -type 'c pol = -| Pc of 'c -| Pinj of positive * 'c pol -| PX of 'c pol * positive * 'c pol - -(** val p0 : 'a1 -> 'a1 pol **) - -let p0 cO = - Pc cO - -(** val p1 : 'a1 -> 'a1 pol **) - -let p1 cI = - Pc cI - -(** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **) - -let rec peq ceqb p p' = - match p with - | Pc c -> (match p' with - | Pc c' -> ceqb c c' - | _ -> false) - | Pinj (j, q0) -> - (match p' with - | Pinj (j', q') -> - (match Coq_Pos.compare j j' with - | Eq -> peq ceqb q0 q' - | _ -> false) - | _ -> false) - | PX (p2, i, q0) -> - (match p' with - | PX (p'0, i', q') -> - (match Coq_Pos.compare i i' with - | Eq -> if peq ceqb p2 p'0 then peq ceqb q0 q' else false - | _ -> false) - | _ -> false) - -(** val mkPinj : positive -> 'a1 pol -> 'a1 pol **) - -let mkPinj j p = match p with -| Pc _ -> p -| Pinj (j', q0) -> Pinj ((Coq_Pos.add j j'), q0) -| PX (_, _, _) -> Pinj (j, p) - -(** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) - -let mkPinj_pred j p = - match j with - | XI j0 -> Pinj ((XO j0), p) - | XO j0 -> Pinj ((Coq_Pos.pred_double j0), p) - | XH -> p - -(** val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let mkPX cO ceqb p i q0 = - match p with - | Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0) - | Pinj (_, _) -> PX (p, i, q0) - | PX (p', i', q') -> - if peq ceqb q' (p0 cO) - then PX (p', (Coq_Pos.add i' i), q0) - else PX (p, i, q0) - -(** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **) - -let mkXi cO cI i = - PX ((p1 cI), i, (p0 cO)) - -(** val mkX : 'a1 -> 'a1 -> 'a1 pol **) - -let mkX cO cI = - mkXi cO cI XH - -(** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) - -let rec popp copp = function -| Pc c -> Pc (copp c) -| Pinj (j, q0) -> Pinj (j, (popp copp q0)) -| PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0)) - -(** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) - -let rec paddC cadd p c = - match p with - | Pc c1 -> Pc (cadd c1 c) - | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c)) - | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c)) - -(** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) - -let rec psubC csub p c = - match p with - | Pc c1 -> Pc (csub c1 c) - | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c)) - | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c)) - -(** val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol **) - -let rec paddI cadd pop q0 j = function -| Pc c -> mkPinj j (paddC cadd q0 c) -| Pinj (j', q') -> - (match Z.pos_sub j' j with - | Z0 -> mkPinj j (pop q' q0) - | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) - | Zneg k -> mkPinj j' (paddI cadd pop q0 k q')) -| PX (p2, i, q') -> - (match j with - | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q')) - | XO j0 -> PX (p2, i, (paddI cadd pop q0 (Coq_Pos.pred_double j0) q')) - | XH -> PX (p2, i, (pop q' q0))) - -(** val psubI : - ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> - 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec psubI cadd copp pop q0 j = function -| Pc c -> mkPinj j (paddC cadd (popp copp q0) c) -| Pinj (j', q') -> - (match Z.pos_sub j' j with - | Z0 -> mkPinj j (pop q' q0) - | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) - | Zneg k -> mkPinj j' (psubI cadd copp pop q0 k q')) -| PX (p2, i, q') -> - (match j with - | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q')) - | XO j0 -> PX (p2, i, (psubI cadd copp pop q0 (Coq_Pos.pred_double j0) q')) - | XH -> PX (p2, i, (pop q' q0))) - -(** val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol - -> positive -> 'a1 pol -> 'a1 pol **) - -let rec paddX cO ceqb pop p' i' p = match p with -| Pc _ -> PX (p', i', p) -| Pinj (j, q') -> - (match j with - | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) - | XO j0 -> PX (p', i', (Pinj ((Coq_Pos.pred_double j0), q'))) - | XH -> PX (p', i', q')) -| PX (p2, i, q') -> - (match Z.pos_sub i i' with - | Z0 -> mkPX cO ceqb (pop p2 p') i q' - | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' - | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') - -(** val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 - pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec psubX cO copp ceqb pop p' i' p = match p with -| Pc _ -> PX ((popp copp p'), i', p) -| Pinj (j, q') -> - (match j with - | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) - | XO j0 -> PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q'))) - | XH -> PX ((popp copp p'), i', q')) -| PX (p2, i, q') -> - (match Z.pos_sub i i' with - | Z0 -> mkPX cO ceqb (pop p2 p') i q' - | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' - | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') - -(** val padd : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol - -> 'a1 pol **) - -let rec padd cO cadd ceqb p = function -| Pc c' -> paddC cadd p c' -| Pinj (j', q') -> paddI cadd (padd cO cadd ceqb) q' j' p -| PX (p'0, i', q') -> - (match p with - | Pc c -> PX (p'0, i', (paddC cadd q' c)) - | Pinj (j, q0) -> - (match j with - | XI j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((XO j0), q0)) q')) - | XO j0 -> - PX (p'0, i', - (padd cO cadd ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q')) - | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q'))) - | PX (p2, i, q0) -> - (match Z.pos_sub i i' with - | Z0 -> - mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q0 q') - | Zpos k -> - mkPX cO ceqb (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' - (padd cO cadd ceqb q0 q') - | Zneg k -> - mkPX cO ceqb (paddX cO ceqb (padd cO cadd ceqb) p'0 k p2) i - (padd cO cadd ceqb q0 q'))) - -(** val psub : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 - -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) - -let rec psub cO cadd csub copp ceqb p = function -| Pc c' -> psubC csub p c' -| Pinj (j', q') -> psubI cadd copp (psub cO cadd csub copp ceqb) q' j' p -| PX (p'0, i', q') -> - (match p with - | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c)) - | Pinj (j, q0) -> - (match j with - | XI j0 -> - PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) - | XO j0 -> - PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) - q')) - | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q'))) - | PX (p2, i, q0) -> - (match Z.pos_sub i i' with - | Z0 -> - mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i - (psub cO cadd csub copp ceqb q0 q') - | Zpos k -> - mkPX cO ceqb (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) - i' (psub cO cadd csub copp ceqb q0 q') - | Zneg k -> - mkPX cO ceqb - (psubX cO copp ceqb (psub cO cadd csub copp ceqb) p'0 k p2) i - (psub cO cadd csub copp ceqb q0 q'))) - -(** val pmulC_aux : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> - 'a1 pol **) - -let rec pmulC_aux cO cmul ceqb p c = - match p with - | Pc c' -> Pc (cmul c' c) - | Pinj (j, q0) -> mkPinj j (pmulC_aux cO cmul ceqb q0 c) - | PX (p2, i, q0) -> - mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i (pmulC_aux cO cmul ceqb q0 c) - -(** val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> - 'a1 -> 'a1 pol **) - -let pmulC cO cI cmul ceqb p c = - if ceqb c cO - then p0 cO - else if ceqb c cI then p else pmulC_aux cO cmul ceqb p c - -(** val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> - 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec pmulI cO cI cmul ceqb pmul0 q0 j = function -| Pc c -> mkPinj j (pmulC cO cI cmul ceqb q0 c) -| Pinj (j', q') -> - (match Z.pos_sub j' j with - | Z0 -> mkPinj j (pmul0 q' q0) - | Zpos k -> mkPinj j (pmul0 (Pinj (k, q')) q0) - | Zneg k -> mkPinj j' (pmulI cO cI cmul ceqb pmul0 q0 k q')) -| PX (p', i', q') -> - (match j with - | XI j' -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' - (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q') - | XO j' -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' - (pmulI cO cI cmul ceqb pmul0 q0 (Coq_Pos.pred_double j') q') - | XH -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' (pmul0 q' q0)) - -(** val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) - -let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with -| Pc c -> pmulC cO cI cmul ceqb p c -| Pinj (j', q') -> pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p -| PX (p', i', q') -> - (match p with - | Pc c -> pmulC cO cI cmul ceqb p'' c - | Pinj (j, q0) -> - let qQ' = - match j with - | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' - | XO j0 -> - pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q' - | XH -> pmul cO cI cadd cmul ceqb q0 q' - in - mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ' - | PX (p2, i, q0) -> - let qQ' = pmul cO cI cadd cmul ceqb q0 q' in - let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 in - let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q0) p' in - let pP' = pmul cO cI cadd cmul ceqb p2 p' in - padd cO cadd ceqb - (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') i' - (p0 cO)) - (mkPX cO ceqb pQ' i qQ')) - -(** val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 pol -> 'a1 pol **) - -let rec psquare cO cI cadd cmul ceqb = function -| Pc c -> Pc (cmul c c) -| Pinj (j, q0) -> Pinj (j, (psquare cO cI cadd cmul ceqb q0)) -| PX (p2, i, q0) -> - let twoPQ = - pmul cO cI cadd cmul ceqb p2 - (mkPinj XH (pmulC cO cI cmul ceqb q0 (cadd cI cI))) - in - let q2 = psquare cO cI cadd cmul ceqb q0 in - let p3 = psquare cO cI cadd cmul ceqb p2 in - mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb p3 i (p0 cO)) twoPQ) i q2 - -(** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) - -let mk_X cO cI j = - mkPinj_pred j (mkX cO cI) - -(** val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 - pol **) - -let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function -| XI p3 -> - subst_l - (pmul cO cI cadd cmul ceqb - (ppow_pos cO cI cadd cmul ceqb subst_l - (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) - p) -| XO p3 -> - ppow_pos cO cI cadd cmul ceqb subst_l - (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3 -| XH -> subst_l (pmul cO cI cadd cmul ceqb res p) - -(** val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **) - -let ppow_N cO cI cadd cmul ceqb subst_l p = function -| N0 -> p1 cI -| Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 - -(** val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) - -let rec norm_aux cO cI cadd cmul csub copp ceqb = function -| PEc c -> Pc c -| PEX j -> mk_X cO cI j -| PEadd (pe1, pe2) -> - (match pe1 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe2) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - (match pe2 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - padd cO cadd ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2))) -| PEsub (pe1, pe2) -> - psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) -| PEmul (pe1, pe2) -> - pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) -| PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) -| PEpow (pe1, n0) -> - ppow_N cO cI cadd cmul ceqb (fun p -> p) - (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 - -(** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) - -let cneqb ceqb x y = - negb (ceqb x y) - -(** val cltb : - ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) - -let cltb ceqb cleb x y = - (&&) (cleb x y) (cneqb ceqb x y) - -type 'c polC = 'c pol - -type op1 = -| Equal -| NonEqual -| Strict -| NonStrict - -type 'c nFormula = 'c polC * op1 - -(** val opMult : op1 -> op1 -> op1 option **) - -let opMult o o' = - match o with - | Equal -> Some Equal - | NonEqual -> - (match o' with - | Equal -> Some Equal - | NonEqual -> Some NonEqual - | _ -> None) - | Strict -> (match o' with - | NonEqual -> None - | _ -> Some o') - | NonStrict -> - (match o' with - | Equal -> Some Equal - | NonEqual -> None - | _ -> Some NonStrict) - -(** val opAdd : op1 -> op1 -> op1 option **) - -let opAdd o o' = - match o with - | Equal -> Some o' - | NonEqual -> (match o' with - | Equal -> Some NonEqual - | _ -> None) - | Strict -> (match o' with - | NonEqual -> None - | _ -> Some Strict) - | NonStrict -> - (match o' with - | Equal -> Some NonStrict - | NonEqual -> None - | x -> Some x) - -type 'c psatz = -| PsatzLet of 'c psatz * 'c psatz -| PsatzIn of nat -| PsatzSquare of 'c polC -| PsatzMulC of 'c polC * 'c psatz -| PsatzMulE of 'c psatz * 'c psatz -| PsatzAdd of 'c psatz * 'c psatz -| PsatzC of 'c -| PsatzZ - -(** val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **) - -let map_option f = function -| Some x -> f x -| None -> None - -(** val map_option2 : - ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **) - -let map_option2 f o o' = - match o with - | Some x -> (match o' with - | Some x' -> f x x' - | None -> None) - | None -> None - -(** val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **) - -let pexpr_times_nformula cO cI cplus ctimes ceqb e = function -| ef,o -> - (match o with - | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef),Equal) - | _ -> None) - -(** val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) - -let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = - 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) - -(** val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 - nFormula -> 'a1 nFormula option **) - -let nformula_plus_nformula cO cplus ceqb f1 f2 = - 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) - -(** val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 - nFormula option **) - -let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function -| PsatzLet (p2, p3) -> - (match eval_Psatz cO cI cplus ctimes ceqb cleb l p2 with - | Some f -> eval_Psatz cO cI cplus ctimes ceqb cleb (f::l) p3 - | None -> None) -| PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal)) -| PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0),NonStrict) -| PsatzMulC (re, e0) -> - map_option (pexpr_times_nformula cO cI cplus ctimes ceqb re) - (eval_Psatz cO cI cplus ctimes ceqb cleb l e0) -| PsatzMulE (f1, f2) -> - map_option2 (nformula_times_nformula cO cI cplus ctimes ceqb) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) -| PsatzAdd (f1, f2) -> - map_option2 (nformula_plus_nformula cO cplus ceqb) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) - (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) -| PsatzC c -> if cltb ceqb cleb cO c then Some ((Pc c),Strict) else None -| PsatzZ -> Some ((Pc cO),Equal) - -(** val check_inconsistent : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> - bool **) - -let check_inconsistent cO ceqb cleb = function -| e,op -> - (match e with - | Pc c -> - (match op with - | Equal -> cneqb ceqb c cO - | NonEqual -> ceqb c cO - | Strict -> cleb c cO - | NonStrict -> cltb ceqb cleb c cO) - | _ -> false) - -(** val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool **) - -let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm = - match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with - | Some f -> check_inconsistent cO ceqb cleb f - | None -> false - -type op2 = -| OpEq -| OpNEq -| OpLe -| OpGe -| OpLt -| OpGt - -type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } - -(** val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) - -let norm = - norm_aux - -(** val psub0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 - -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) - -let psub0 = - psub - -(** val padd0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol - -> 'a1 pol **) - -let padd0 = - padd - -(** val popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) - -let popp0 = - popp - -(** val normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula **) - -let normalise cO cI cplus ctimes cminus copp ceqb f = - let { flhs = lhs; fop = op; frhs = rhs } = f in - let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in - let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in - (match op with - | OpEq -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal - | OpNEq -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonEqual - | OpLe -> (psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict - | OpGe -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict - | OpLt -> (psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict - | OpGt -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict) - -(** val xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) - -let xnormalise copp = function -| e,o -> - (match o with - | Equal -> (e,Strict)::(((popp0 copp e),Strict)::[]) - | NonEqual -> (e,Equal)::[] - | Strict -> ((popp0 copp e),NonStrict)::[] - | NonStrict -> ((popp0 copp e),Strict)::[]) - -(** val xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) - -let xnegate copp = function -| e,o -> - (match o with - | NonEqual -> (e,Strict)::(((popp0 copp e),Strict)::[]) - | x -> (e,x)::[]) - -(** val cnf_of_list : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list - -> 'a2 -> ('a1 nFormula, 'a2) cnf **) - -let cnf_of_list cO ceqb cleb l tg = - fold_right (fun x acc -> - if check_inconsistent cO ceqb cleb x then acc else ((x,tg)::[])::acc) - cnf_tt l - -(** val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) - -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf **) - -let cnf_normalise cO cI cplus ctimes cminus copp ceqb cleb t0 tg = - let f = normalise cO cI cplus ctimes cminus copp ceqb t0 in - if check_inconsistent cO ceqb cleb f - then cnf_ff - else cnf_of_list cO ceqb cleb (xnormalise copp f) tg - -(** val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) - -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf **) - -let cnf_negate cO cI cplus ctimes cminus copp ceqb cleb t0 tg = - let f = normalise cO cI cplus ctimes cminus copp ceqb t0 in - if check_inconsistent cO ceqb cleb f - then cnf_tt - else cnf_of_list cO ceqb cleb (xnegate copp f) tg - -(** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) - -let rec xdenorm jmp = function -| Pc c -> PEc c -| Pinj (j, p2) -> xdenorm (Coq_Pos.add j jmp) p2 -| PX (p2, j, q0) -> - PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp), (Npos j))))), - (xdenorm (Coq_Pos.succ jmp) q0)) - -(** val denorm : 'a1 pol -> 'a1 pExpr **) - -let denorm p = - xdenorm XH p - -(** val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr **) - -let rec map_PExpr c_of_S = function -| PEc c -> PEc (c_of_S c) -| PEX p -> PEX p -| PEadd (e1, e2) -> PEadd ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) -| PEsub (e1, e2) -> PEsub ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) -| PEmul (e1, e2) -> PEmul ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) -| PEopp e0 -> PEopp (map_PExpr c_of_S e0) -| PEpow (e0, n0) -> PEpow ((map_PExpr c_of_S e0), n0) - -(** val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula **) - -let map_Formula c_of_S f = - let { flhs = l; fop = o; frhs = r } = f in - { flhs = (map_PExpr c_of_S l); fop = o; frhs = (map_PExpr c_of_S r) } - -(** val simpl_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> - 'a1 psatz **) - -let simpl_cone cO cI ctimes ceqb e = match e with -| PsatzSquare t0 -> - (match t0 with - | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c) - | _ -> PsatzSquare t0) -| PsatzMulE (t1, t2) -> - (match t1 with - | PsatzMulE (x, x0) -> - (match x with - | PsatzC p2 -> - (match t2 with - | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0) - | PsatzZ -> PsatzZ - | _ -> e) - | _ -> - (match x0 with - | PsatzC p2 -> - (match t2 with - | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x) - | PsatzZ -> PsatzZ - | _ -> e) - | _ -> - (match t2 with - | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) - | PsatzZ -> PsatzZ - | _ -> e))) - | PsatzC c -> - (match t2 with - | PsatzMulE (x, x0) -> - (match x with - | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0) - | _ -> - (match x0 with - | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x) - | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))) - | PsatzAdd (y, z0) -> - PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), z0))) - | PsatzC c0 -> PsatzC (ctimes c c0) - | PsatzZ -> PsatzZ - | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)) - | PsatzZ -> PsatzZ - | _ -> - (match t2 with - | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) - | PsatzZ -> PsatzZ - | _ -> e)) -| PsatzAdd (t1, t2) -> - (match t1 with - | PsatzZ -> t2 - | _ -> (match t2 with - | PsatzZ -> t1 - | _ -> PsatzAdd (t1, t2))) -| _ -> e - -type 'a t = -| Empty -| Elt of 'a -| Branch of 'a t * 'a * 'a t - -(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) - -let rec find default vm p = - match vm with - | Empty -> default - | Elt i -> i - | Branch (l, e, r) -> - (match p with - | XI p2 -> find default r p2 - | XO p2 -> find default l p2 - | XH -> e) - -(** val singleton : 'a1 -> positive -> 'a1 -> 'a1 t **) - -let rec singleton default x v = - match x with - | XI p -> Branch (Empty, default, (singleton default p v)) - | XO p -> Branch ((singleton default p v), default, Empty) - | XH -> Elt v - -(** val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t **) - -let rec vm_add default x v = function -| Empty -> singleton default x v -| Elt vl -> - (match x with - | XI p -> Branch (Empty, vl, (singleton default p v)) - | XO p -> Branch ((singleton default p v), vl, Empty) - | XH -> Elt v) -| Branch (l, o, r) -> - (match x with - | XI p -> Branch (l, o, (vm_add default p v r)) - | XO p -> Branch ((vm_add default p v l), o, r) - | XH -> Branch (l, v, r)) - -(** val zeval_const : z pExpr -> z option **) - -let rec zeval_const = function -| PEc c -> Some c -| PEX _ -> None -| PEadd (e1, e2) -> - map_option2 (fun x y -> Some (Z.add x y)) (zeval_const e1) (zeval_const e2) -| PEsub (e1, e2) -> - map_option2 (fun x y -> Some (Z.sub x y)) (zeval_const e1) (zeval_const e2) -| PEmul (e1, e2) -> - map_option2 (fun x y -> Some (Z.mul x y)) (zeval_const e1) (zeval_const e2) -| PEopp e0 -> map_option (fun x -> Some (Z.opp x)) (zeval_const e0) -| PEpow (e1, n0) -> - map_option (fun x -> Some (Z.pow x (Z.of_N n0))) (zeval_const e1) - -type zWitness = z psatz - -(** val zWeakChecker : z nFormula list -> z psatz -> bool **) - -let zWeakChecker = - check_normalised_formulas Z0 (Zpos XH) Z.add Z.mul Z.eqb Z.leb - -(** val psub1 : z pol -> z pol -> z pol **) - -let psub1 = - psub0 Z0 Z.add Z.sub Z.opp Z.eqb - -(** val popp1 : z pol -> z pol **) - -let popp1 = - popp0 Z.opp - -(** val padd1 : z pol -> z pol -> z pol **) - -let padd1 = - padd0 Z0 Z.add Z.eqb - -(** val normZ : z pExpr -> z pol **) - -let normZ = - norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp Z.eqb - -(** val zunsat : z nFormula -> bool **) - -let zunsat = - check_inconsistent Z0 Z.eqb Z.leb - -(** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) - -let zdeduce = - nformula_plus_nformula Z0 Z.add Z.eqb - -(** val xnnormalise : z formula -> z nFormula **) - -let xnnormalise t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = normZ lhs in - let rhs0 = normZ rhs in - (match o with - | OpEq -> (psub1 rhs0 lhs0),Equal - | OpNEq -> (psub1 rhs0 lhs0),NonEqual - | OpLe -> (psub1 rhs0 lhs0),NonStrict - | OpGe -> (psub1 lhs0 rhs0),NonStrict - | OpLt -> (psub1 rhs0 lhs0),Strict - | OpGt -> (psub1 lhs0 rhs0),Strict) - -(** val xnormalise0 : z nFormula -> z nFormula list **) - -let xnormalise0 = function -| e,o -> - (match o with - | Equal -> - ((psub1 e (Pc (Zpos XH))),NonStrict)::(((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) - | NonEqual -> (e,Equal)::[] - | Strict -> ((psub1 (Pc Z0) e),NonStrict)::[] - | NonStrict -> ((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) - -(** val cnf_of_list0 : - 'a1 -> z nFormula list -> (z nFormula * 'a1) list list **) - -let cnf_of_list0 tg l = - fold_right (fun x acc -> if zunsat x then acc else ((x,tg)::[])::acc) - cnf_tt l - -(** val normalise0 : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) - -let normalise0 t0 tg = - let f = xnnormalise t0 in - if zunsat f then cnf_ff else cnf_of_list0 tg (xnormalise0 f) - -(** val xnegate0 : z nFormula -> z nFormula list **) - -let xnegate0 = function -| e,o -> - (match o with - | NonEqual -> - ((psub1 e (Pc (Zpos XH))),NonStrict)::(((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) - | Strict -> ((psub1 e (Pc (Zpos XH))),NonStrict)::[] - | x -> (e,x)::[]) - -(** val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) - -let negate t0 tg = - let f = xnnormalise t0 in - if zunsat f then cnf_tt else cnf_of_list0 tg (xnegate0 f) - -(** val cnfZ : - kind -> (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) - cnf * 'a1 trace **) - -let cnfZ k f = - rxcnf zunsat zdeduce normalise0 negate true k f - -(** val ceiling : z -> z -> z **) - -let ceiling a b = - let q0,r = Z.div_eucl a b in - (match r with - | Z0 -> q0 - | _ -> Z.add q0 (Zpos XH)) - -type zArithProof = -| DoneProof -| RatProof of zWitness * zArithProof -| CutProof of zWitness * zArithProof -| SplitProof of z polC * zArithProof * zArithProof -| Deprecated_EnumProof of zWitness * zWitness * zArithProof list -| ExProof of positive * zArithProof - -(** val zgcdM : z -> z -> z **) - -let zgcdM x y = - Z.max (Z.gcd x y) (Zpos XH) - -(** val zgcd_pol : z polC -> z * z **) - -let rec zgcd_pol = function -| Pc c -> Z0,c -| Pinj (_, p2) -> zgcd_pol p2 -| PX (p2, _, q0) -> - let g1,c1 = zgcd_pol p2 in - let g2,c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2),c2 - -(** val zdiv_pol : z polC -> z -> z polC **) - -let rec zdiv_pol p x = - match p with - | Pc c -> Pc (Z.div c x) - | Pinj (j, p2) -> Pinj (j, (zdiv_pol p2 x)) - | PX (p2, j, q0) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q0 x)) - -(** val makeCuttingPlane : z polC -> z polC * z **) - -let makeCuttingPlane p = - 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 - -(** val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option **) - -let genCuttingPlane = function -| e,op -> - (match op with - | Equal -> - let g,c = zgcd_pol e in - if (&&) (Z.gtb g Z0) - ((&&) (negb (Z.eqb c Z0)) (negb (Z.eqb (Z.gcd g c) g))) - then None - else Some ((makeCuttingPlane e),Equal) - | NonEqual -> Some ((e,Z0),op) - | Strict -> Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict) - | NonStrict -> Some ((makeCuttingPlane e),NonStrict)) - -(** val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula **) - -let nformula_of_cutting_plane = function -| e_z,o -> let e,z0 = e_z in (padd1 e (Pc z0)),o - -(** val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option **) - -let eval_Psatz0 = - eval_Psatz Z0 (Zpos XH) Z.add Z.mul Z.eqb Z.leb - -(** val bound_var : positive -> z formula **) - -let bound_var v = - { flhs = (PEX v); fop = OpGe; frhs = (PEc Z0) } - -(** val mk_eq_pos : positive -> positive -> positive -> z formula **) - -let mk_eq_pos x y t0 = - { flhs = (PEX x); fop = OpEq; frhs = (PEsub ((PEX y), (PEX t0))) } - -(** val max_var : positive -> z pol -> positive **) - -let rec max_var jmp = function -| Pc _ -> jmp -| Pinj (j, p2) -> max_var (Coq_Pos.add j jmp) p2 -| PX (p2, _, q0) -> - Coq_Pos.max (max_var jmp p2) (max_var (Coq_Pos.succ jmp) q0) - -(** val max_var_nformulae : z nFormula list -> positive **) - -let max_var_nformulae l = - fold_left (fun acc f -> Coq_Pos.max acc (max_var XH (fst f))) l XH - -(** val zChecker : z nFormula list -> zArithProof -> bool **) - -let rec zChecker l = function -| RatProof (w, pf0) -> - (match eval_Psatz0 l w with - | Some f -> if zunsat f then true else zChecker (f::l) pf0 - | None -> false) -| CutProof (w, pf0) -> - (match eval_Psatz0 l w with - | Some f -> - (match genCuttingPlane f with - | Some cp -> zChecker ((nformula_of_cutting_plane cp)::l) pf0 - | None -> true) - | None -> false) -| SplitProof (p, pf1, pf2) -> - (match genCuttingPlane (p,NonStrict) with - | Some cp1 -> - (match genCuttingPlane ((popp1 p),NonStrict) with - | Some cp2 -> - (&&) (zChecker ((nformula_of_cutting_plane cp1)::l) pf1) - (zChecker ((nformula_of_cutting_plane cp2)::l) pf2) - | None -> false) - | None -> false) -| ExProof (x, prf) -> - let fr = max_var_nformulae l in - if Coq_Pos.leb x fr - then let z0 = Coq_Pos.succ fr in - let t0 = Coq_Pos.succ z0 in - let nfx = xnnormalise (mk_eq_pos x z0 t0) in - let posz = xnnormalise (bound_var z0) in - let post = xnnormalise (bound_var t0) in - zChecker (nfx::(posz::(post::l))) prf - else false -| _ -> false - -(** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) - -let zTautoChecker f w = - tauto_checker zunsat zdeduce normalise0 negate (fun cl -> - zChecker (map fst cl)) f w - -type q = { qnum : z; qden : positive } - -(** val qeq_bool : q -> q -> bool **) - -let qeq_bool x y = - Z.eqb (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) - -(** val qle_bool : q -> q -> bool **) - -let qle_bool x y = - Z.leb (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) - -(** val qplus : q -> q -> q **) - -let qplus x y = - { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))); - qden = (Coq_Pos.mul x.qden y.qden) } - -(** val qmult : q -> q -> q **) - -let qmult x y = - { qnum = (Z.mul x.qnum y.qnum); qden = (Coq_Pos.mul x.qden y.qden) } - -(** val qopp : q -> q **) - -let qopp x = - { qnum = (Z.opp x.qnum); qden = x.qden } - -(** val qminus : q -> q -> q **) - -let qminus x y = - qplus x (qopp y) - -(** val qinv : q -> q **) - -let qinv x = - match x.qnum with - | Z0 -> { qnum = Z0; qden = XH } - | Zpos p -> { qnum = (Zpos x.qden); qden = p } - | Zneg p -> { qnum = (Zneg x.qden); qden = p } - -(** val qpower_positive : q -> positive -> q **) - -let qpower_positive = - pow_pos0 qmult - -(** val qpower : q -> z -> q **) - -let qpower q0 = function -| Z0 -> { qnum = (Zpos XH); qden = XH } -| Zpos p -> qpower_positive q0 p -| Zneg p -> qinv (qpower_positive q0 p) - -type qWitness = q psatz - -(** val qWeakChecker : q nFormula list -> q psatz -> bool **) - -let qWeakChecker = - check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); - qden = XH } qplus qmult qeq_bool qle_bool - -(** val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) - -let qnormalise t0 tg = - cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool qle_bool t0 tg - -(** val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) - -let qnegate t0 tg = - cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool qle_bool t0 tg - -(** val qunsat : q nFormula -> bool **) - -let qunsat = - check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool - -(** val qdeduce : q nFormula -> q nFormula -> q nFormula option **) - -let qdeduce = - nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool - -(** val normQ : q pExpr -> q pol **) - -let normQ = - norm { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult - qminus qopp qeq_bool - -(** val cnfQ : - kind -> (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) - cnf * 'a1 trace **) - -let cnfQ k f = - rxcnf qunsat qdeduce qnormalise qnegate true k f - -(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) - -let qTautoChecker f w = - tauto_checker qunsat qdeduce qnormalise qnegate (fun cl -> - qWeakChecker (map fst cl)) f w - -type rcst = -| C0 -| C1 -| CQ of q -| CZ of z -| CPlus of rcst * rcst -| CMinus of rcst * rcst -| CMult of rcst * rcst -| CPow of rcst * (z, nat) sum -| CInv of rcst -| COpp of rcst - -(** val z_of_exp : (z, nat) sum -> z **) - -let z_of_exp = function -| Inl z1 -> z1 -| Inr n0 -> Z.of_nat n0 - -(** val q_of_Rcst : rcst -> q **) - -let rec q_of_Rcst = function -| C0 -> { qnum = Z0; qden = XH } -| C1 -> { qnum = (Zpos XH); qden = XH } -| CQ q0 -> q0 -| CZ z0 -> { qnum = z0; qden = XH } -| 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, z0) -> qpower (q_of_Rcst r1) (z_of_exp z0) -| CInv r0 -> qinv (q_of_Rcst r0) -| COpp r0 -> qopp (q_of_Rcst r0) - -type rWitness = q psatz - -(** val rWeakChecker : q nFormula list -> q psatz -> bool **) - -let rWeakChecker = - check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); - qden = XH } qplus qmult qeq_bool qle_bool - -(** val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) - -let rnormalise t0 tg = - cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool qle_bool t0 tg - -(** val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) - -let rnegate t0 tg = - cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool qle_bool t0 tg - -(** val runsat : q nFormula -> bool **) - -let runsat = - check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool - -(** val rdeduce : q nFormula -> q nFormula -> q nFormula option **) - -let rdeduce = - nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool - -(** val rTautoChecker : rcst formula bFormula -> rWitness list -> bool **) - -let rTautoChecker f w = - tauto_checker runsat rdeduce rnormalise rnegate (fun cl -> - rWeakChecker (map fst cl)) - (map_bformula IsProp (map_Formula q_of_Rcst) f) w - diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v deleted file mode 100644 index a31c993666..0000000000 --- a/test-suite/output/MExtraction.v +++ /dev/null @@ -1,68 +0,0 @@ -(************************************************************************) -(* * The Rocq Prover / The Rocq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* "( * )" [ "(,)" ]. -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. *) -Recursive Extraction - 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 QArith_base.Qpower vm_add - normZ normQ normQ Z.to_N N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/theories/micromega/EnvRing.v b/theories/micromega/EnvRing.v index fb9f1ea13b..62750e61b4 100644 --- a/theories/micromega/EnvRing.v +++ b/theories/micromega/EnvRing.v @@ -11,67 +11,15 @@ For big polynomials, this is inefficient -- linear access. I have modified the code to use binary trees -- logarithmic access. *) - -Set Implicit Arguments. +From micromega_plugin Require Export formula witness eval checker. From Stdlib Require Import Setoid Morphisms Env BinPos BinNat BinInt. From Stdlib Require Export Ring_theory. +Set Implicit Arguments. + #[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. - -Register PEc as micromega.PExpr.PEc. -Register PEX as micromega.PExpr.PEX. -Register PEadd as micromega.PExpr.PEadd. -Register PEsub as micromega.PExpr.PEsub. -Register PEmul as micromega.PExpr.PEmul. -Register PEopp as micromega.PExpr.PEopp. -Register PEpow as micromega.PExpr.PEpow. - - (* 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. - -Register Pc as micromega.Pol.Pc. -Register Pinj as micromega.Pol.Pinj. -Register PX as micromega.Pol.PX. - Section MakeRingPol. (* Ring elements *) @@ -155,275 +103,34 @@ Section MakeRingPol. 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. + #[local] Notation P0 := (P0 cO). + #[local] Notation P1 := (P1 cI). + #[local] Notation Peq := (Peq ceqb). + #[local] Notation mkPX := (mkPX cO ceqb). + #[local] Notation mk_X := (mkX cO cI). + #[local] Notation Popp := (Popp copp). + #[local] Notation PaddC := (PaddC cadd). + #[local] Notation PsubC := (PsubC csub). + #[local] Notation PaddI := (PaddI cadd). + #[local] Notation PaddX := (PaddX cO ceqb). + #[local] Notation Padd := (Padd cO cadd ceqb). + #[local] Notation PsubI := (PsubI cadd copp). + #[local] Notation PsubX := (PsubX cO copp ceqb). + #[local] Notation Psub := (Psub cO cadd csub copp ceqb). + #[local] Notation PmulC_aux := (PmulC_aux cO cmul ceqb). + #[local] Notation PmulC := (PmulC cO cI cmul ceqb). + #[local] Notation PmulI := (PmulI cO cI cmul ceqb). + #[local] Notation Pmul := (Pmul cO cI cadd cmul ceqb). + #[local] Notation Psquare := (Psquare cO cI cadd cmul ceqb). + #[local] Notation Ppow_pos := (Ppow_pos cO cI cadd cmul ceqb). + #[local] Notation norm_aux := (Pol_of_PExpr cO cI cadd cmul csub copp ceqb). 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 @@ -971,21 +678,10 @@ Qed. 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. + #[local] Notation PEeval := (PEeval + rO rI radd rmul rsub ropp Cp_phi rpow phi (@nth R)). (** Correctness proofs *) @@ -1001,18 +697,6 @@ Qed. 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) -> @@ -1023,6 +707,8 @@ Section POWER. mul_permut. Qed. + #[local] Notation Ppow_N := (Ppow_N cO cI cadd cmul ceqb). + 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. @@ -1043,20 +729,6 @@ Section POWER. 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. @@ -1077,7 +749,7 @@ Section POWER. end. Proof. simpl (norm_aux (PEadd _ _)). - destruct pe1; [ | | | | | reflexivity | ]; + destruct pe1; [ | | | | | | | reflexivity | ]; destruct pe2; simpl get_PEopp; reflexivity. Qed. @@ -1094,7 +766,9 @@ Section POWER. PEeval l pe == (norm_aux pe)@l. Proof. intros. - induction pe as [| |pe1 IHpe1 pe2 IHpe2|? IHpe1 ? IHpe2|? IHpe1 ? IHpe2|? IHpe|? IHpe n0]. + induction pe as [| | | |pe1 IHpe1 pe2 IHpe2|? IHpe1 ? IHpe2|? IHpe1 ? IHpe2|? IHpe|? IHpe n0]. + - now rewrite (morph0 CRmorph). + - now rewrite (morph1 CRmorph). - reflexivity. - apply mkX_ok. - simpl PEeval. rewrite IHpe1, IHpe2. @@ -1105,7 +779,7 @@ Section POWER. - simpl. rewrite IHpe1, IHpe2. Esimpl. - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - simpl. rewrite IHpe. Esimpl. - - simpl. rewrite Ppow_N_ok by reflexivity. + - simpl. rewrite (Ppow_N_ok id) by reflexivity. rewrite (rpow_pow_N pow_th). destruct n0 as [|p]; simpl; Esimpl. induction p as [p IHp|p IHp|];simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. @@ -1113,3 +787,6 @@ Section POWER. End NORM_SUBST_REC. End MakeRingPol. + +Notation PEeval := (fun rO rI add mul sub opp phi pow_phi pow => PEeval + rO rI add mul sub opp pow_phi pow phi (@Env.nth _)). diff --git a/theories/micromega/Lia.v b/theories/micromega/Lia.v index 7ea3ecac5b..5888141482 100644 --- a/theories/micromega/Lia.v +++ b/theories/micromega/Lia.v @@ -16,8 +16,7 @@ From Stdlib Require Import BinInt. From Stdlib.micromega Require Import Tauto VarMap ZMicromega Zify. -Declare ML Module "rocq-runtime.plugins.micromega_core". -Declare ML Module "rocq-runtime.plugins.micromega". +From micromega_plugin Require Export tactics. Ltac zchecker := let __wit := fresh "__wit" in diff --git a/theories/micromega/Lqa.v b/theories/micromega/Lqa.v index f2a71f288d..2d1d7f3384 100644 --- a/theories/micromega/Lqa.v +++ b/theories/micromega/Lqa.v @@ -20,8 +20,7 @@ From Stdlib Require Import RingMicromega. From Stdlib Require Import VarMap. From Stdlib Require Import DeclConstant. From Stdlib.micromega Require Tauto. -Declare ML Module "rocq-runtime.plugins.micromega_core". -Declare ML Module "rocq-runtime.plugins.micromega". +From micromega_plugin Require Export tactics. Ltac rchange := let __wit := fresh "__wit" in diff --git a/theories/micromega/Lra.v b/theories/micromega/Lra.v index 46f80c5d5a..5941cb262c 100644 --- a/theories/micromega/Lra.v +++ b/theories/micromega/Lra.v @@ -21,8 +21,7 @@ From Stdlib Require Import RingMicromega. From Stdlib Require Import VarMap. From Stdlib.micromega Require Tauto. From Stdlib Require Import Rregisternames. - -Declare ML Module "rocq-runtime.plugins.micromega". +From micromega_plugin Require Export tactics. Ltac rchange := let __wit := fresh "__wit" in diff --git a/theories/micromega/Psatz.v b/theories/micromega/Psatz.v index 48d7d444fd..e65b1c8e40 100644 --- a/theories/micromega/Psatz.v +++ b/theories/micromega/Psatz.v @@ -26,8 +26,7 @@ From Stdlib.micromega Require Tauto. From Stdlib Require Lia. From Stdlib Require Lra. From Stdlib Require Lqa. - -Declare ML Module "rocq-runtime.plugins.micromega". +From micromega_plugin Require Export tactics. Ltac lia := Lia.lia. diff --git a/theories/micromega/QMicromega.v b/theories/micromega/QMicromega.v index 0cca873d1b..a82d4873c4 100644 --- a/theories/micromega/QMicromega.v +++ b/theories/micromega/QMicromega.v @@ -14,7 +14,6 @@ (* *) (************************************************************************) -From Stdlib Require Import micromega.Tauto. From Stdlib Require Import OrderedRing. From Stdlib Require Import RingMicromega. From Stdlib Require Import Refl. @@ -65,33 +64,10 @@ 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).*) From Stdlib 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. +#[local] Notation Qeval_expr := (PEeval + Q0 Q1 Qplus Qmult Qminus Qopp id Z.of_N Qpower). -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). +Definition Qeval_expr' := eval_pexpr Q0 Q1 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. @@ -101,10 +77,9 @@ 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. + induction e ; simpl ; subst ; try congruence; try reflexivity. + rewrite IHe. + apply QNpower. Qed. Definition Qeval_pop2 (o : Op2) : Q -> Q -> Prop := @@ -167,11 +142,11 @@ Proof. - simpl. apply pop2_bop2. Qed. -Definition Qeval_formula (e:PolEnv Q) (k: Tauto.kind) (ff : Formula Q) := +Definition Qeval_formula (e:PolEnv Q) (k: kind) (ff : Formula Q) := let (lhs,o,rhs) := ff in Qeval_op2 k 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). + eval_formula Q0 Q1 Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult). Lemma Qeval_formula_compat : forall env b f, Tauto.hold b (Qeval_formula env b f) <-> Qeval_formula' env f. Proof. @@ -204,12 +179,8 @@ Proof. exact (fun env d =>eval_nformula_dec Qsor (fun x => x) env d). Qed. -Definition QWitness := Psatz Q. - -Register QWitness as micromega.QWitness.type. - - -Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qeq_bool Qle_bool. +#[local] Notation QWeakChecker := (CWeakChecker + Q0 Q1 Qplus Qmult Qeq_bool Qle_bool). From Stdlib Require Import List. @@ -227,27 +198,18 @@ Qed. From Stdlib.micromega Require Import 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. +#[local] Notation Qnormalise := (Cnormalise + Q0 Q1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool). +#[local] Notation Qnegate := (Cnegate + Q0 Q1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool). +#[local] Notation qunsat := (check_inconsistent Q0 Qeq_bool Qle_bool). +#[local] Notation qdeduce := (nformula_plus_nformula Q0 Qplus Qeq_bool). Definition normQ := norm 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Declare Equivalent Keys normQ RingMicromega.norm. -Definition cnfQ (Annot:Type) (TX: Tauto.kind -> Type) (AF: Type) (k: Tauto.kind) (f: TFormula (Formula Q) Annot TX AF k) := - rxcnf qunsat qdeduce (Qnormalise Annot) (Qnegate Annot) true f. - -Definition QTautoChecker (f : BFormula (Formula Q) Tauto.isProp) (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. - - +Definition cnfQ (Annot:Type) (TX: kind -> Type) (AF: Type) (k: kind) (f: @GFormula (Formula Q) TX Annot AF k) := + rxcnf qunsat qdeduce (@Qnormalise Annot) (@Qnegate Annot) true f. Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_bf (Qeval_formula env) f. Proof. diff --git a/theories/micromega/RMicromega.v b/theories/micromega/RMicromega.v index cdd0af4e8b..65ca8b01d1 100644 --- a/theories/micromega/RMicromega.v +++ b/theories/micromega/RMicromega.v @@ -14,7 +14,6 @@ (* *) (************************************************************************) -From Stdlib Require Import micromega.Tauto. From Stdlib Require Import OrderedRing. From Stdlib Require Import QMicromega RingMicromega. From Stdlib Require Import Refl. @@ -379,7 +378,7 @@ Definition INZ (n:N) : R := | Npos p => IZR (Zpos p) end. -Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp R_of_Rcst N.to_nat pow. +Definition Reval_expr := eval_pexpr R0 R1 Rplus Rmult Rminus Ropp R_of_Rcst N.to_nat pow. Definition Reval_pop2 (o:Op2) : R -> R -> Prop := @@ -432,16 +431,16 @@ Proof. - simpl. apply pop2_bop2. Qed. -Definition Reval_formula (e: PolEnv R) (k: Tauto.kind) (ff : Formula Rcst) := +Definition Reval_formula (e: PolEnv R) (k: kind) (ff : Formula Rcst) := let (lhs,o,rhs) := ff in Reval_op2 k 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. + eval_sformula R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt N.to_nat pow R_of_Rcst. Lemma Reval_pop2_eval_op2 : forall o e1 e2, Reval_pop2 o e1 e2 <-> - eval_op2 eq Rle Rlt o e1 e2. + eval_op2 isProp eq (fun x y => x <> y) Rle Rlt o e1 e2. Proof. destruct o ; simpl ; try tauto. split. @@ -460,14 +459,14 @@ Proof. apply Reval_pop2_eval_op2. Qed. -Definition QReval_expr := eval_pexpr Rplus Rmult Rminus Ropp Q2R N.to_nat pow. +Definition QReval_expr := eval_pexpr R0 R1 Rplus Rmult Rminus Ropp Q2R N.to_nat pow. -Definition QReval_formula (e: PolEnv R) (k: Tauto.kind) (ff : Formula Q) := +Definition QReval_formula (e: PolEnv R) (k: kind) (ff : Formula Q) := let (lhs,o,rhs) := ff in Reval_op2 k o (QReval_expr e lhs) (QReval_expr e rhs). Definition QReval_formula' := - eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt Q2R N.to_nat pow. + eval_formula R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt Q2R N.to_nat pow. Lemma QReval_formula_compat : forall env b f, Tauto.hold b (QReval_formula env b f) <-> QReval_formula' env f. Proof. @@ -490,7 +489,8 @@ Qed. Definition RWitness := Psatz Q. -Definition RWeakChecker := check_normalised_formulas 0%Q 1%Q Qplus Qmult Qeq_bool Qle_bool. +#[local] Notation RWeakChecker := (CWeakChecker + Q0 Q1 Qplus Qmult Qeq_bool Qle_bool). From Stdlib Require Import List. @@ -508,18 +508,11 @@ Qed. From Stdlib.micromega Require Import 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. +#[local] Notation Qcnf_of_GFormula := (Ccnf_of_GFormula + Q0 Q1 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) Tauto.isProp) (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. +Definition RTautoChecker (f : BFormula (Formula Rcst) isProp) (w: list RWitness) : bool := + checker.tauto_checker (fun cl => RWeakChecker (List.map fst cl)) (Qcnf_of_GFormula (GFmap (Fmap Q_of_Rcst) f)) w. Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_bf (Reval_formula env) f. Proof. @@ -527,7 +520,7 @@ Proof. unfold RTautoChecker. intros TC env. apply tauto_checker_sound with (eval:=QReval_formula) (eval':= Qeval_nformula) (env := env) in TC. - - change (eval_f e_eKind (QReval_formula env)) + - change (GFeval eqb e_eKind (QReval_formula env)) with (eval_bf (QReval_formula env)) in TC. rewrite eval_bf_map in TC. @@ -545,8 +538,7 @@ Proof. - apply Reval_nformula_dec. - destruct t. apply (check_inconsistent_sound Rsor QSORaddon) ; auto. - - unfold rdeduce. - intros. revert H. + - intros. revert H. eapply (nformula_plus_nformula_correct Rsor QSORaddon); eauto. - intros. diff --git a/theories/micromega/RingMicromega.v b/theories/micromega/RingMicromega.v index a0d043ebc4..21bdbf773a 100644 --- a/theories/micromega/RingMicromega.v +++ b/theories/micromega/RingMicromega.v @@ -23,7 +23,7 @@ From Stdlib Require Import List. From Stdlib Require Import Bool. From Stdlib Require Import OrderedRing. From Stdlib Require Import Refl. -From Stdlib.micromega Require Tauto. +From Stdlib.micromega Require Import Tauto. Set Implicit Arguments. @@ -114,8 +114,8 @@ 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). +#[local] Notation cneqb := (cneqb ceqb). +#[local] Notation cltb := (cltb ceqb cleb). Notation "x [~=] y" := (cneqb x y). Notation "x [<] y" := (cltb x y). @@ -149,13 +149,7 @@ 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 *) +#[local] Notation NFormula := (NFormula C). Definition eval_op1 (o : Op1) : R -> Prop := match o with @@ -172,47 +166,6 @@ 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). @@ -224,8 +177,6 @@ unfold eval_op1; intros o; destruct o; simpl; intros o' om x y H1 H2 H3. 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 *) @@ -291,25 +242,7 @@ unfold eval_op1; intros o; destruct o; simpl; intros o' oa e e' H1 H2 Hoa. now apply (Rplus_nonneg_nonneg sor). Qed. -Inductive Psatz : Type := -| PsatzLet: Psatz -> Psatz -> Psatz -| PsatzIn : nat -> Psatz -| PsatzSquare : PolC -> Psatz -| PsatzMulC : PolC -> Psatz -> Psatz -| PsatzMulE : Psatz -> Psatz -> Psatz -| PsatzAdd : Psatz -> Psatz -> Psatz -| PsatzC : C -> Psatz -| PsatzZ : Psatz. - -Register PsatzLet as micromega.Psatz.PsatzLet. -Register PsatzIn as micromega.Psatz.PsatzIn. -Register PsatzSquare as micromega.Psatz.PsatzSquare. -Register PsatzMulC as micromega.Psatz.PsatzMulC. -Register PsatzMulE as micromega.Psatz.PsatzMulE. -Register PsatzAdd as micromega.Psatz.PsatzAdd. -Register PsatzC as micromega.Psatz.PsatzC. -Register PsatzZ as micromega.Psatz.PsatzZ. - +#[local] Notation Psatz := (Psatz C). (** Given a list [l] of NFormula and an extended polynomial expression [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a @@ -317,64 +250,15 @@ Register PsatzZ as micromega.Psatz.PsatzZ. 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 - | PsatzLet p1 p2 => match eval_Psatz l p1 with - | None => None - | Some f => eval_Psatz (f::l) p2 - end - | 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. - +#[local] Notation pexpr_times_nformula := (pexpr_times_nformula cO cI cplus ctimes ceqb). +#[local] Notation nformula_times_nformula := (nformula_times_nformula cO cI cplus ctimes ceqb). +#[local] Notation nformula_plus_nformula := (nformula_plus_nformula cO cplus ceqb). +#[local] Notation eval_Psatz := (eval_Psatz cO cI cplus ctimes ceqb cleb). Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula), eval_nformula env f -> pexpr_times_nformula e f = Some f' -> @@ -508,19 +392,19 @@ Qed. Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat := match prf with - | PsatzC _ | PsatzZ | PsatzSquare _ => acc + | 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 + | PsatzIn _ n => if ge_bool n base then (n::acc) else acc | PsatzLet e1 e2 => xhyps_of_psatz base (xhyps_of_psatz (S base) acc e2) e1 end. Fixpoint nhyps_of_psatz (base:nat) (prf : Psatz) : list nat := match prf with - | PsatzC _ | PsatzZ | PsatzSquare _ => nil + | PsatzC _ | PsatzZ _ | PsatzSquare _ => nil | PsatzMulC _ prf => nhyps_of_psatz base prf | PsatzAdd e1 e2 | PsatzMulE e1 e2 => nhyps_of_psatz base e1 ++ nhyps_of_psatz base e2 - | PsatzIn n => if ge_bool n base then (n::nil) else nil + | PsatzIn _ n => if ge_bool n base then (n::nil) else nil | PsatzLet e1 e2 => nhyps_of_psatz base e1 ++ nhyps_of_psatz (S base) e2 end. @@ -568,22 +452,7 @@ Definition PaddC_ok : forall c P env, eval_pol env (paddC P c) == eval_pol env 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. +#[local] Notation check_inconsistent := (check_inconsistent cO ceqb cleb). Lemma check_inconsistent_sound : forall (p : PolC) (op : Op1), @@ -600,13 +469,7 @@ try rewrite <- (morph0 (SORrm addon)); trivial. - 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. +#[local] Notation check_normalised_formulas := (check_normalised_formulas cO cI cplus ctimes ceqb cleb). Lemma checker_nf_sound : forall (l : list NFormula) (cm : Psatz), @@ -627,73 +490,23 @@ Qed. (** Normalisation of formulae **) -Inductive Op2 : Set := (* binary relations *) -| OpEq -| OpNEq -| OpLe -| OpGe -| OpLt -| OpGt. - -Register OpEq as micromega.Op2.OpEq. -Register OpNEq as micromega.Op2.OpNEq. -Register OpLe as micromega.Op2.OpLe. -Register OpGe as micromega.Op2.OpGe. -Register OpLt as micromega.Op2.OpLt. -Register OpGt as micromega.Op2.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. +#[local] Notation eval_op2 := (eval_op2 + isProp req (fun x y => ~ req x y) rle rlt). Definition eval_pexpr : PolEnv -> PExpr C -> R := - PEeval rplus rtimes rminus ropp phi pow_phi rpow. - -#[universes(template)] -Record Formula (T:Type) : Type := Build_Formula{ - Flhs : PExpr T; - Fop : Op2; - Frhs : PExpr T -}. - -Register Formula as micromega.Formula.type. -Register Build_Formula as micromega.Formula.Build_Formula. - -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). + PEeval rO rI rplus rtimes rminus ropp pow_phi rpow phi (@Env.nth R). +#[local] Notation eval_formula := (Feval rO rI rplus rtimes rminus ropp + pow_phi rpow isProp req (fun x y => ~ req x y) rle rlt phi (@Env.nth R)). (* 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. +#[local] Notation norm := (Pol_of_PExpr cO cI cplus ctimes cminus copp ceqb). +#[local] Notation psub := (Psub cO cplus cminus copp ceqb). +#[local] Notation padd := (Padd cO cplus ceqb). +#[local] Notation pmul := (Pmul cO cI cplus ctimes ceqb). +#[local] Notation popp := (Popp copp). +#[local] Notation normalise := (normalise cO cI cplus ctimes cminus copp ceqb). Definition negate (f : Formula C) : NFormula := let (lhs, op, rhs) := f in @@ -777,31 +590,9 @@ 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 Stdlib.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. +#[local] Notation xnormalise := (normalise_aux copp). +#[local] Notation xnegate := (negate_aux copp). +#[local] Notation cnf_of_list := (cnf_of_list cO ceqb cleb). Add Ring SORRing : (SORrt sor). @@ -837,15 +628,8 @@ Proof. 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. +#[local] Notation cnf_normalise := (cnf_normalise cO cI cplus ctimes cminus copp ceqb cleb). +#[local] Notation cnf_negate := (cnf_negate cO cI cplus ctimes cminus copp ceqb cleb). Lemma eq0_cnf : forall x, (0 < x -> False) /\ (0 < - x -> False) <-> x == 0. @@ -954,7 +738,7 @@ Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C := | 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))) + (PEmul (xdenorm jmp p) (PEpow (PEX _ jmp) (Npos j))) (xdenorm (Pos.succ jmp) q) end. @@ -1020,34 +804,18 @@ 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. + PEeval rO rI rplus rtimes rminus ropp pow_phi rpow phiS (@Env.nth R). 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). +Lemma eval_pexprSC : forall env s, eval_sexpr env s = eval_pexpr env (PEmap C_of_S s). Proof. unfold eval_pexpr, eval_sexpr. intros env s; - induction s as [| |? IHs1 ? IHs2|? IHs1 ? IHs2|? IHs1 ? IHs2|? IHs|? IHs ?]; + induction s as [| | | |? IHs1 ? IHs2|? IHs1 ? IHs2|? IHs1 ? IHs2|? IHs|? IHs ?]; simpl ; try (rewrite IHs1 ; rewrite IHs2) ; try reflexivity. - apply phi_C_of_S. - rewrite IHs. reflexivity. @@ -1055,7 +823,7 @@ Proof. Qed. (** equality might be (too) strong *) -Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (map_Formula f). +Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (Fmap C_of_S f). Proof. intros env f; destruct f. simpl. @@ -1073,13 +841,13 @@ 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) + | Pc c => if ceqb cO c then PsatzZ _ else PsatzC (ctimes c c) | _ => PsatzSquare t end | PsatzMulE t1 t2 => match t1 , t2 with - | PsatzZ , _ => PsatzZ - | _ , PsatzZ => PsatzZ + | PsatzZ _ , _ => PsatzZ C + | _ , PsatzZ _ => PsatzZ C | 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 @@ -1092,8 +860,8 @@ Definition simpl_cone (e:Psatz) : Psatz := end | PsatzAdd t1 t2 => match t1 , t2 with - | PsatzZ , x => x - | x , PsatzZ => x + | PsatzZ _ , x => x + | x , PsatzZ _ => x | x , y => PsatzAdd x y end | _ => e @@ -1103,6 +871,16 @@ Definition simpl_cone (e:Psatz) : Psatz := End Micromega. +Notation norm := Pol_of_PExpr (only parsing). +Notation psub := Psub (only parsing). +Notation padd := Padd (only parsing). +Notation pmul := Pmul (only parsing). +Notation popp := Popp (only parsing). + +Notation eval_formula := + (fun rO rI add mul sub opp eqProp le lt phi pow_phi pow => Feval + rO rI add mul sub opp pow_phi pow + isProp eqProp (fun x y => ~ eqProp x y) le lt phi (@Env.nth _)). (* Local Variables: *) (* coding: utf-8 *) diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index 594bbc5ab7..8b39038b81 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -14,6 +14,7 @@ (* *) (************************************************************************) +From micromega_plugin Require Export formula witness eval checker. From Stdlib Require Import List. From Stdlib Require Import Refl. From Stdlib Require Import Bool. @@ -21,52 +22,22 @@ From Stdlib Require Import Relation_Definitions Setoid. Set Implicit Arguments. -(** Formulae are either interpreted over Prop or bool. *) -Inductive kind : Type := -|isProp -|isBool. - -Register isProp as micromega.kind.isProp. -Register isBool as micromega.kind.isBool. - -Definition eKind (k: kind) := if k then Prop else bool. -Register eKind as micromega.eKind. - Inductive Trace (A : Type) := | null : Trace A | push : A -> Trace A -> Trace A | merge : Trace A -> Trace A -> Trace A . +#[local] Notation eIFF := (eIFF eqb). +Notation eval_f := (GFeval eqb). + Section S. Context {TA : Type}. (* type of interpreted atoms *) Context {TX : kind -> Type}. (* type of uninterpreted terms (Prop) *) Context {AA : Type}. (* type of annotations for atoms *) Context {AF : Type}. (* type of formulae identifiers *) - Inductive GFormula : kind -> Type := - | TT : forall (k: kind), GFormula k - | FF : forall (k: kind), GFormula k - | X : forall (k: kind), TX k -> GFormula k - | A : forall (k: kind), TA -> AA -> GFormula k - | AND : forall (k: kind), GFormula k -> GFormula k -> GFormula k - | OR : forall (k: kind), GFormula k -> GFormula k -> GFormula k - | NOT : forall (k: kind), GFormula k -> GFormula k - | IMPL : forall (k: kind), GFormula k -> option AF -> GFormula k -> GFormula k - | IFF : forall (k: kind), GFormula k -> GFormula k -> GFormula k - | EQ : GFormula isBool -> GFormula isBool -> GFormula isProp. - - Register TT as micromega.GFormula.TT. - Register FF as micromega.GFormula.FF. - Register X as micromega.GFormula.X. - Register A as micromega.GFormula.A. - Register AND as micromega.GFormula.AND. - Register OR as micromega.GFormula.OR. - Register NOT as micromega.GFormula.NOT. - Register IMPL as micromega.GFormula.IMPL. - Register IFF as micromega.GFormula.IFF. - Register EQ as micromega.GFormula.EQ. - + Local Notation GFormula := (@GFormula TA TX AA AF). Section MAPX. Variable F : forall k, TX k -> TX k. @@ -75,7 +46,7 @@ Section S. match f with | TT k => TT k | FF k => FF k - | X x => X (F x) + | X k x => X k (F x) | A k a an => A k a an | AND f1 f2 => AND (mapX f1) (mapX f2) | OR f1 f2 => OR (mapX f1) (mapX f2) @@ -95,7 +66,7 @@ Section S. match f with | TT _ => acc | FF _ => acc - | X x => acc + | X k x => acc | A _ a an => F acc an | AND f1 f2 | OR f1 f2 @@ -121,7 +92,7 @@ Section S. Fixpoint collect_annot (k: kind) (f : GFormula k) : list AA := match f with - | TT _ | FF _ | X _ => nil + | TT _ | FF _ | X _ _ => nil | A _ _ a => a ::nil | AND f1 f2 | OR f1 f2 @@ -136,58 +107,20 @@ Section S. Variable ea : forall (k: kind), TA -> eKind k. - Definition eTT (k: kind) : eKind k := - if k as k' return eKind k' then True else true. - - Definition eFF (k: kind) : eKind k := - if k as k' return eKind k' then False else false. - - Definition eAND (k: kind) : eKind k -> eKind k -> eKind k := - if k as k' return eKind k' -> eKind k' -> eKind k' - then and else andb. - - Definition eOR (k: kind) : eKind k -> eKind k -> eKind k := - if k as k' return eKind k' -> eKind k' -> eKind k' - then or else orb. - - Definition eIMPL (k: kind) : eKind k -> eKind k -> eKind k := - if k as k' return eKind k' -> eKind k' -> eKind k' - then (fun x y => x -> y) else implb. - - Definition eIFF (k: kind) : eKind k -> eKind k -> eKind k := - if k as k' return eKind k' -> eKind k' -> eKind k' - then iff else eqb. - - Definition eNOT (k: kind) : eKind k -> eKind k := - if k as k' return eKind k' -> eKind k' - then not else negb. - - Fixpoint eval_f (k: kind) (f:GFormula k) {struct f}: eKind k := - match f in GFormula k' return eKind k' with - | TT tk => eTT tk - | FF tk => eFF tk - | A k a _ => ea k a - | X p => ex p - | @AND k e1 e2 => eAND k (eval_f e1) (eval_f e2) - | @OR k e1 e2 => eOR k (eval_f e1) (eval_f e2) - | @NOT k e => eNOT k (eval_f e) - | @IMPL k f1 _ f2 => eIMPL k (eval_f f1) (eval_f f2) - | @IFF k f1 f2 => eIFF k (eval_f f1) (eval_f f2) - | EQ f1 f2 => (eval_f f1) = (eval_f f2) - end. + #[local] Notation eval_f := (eval_f ex ea). Lemma eval_f_rew : forall k (f:GFormula k), eval_f f = - match f in GFormula k' return eKind k' with + match f in formula.GFormula k' return eKind k' with | TT tk => eTT tk | FF tk => eFF tk | A k a _ => ea k a - | X p => ex p - | @AND k e1 e2 => eAND k (eval_f e1) (eval_f e2) - | @OR k e1 e2 => eOR k (eval_f e1) (eval_f e2) - | @NOT k e => eNOT k (eval_f e) - | @IMPL k f1 _ f2 => eIMPL k (eval_f f1) (eval_f f2) - | @IFF k f1 f2 => eIFF k (eval_f f1) (eval_f f2) + | X k p => ex p + | @AND _ _ _ _ k e1 e2 => eAND k (eval_f e1) (eval_f e2) + | @OR _ _ _ _ k e1 e2 => eOR k (eval_f e1) (eval_f e2) + | @NOT _ _ _ _ k e => eNOT k (eval_f e) + | @IMPL _ _ _ _ k f1 _ f2 => eIMPL k (eval_f f1) (eval_f f2) + | @IFF _ _ _ _ k f1 f2 => eIFF k (eval_f f1) (eval_f f2) | EQ f1 f2 => (eval_f f1) = (eval_f f2) end. Proof. @@ -195,7 +128,7 @@ Section S. Qed. End EVAL. - + #[local] Notation eval_f := (eval_f ex). Definition hold (k: kind) : eKind k -> Prop := if k as k0 return (eKind k0 -> Prop) then fun x => x else is_true. @@ -293,44 +226,6 @@ End S. #[global] Hint Extern 2 (subrelation (eiff _) _) => progress cbn : typeclass_instances. -(** Typical boolean formulae *) - -Definition BFormula (A : Type) := @GFormula A eKind unit unit. - -Register BFormula as micromega.BFormula.type. - -Section MAPATOMS. - Context {TA TA':Type}. - Context {TX : kind -> Type}. - Context {AA : Type}. - Context {AF : Type}. - - - Fixpoint map_bformula (k: kind)(fct : TA -> TA') (f : @GFormula TA TX AA AF k) : @GFormula TA' TX AA AF k:= - match f with - | TT k => TT k - | FF k => FF k - | X k p => X k p - | A k a t => A k (fct a) t - | AND f1 f2 => AND (map_bformula fct f1) (map_bformula fct f2) - | OR f1 f2 => OR (map_bformula fct f1) (map_bformula fct f2) - | NOT f => NOT (map_bformula fct f) - | IMPL f1 a f2 => IMPL (map_bformula fct f1) a (map_bformula fct f2) - | IFF f1 f2 => IFF (map_bformula fct f1) (map_bformula fct f2) - | EQ f1 f2 => EQ (map_bformula fct f1) (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. - intros A B f l; destruct l ; reflexivity. -Qed. - - Section S. (** A cnf tracking annotations of atoms. *) @@ -349,136 +244,34 @@ Section S. #[local] Notation push := (@push Annot). #[local] Notation merge := (@merge Annot). - Definition clause := list (Term' * Annot). - Definition cnf := list clause. + #[local] Notation clause := (clause Term' Annot). + #[local] Notation cnf := (cnf Term' Annot). 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 is unit in Coq and Names.Id.t in Ocaml - *) - Definition TFormula (TX: kind -> 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 - if is_cnf_tt f2 - then f1 - 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. - - Section REC. - Context {TX : kind -> Type}. - Context {AF : Type}. - - Variable REC : forall (pol : bool) (k: kind) (f : TFormula TX AF k), cnf. - - Definition mk_and (k: kind) (pol:bool) (f1 f2 : TFormula TX AF k):= - (if pol then and_cnf_opt else or_cnf_opt) (REC pol f1) (REC pol f2). - - Definition mk_or (k: kind) (pol:bool) (f1 f2 : TFormula TX AF k):= - (if pol then or_cnf_opt else and_cnf_opt) (REC pol f1) (REC pol f2). - - Definition mk_impl (k: kind) (pol:bool) (f1 f2 : TFormula TX AF k):= - (if pol then or_cnf_opt else and_cnf_opt) (REC (negb pol) f1) (REC pol f2). - - - Definition mk_iff (k: kind) (pol:bool) (f1 f2: TFormula TX AF k):= - or_cnf_opt (and_cnf_opt (REC (negb pol) f1) (REC false f2)) - (and_cnf_opt (REC pol f1) (REC true f2)). - - - End REC. - - Definition is_bool {TX : kind -> Type} {AF: Type} (k: kind) (f : TFormula TX AF k) := - match f with - | TT _ => Some true - | FF _ => Some false - | _ => None - end. + #[local] Notation cnf_tt := (cnf_tt Term' Annot). + #[local] Notation cnf_ff := (cnf_ff Term' Annot). + #[local] Notation is_cnf_tt := (@is_cnf_tt Term' Annot). + #[local] Notation is_cnf_ff := (@is_cnf_ff Term' Annot). + #[local] Notation is_tauto := + (fun x y => match deduce x y with None => false | Some u => unsat u end). + #[local] Notation add_term := (add_term is_tauto). + #[local] Notation or_clause := (or_clause is_tauto). + #[local] Notation or_clause_cnf := (or_clause_cnf is_tauto). + #[local] Notation or_cnf_opt := (@or_cnf Term' Annot is_tauto). + #[local] Notation or_cnf := (@or_cnf_aux Term' Annot is_tauto). + #[local] Notation and_cnf_opt := (@and_cnf Term' Annot). + + #[local] Notation TFormula TX AF := (@GFormula Term TX Annot AF). + + #[local] Notation mk_and := (mk_and or_cnf_opt and_cnf_opt). + #[local] Notation mk_or := (mk_or or_cnf_opt and_cnf_opt). + #[local] Notation mk_impl := (mk_impl or_cnf_opt and_cnf_opt). + #[local] Notation mk_iff := (mk_iff or_cnf_opt and_cnf_opt). + #[local] Notation is_bool := (@is_bool Term Annot). + #[local] Notation xcnf := + (cnf_of_GFormula cnf_tt cnf_ff or_cnf_opt and_cnf_opt normalise negate). Lemma is_bool_inv : forall {TX : kind -> Type} {AF: Type} (k: kind) (f : TFormula TX AF k) res, is_bool f = Some res -> f = if res then TT _ else FF _. @@ -487,28 +280,6 @@ Section S. destruct f ; inversion H; reflexivity. Qed. - - Fixpoint xcnf {TX : kind -> Type} {AF: Type} (pol : bool) (k: kind) (f : TFormula TX AF k) {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 - | NOT e => xcnf (negb pol) e - | AND e1 e2 => mk_and xcnf pol e1 e2 - | OR e1 e2 => mk_or xcnf pol e1 e2 - | IMPL e1 _ e2 => mk_impl xcnf pol e1 e2 - | IFF e1 e2 => match is_bool e2 with - | Some isb => xcnf (if isb then pol else negb pol) e1 - | None => mk_iff xcnf pol e1 e2 - end - | EQ e1 e2 => - match is_bool e2 with - | Some isb => xcnf (if isb then pol else negb pol) e1 - | None => mk_iff xcnf pol e1 e2 - end - end. - Section CNFAnnot. (** Records annotations used to optimise the cnf. @@ -1248,13 +1019,14 @@ Section S. reflexivity. Qed. - Lemma xror_clause_clause : forall a f, - fst (xror_clause_cnf a f) = xor_clause_cnf a f. + Lemma xror_clause_clause : forall a a' f, + fst (xror_clause_cnf (a :: a') f) = or_clause_cnf (a :: a') f. Proof. unfold xror_clause_cnf. - unfold xor_clause_cnf. + unfold or_clause_cnf. assert (ACC: fst (@nil clause, null) = nil) by reflexivity. - intros a f. + intros a' a'' f. + set (a := a' :: a''); clearbody a. set (F1:= (fun '(acc, tg) (e : clause) => match ror_clause a e with | inl cl => (cl :: acc, tg) @@ -1395,6 +1167,7 @@ Section S. rewrite H by auto. unfold or_cnf_opt. simpl. + fold or_cnf_opt. 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. @@ -1491,14 +1264,13 @@ Section S. 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). + Lemma eval_cnf_and_opt : forall env x y, eval_cnf env (and_cnf_opt x y) <-> eval_cnf env (rev_append x y). Proof. unfold and_cnf_opt. intros env x y. 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. @@ -1507,7 +1279,6 @@ Section S. 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. @@ -1516,7 +1287,6 @@ Section S. { apply is_cnf_tt_inv in F3. subst. - unfold and_cnf. rewrite eval_cnf_app. rewrite eval_cnf_tt. tauto. @@ -1638,9 +1408,7 @@ Section S. } destruct t ; auto. - unfold eval_clause ; simpl. tauto. - - unfold xor_clause_cnf. - unfold F in H. - rewrite H. + - rewrite H. unfold make_conj at 2. tauto. Qed. @@ -1818,7 +1586,6 @@ Section S. 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]. @@ -1869,7 +1636,6 @@ Section S. rewrite or_cnf_opt_correct in H; rewrite or_cnf_correct in H; rewrite! eval_cnf_and_opt in H; - unfold and_cnf in H; rewrite! eval_cnf_app in H; generalize (IHf1 false env); generalize (IHf1 true env); @@ -1922,7 +1688,6 @@ Section S. + (* pol = true *) intros. rewrite eval_cnf_and_opt in H. - unfold and_cnf in H. rewrite eval_cnf_app in H. destruct H as [H H0]. apply hold_eAND; split. @@ -1962,7 +1727,6 @@ Section S. + (* pol = true *) intros. unfold mk_or in H. rewrite eval_cnf_and_opt in H. - unfold and_cnf. rewrite eval_cnf_app in H. destruct H as [H0 H1]. simpl. @@ -2018,17 +1782,8 @@ Section S. 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. + #[local] Notation cnf_checker := (cnf_checker checker). + #[local] Notation tauto_checker := (tauto_checker checker). Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf env t. Proof. @@ -2052,10 +1807,7 @@ Section S. tauto. Qed. - Definition tauto_checker (f:@GFormula Term eKind Annot unit isProp) (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 e_eKind (eval env) t. + Lemma tauto_checker_sound : forall t w, tauto_checker (@xcnf true isProp t) w = true -> forall env, @GFeval eqb _ _ _ unit e_eKind (eval env) _ t. Proof. unfold tauto_checker. intros t w H env. @@ -2064,10 +1816,10 @@ Section S. eapply cnf_checker_sound ; eauto. Qed. - Definition eval_bf {A : Type} (ea : forall (k: kind), A -> eKind k) (k: kind) (f: BFormula A k) := eval_f e_eKind ea f. + #[local] Notation eval_bf := (BFeval eqb). Lemma eval_bf_map : forall T U (fct: T-> U) env (k: kind) (f:BFormula T k) , - eval_bf env (map_bformula fct f) = eval_bf (fun b x => env b (fct x)) f. + eval_bf env (GFmap fct f) = eval_bf (fun b x => env b (fct x)) f. Proof. intros T U fct env k f; induction f as [| | | |? ? IHf1 ? IHf2|? ? IHf1 ? IHf2|? ? IHf @@ -2078,7 +1830,16 @@ Section S. End S. - +Notation eval_bf := (BFeval eqb). + +Notation tauto_checker := + (fun term term' annot unsat deduce normalise negate witness check f => + @tauto_checker (clause term' annot) witness check + (@cnf_of_GFormula term annot (cnf term' annot) (cnf_tt _ _) (cnf_ff _ _) + (or_cnf (fun f1 f2 => match deduce f1 f2 : option term' with + | None => false + | Some u => unsat u end)) + (@and_cnf _ _) normalise negate eKind annot true isProp f)). (* Local Variables: *) (* coding: utf-8 *) diff --git a/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v index 102f0d1095..79bb963d3e 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -97,8 +97,10 @@ Qed. Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := match e with + | PEO => Z0 + | PEI => Zpos xH | PEc c => c - | PEX x => env x + | 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) @@ -108,21 +110,19 @@ Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := Strategy expand [ Zeval_expr ]. -Definition eval_expr := eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => x) (pow_N 1 Z.mul). +Definition eval_expr := eval_pexpr Z0 (Zpos xH) 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 + | PEO => Some Z0 + | PEI => Some (Zpos xH) | 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) + | PEX _ x => None + | PEadd e1 e2 => map_option2 Z.add (Zeval_const e1) (Zeval_const e2) + | PEmul e1 e2 => map_option2 Z.mul (Zeval_const e1) (Zeval_const e2) + | PEpow e1 n => map_option (fun x => Z.pow x (Z.of_N n)) (Zeval_const e1) + | PEsub e1 e2 => map_option2 Z.sub (Zeval_const e1) (Zeval_const e2) + | PEopp e => map_option Z.opp (Zeval_const e) end. Lemma ZNpower : forall r n, r ^ Z.of_N n = pow_N 1 Z.mul r n. @@ -194,34 +194,34 @@ Proof. Qed. -Definition Zeval_formula (env : PolEnv Z) (k: Tauto.kind) (f : Formula Z):= +Definition Zeval_formula (env : PolEnv Z) (k: kind) (f : Formula Z):= let (lhs, op, rhs) := f in (Zeval_op2 k 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). + eval_formula Z0 (Zpos xH) 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 k f, Tauto.hold k (Zeval_formula env k f) <-> Zeval_formula env Tauto.isProp f. +Lemma Zeval_formula_compat : forall env k f, Tauto.hold k (Zeval_formula env k f) <-> Zeval_formula env isProp f. Proof. intros env k; destruct k ; simpl. - tauto. - intros f; destruct f ; simpl. - rewrite <- (Zeval_op2_hold Tauto.isBool). + rewrite <- (Zeval_op2_hold isBool). simpl. tauto. Qed. -Lemma Zeval_formula_compat' : forall env f, Zeval_formula env Tauto.isProp f <-> Zeval_formula' env f. +Lemma Zeval_formula_compat' : forall env f, Zeval_formula env isProp f <-> Zeval_formula' env f. Proof. intros env f. unfold Zeval_formula. destruct f as [Flhs Fop Frhs]. 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)). + unfold eval_expr, eval_pexpr. + generalize (ring_eval.PEeval Z0 (Zpos xH) Z.add Z.mul Z.sub Z.opp (fun x => x) + (pow_N 1 Z.mul) (fun x => x) (@Env.nth Z) env Flhs). + generalize (ring_eval.PEeval Z0 (Zpos xH) Z.add Z.mul Z.sub Z.opp (fun x => x) + (pow_N 1 Z.mul) (fun x => x) (@Env.nth Z) env Frhs). destruct Fop ; simpl; intros; intuition auto using Z.le_ge, Z.ge_le, Z.lt_gt, Z.gt_lt. Qed. @@ -245,7 +245,7 @@ Proof. apply (eval_nformula_dec Zsor). Qed. -Definition ZWitness := Psatz Z. +Notation ZWitness := ZWitness. Definition ZWeakChecker := check_normalised_formulas 0 1 Z.add Z.mul Z.eqb Z.leb. @@ -331,7 +331,7 @@ Definition xnnormalise (t : Formula Z) : NFormula Z := Lemma xnnormalise_correct : forall env f, - eval_nformula env (xnnormalise f) <-> Zeval_formula env Tauto.isProp f. + eval_nformula env (xnnormalise f) <-> Zeval_formula env isProp f. Proof. intros env f. rewrite Zeval_formula_compat'. @@ -339,11 +339,11 @@ Proof. 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 z z0. + unfold eval_expr, eval_pexpr; + generalize (ring_eval.PEeval Z0 (Zpos xH) Z.add Z.mul Z.sub Z.opp (fun x => x) + (pow_N 1 Z.mul) (fun x => x) (@Env.nth Z) env lhs); + generalize (ring_eval.PEeval Z0 (Zpos xH) Z.add Z.mul Z.sub Z.opp (fun x => x) + (pow_N 1 Z.mul) (fun x => x) (@Env.nth Z) env rhs); intros z z0. - split ; intros. + assert (z0 + (z - z0) = z0 + 0) as H0 by congruence. rewrite Z.add_0_r in H0. @@ -435,7 +435,7 @@ Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := 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 Tauto.isProp t. +Lemma normalise_correct : forall (T: Type) env t (tg:T), eval_cnf eval_nformula env (normalise t tg) <-> Zeval_formula env isProp t. Proof. intros T env t tg. rewrite <- xnnormalise_correct. @@ -479,7 +479,7 @@ Proof. - tauto. Qed. -Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env Tauto.isProp t. +Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env isProp t. Proof. intros T env t tg. rewrite <- xnnormalise_correct. @@ -493,11 +493,23 @@ Proof. apply xnegate_correct. Qed. -Definition cnfZ (Annot: Type) (TX : Tauto.kind -> Type) (AF : Type) (k: Tauto.kind) (f : TFormula (Formula Z) Annot TX AF k) := +Definition cnfZ (Annot: Type) (TX : kind -> Type) (AF : Type) (k: kind) (f : @GFormula (Formula Z) TX Annot AF k) := rxcnf Zunsat Zdeduce normalise negate true f. -Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z) Tauto.isProp) : bool := - @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZWitness (fun cl => ZWeakChecker (List.map fst cl)) f w. +Definition Zis_tauto x y := + match Zdeduce x y with None => false | Some u => Zunsat u end. + +Definition Zcnf_tt := @cnf_tt (NFormula Z) unit. +Definition Zcnf_ff := @cnf_ff (NFormula Z) unit. +Definition Zor_cnf := @or_cnf (NFormula Z) unit Zis_tauto. +Definition Zand_cnf := @and_cnf (NFormula Z) unit. + +Definition ZGFormula_to_cnf := @cnf_of_GFormula _ _ _ + Zcnf_tt Zcnf_ff Zor_cnf Zand_cnf (@normalise unit) (@negate unit) + eKind unit true isProp. + +Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z) isProp) : bool := + tauto_checker (fun cl => ZWeakChecker (List.map fst cl)) (ZGFormula_to_cnf f) w. (* To get a complete checker, the proof format has to be enriched *) @@ -539,27 +551,7 @@ Qed. (** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *) -Inductive ZArithProof := -| DoneProof -| RatProof : ZWitness -> ZArithProof -> ZArithProof -| CutProof : ZWitness -> ZArithProof -> ZArithProof -| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof -| deprecated_EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof -| ExProof : positive -> ZArithProof -> ZArithProof -(*ExProof x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) -. -#[deprecated(since="Stdlib 9.1")] -Notation EnumProof := deprecated_EnumProof (only parsing). - - -Register ZArithProof as micromega.ZArithProof.type. -Register DoneProof as micromega.ZArithProof.DoneProof. -Register RatProof as micromega.ZArithProof.RatProof. -Register CutProof as micromega.ZArithProof.CutProof. -Register SplitProof as micromega.ZArithProof.SplitProof. -Register ExProof as micromega.ZArithProof.ExProof. - - +Notation ZArithProof := ZArithProof. (* In order to compute the 'cut', we need to express a polynomial P as a * Q + b. - b is the constant @@ -831,10 +823,10 @@ Definition valid_cut_sign (op:Op1) := Definition bound_var (v : positive) : Formula Z := - Build_Formula (PEX v) OpGe (PEc 0). + 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)). + Build_Formula (PEX _ x) OpEq (PEsub (PEX _ y) (PEX _ t)). Fixpoint max_var (jmp : positive) (p : Pol Z) : positive := @@ -1336,8 +1328,8 @@ Proof. apply Z.le_ge, Z.opp_nonneg_nonpos; auto. } } Qed. -Definition ZTautoChecker (f : BFormula (Formula Z) Tauto.isProp) (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. +Definition ZTautoChecker (f : BFormula (Formula Z) isProp) (w: list ZArithProof): bool := + tauto_checker (fun cl => ZChecker (List.map fst cl)) (ZGFormula_to_cnf f) w. Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_bf (Zeval_formula env) f. Proof. @@ -1383,7 +1375,7 @@ Definition leaf := @VarMap.Elt Z. Definition coneMember := ZWitness. -Definition eval := eval_formula. +Definition eval := Feval. #[deprecated(note="Use [prod positive nat]", since="Stdlib 9.0")] Definition prod_pos_nat := prod positive nat. diff --git a/theories/micromega/Zify.v b/theories/micromega/Zify.v index 378122e8a6..be4b795a7e 100644 --- a/theories/micromega/Zify.v +++ b/theories/micromega/Zify.v @@ -9,7 +9,7 @@ (************************************************************************) From Stdlib Require Import ZifyClasses ZifyInst. -Declare ML Module "rocq-runtime.plugins.zify". +From micromega_plugin Require Export Zify. (** [zify_pre_hook] and [zify_post_hook] are there to be redefined. *) Ltac zify_pre_hook := idtac. diff --git a/theories/micromega/ZifyInst.v b/theories/micromega/ZifyInst.v index c90ca3d56a..af523af3ac 100644 --- a/theories/micromega/ZifyInst.v +++ b/theories/micromega/ZifyInst.v @@ -14,7 +14,7 @@ From Stdlib Require Import BinInt BinNat Znat Nnat. From Stdlib Require Import ZifyClasses. -Declare ML Module "rocq-runtime.plugins.zify". +From micromega_plugin Require Zify. #[local] Open Scope Z_scope. Ltac refl := From a65c430e090de7f4f6da4ce6ff28b80a4d26c6ce Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Fri, 3 Apr 2026 13:47:41 +0200 Subject: [PATCH 09/12] Rename micromega plugin tactics to avoid conflicts For instance conflicts between two libraries, one that would still be using the plugin shipped with Rocq and another that uses the new plugin. --- test-suite/micromega/bug_18158.v | 4 ++-- theories/micromega/Lia.v | 4 ++-- theories/micromega/Lqa.v | 6 +++--- theories/micromega/Lra.v | 6 +++--- theories/micromega/Psatz.v | 6 +++--- 5 files changed, 13 insertions(+), 13 deletions(-) diff --git a/test-suite/micromega/bug_18158.v b/test-suite/micromega/bug_18158.v index 002e0f373f..b863204316 100644 --- a/test-suite/micromega/bug_18158.v +++ b/test-suite/micromega/bug_18158.v @@ -86,6 +86,6 @@ Goal forall x y , -> Z.le (Z.shiftr x 24) 255. intros. Zify.zify_saturate. - (* [xlia zchecker] used to raise a [Stack overflow] error. It is supposed to fail normally. *) - assert_fails (xlia zchecker). + (* [mp_lia zchecker] used to raise a [Stack overflow] error. It is supposed to fail normally. *) + assert_fails (mp_lia zchecker). Abort. diff --git a/theories/micromega/Lia.v b/theories/micromega/Lia.v index 5888141482..f17ee3a0fc 100644 --- a/theories/micromega/Lia.v +++ b/theories/micromega/Lia.v @@ -27,6 +27,6 @@ Ltac zchecker := (@eq_refl bool true <: @eq bool (ZTautoChecker __ff __wit) true) (@find Z Z0 __varmap)). -Ltac lia := Zify.zify; xlia zchecker. +Ltac lia := Zify.zify; mp_lia zchecker. -Ltac nia := Zify.zify; xnia zchecker. +Ltac nia := Zify.zify; mp_nia zchecker. diff --git a/theories/micromega/Lqa.v b/theories/micromega/Lqa.v index 2d1d7f3384..dc007660a4 100644 --- a/theories/micromega/Lqa.v +++ b/theories/micromega/Lqa.v @@ -36,15 +36,15 @@ 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 := xlra_Q rchecker. +Ltac lra := mp_lra_Q rchecker. (** Here, nra stands for non-linear rational arithmetic *) -Ltac nra := xnra_Q rchecker. +Ltac nra := mp_nra_Q rchecker. Ltac xpsatz dom d := let tac := lazymatch dom with | Q => - ((xsos_Q rchecker) || (xpsatz_Q d rchecker)) + ((mp_sos_Q rchecker) || (mp_psatz_Q d rchecker)) | _ => fail "Unsupported domain" end in tac. diff --git a/theories/micromega/Lra.v b/theories/micromega/Lra.v index 5941cb262c..610ff65f4e 100644 --- a/theories/micromega/Lra.v +++ b/theories/micromega/Lra.v @@ -37,15 +37,15 @@ 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 * ; xlra_R rchecker. +Ltac lra := unfold Rdiv in * ; mp_lra_R rchecker. (** Here, nra stands for non-linear real arithmetic *) -Ltac nra := unfold Rdiv in * ; xnra_R rchecker. +Ltac nra := unfold Rdiv in * ; mp_nra_R rchecker. Ltac xpsatz dom d := let tac := lazymatch dom with | R => - (xsos_R rchecker) || (xpsatz_R d rchecker) + (mp_sos_R rchecker) || (mp_psatz_R d rchecker) | _ => fail "Unsupported domain" end in tac. diff --git a/theories/micromega/Psatz.v b/theories/micromega/Psatz.v index e65b1c8e40..72b2f7175b 100644 --- a/theories/micromega/Psatz.v +++ b/theories/micromega/Psatz.v @@ -34,9 +34,9 @@ Ltac nia := Lia.nia. Ltac xpsatz dom d := let tac := lazymatch dom with - | Z => (xsos_Z Lia.zchecker) || (xpsatz_Z d Lia.zchecker) - | R => (xsos_R Lra.rchecker) || (xpsatz_R d Lra.rchecker) - | Q => (xsos_Q Lqa.rchecker) || (xpsatz_Q d Lqa.rchecker) + | Z => (mp_sos_Z Lia.zchecker) || (mp_psatz_Z d Lia.zchecker) + | R => (mp_sos_R Lra.rchecker) || (mp_psatz_R d Lra.rchecker) + | Q => (mp_sos_Q Lqa.rchecker) || (mp_psatz_Q d Lqa.rchecker) | _ => fail "Unsupported domain" end in tac. From b1035a8a953465b7f937891b8faa5cef73e455b2 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Tue, 9 Sep 2025 11:19:48 +0200 Subject: [PATCH 10/12] Add overlays --- .github/workflows/nix-action-rocq-9.1.yml | 399 +------------------ .github/workflows/nix-action-rocq-9.2.yml | 78 ---- .github/workflows/nix-action-rocq-master.yml | 78 ---- .nix/config.nix | 13 +- .nix/coq-nix-toolbox.nix | 2 +- default.nix | 4 +- 6 files changed, 23 insertions(+), 551 deletions(-) diff --git a/.github/workflows/nix-action-rocq-9.1.yml b/.github/workflows/nix-action-rocq-9.1.yml index 2a8c222ec5..88945a6589 100644 --- a/.github/workflows/nix-action-rocq-9.1.yml +++ b/.github/workflows/nix-action-rocq-9.1.yml @@ -2506,87 +2506,13 @@ jobs: run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.1" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "mathcomp-algebra" - mathcomp-algebra-tactics: - needs: - - coq - - mathcomp-algebra - - coq-elpi - - mathcomp-zify - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (mathcomp-algebra-tactics) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.1\" --argstr job \"mathcomp-algebra-tactics\" \\\n --dry-run 2> - err > out || (touch fail; true)\ncat out err\nif [ -e fail ]; then echo \"\ - Error: getting derivation failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: mathcomp-ssreflect' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "mathcomp-ssreflect" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: mathcomp-algebra' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "mathcomp-algebra" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq-elpi' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "coq-elpi" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: mathcomp-zify' + name: 'Building/fetching previous CI target: micromega-plugin' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "mathcomp-zify" + "rocq-9.1" --argstr job "micromega-plugin" - if: steps.stepCheck.outputs.status != 'fetched' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "mathcomp-algebra-tactics" + "rocq-9.1" --argstr job "mathcomp-algebra" mathcomp-analysis: needs: - coq @@ -3660,317 +3586,6 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.1" --argstr job "mathcomp-zify" - metarocq-common: - needs: - - coq - - equations - - ExtLib - - stdlib - - metarocq-utils - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (metarocq-common) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.1\" --argstr job \"metarocq-common\" \\\n --dry-run 2> err > out - || (touch fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting - derivation failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: equations' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "equations" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: ExtLib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "ExtLib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: stdlib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "stdlib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: metarocq-utils' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "metarocq-utils" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "metarocq-common" - metarocq-template-rocq: - needs: - - coq - - equations - - ExtLib - - stdlib - - metarocq-common - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (metarocq-template-rocq) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.1\" --argstr job \"metarocq-template-rocq\" \\\n --dry-run 2> err - > out || (touch fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: - getting derivation failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: equations' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "equations" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: ExtLib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "ExtLib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: stdlib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "stdlib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: metarocq-common' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "metarocq-common" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "metarocq-template-rocq" - metarocq-translations: - needs: - - coq - - equations - - ExtLib - - stdlib - - metarocq-template-rocq - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (metarocq-translations) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.1\" --argstr job \"metarocq-translations\" \\\n --dry-run 2> err - > out || (touch fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: - getting derivation failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: equations' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "equations" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: ExtLib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "ExtLib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: stdlib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "stdlib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: metarocq-template-rocq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "metarocq-template-rocq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "metarocq-translations" - metarocq-utils: - needs: - - coq - - equations - - ExtLib - - stdlib - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (metarocq-utils) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.1\" --argstr job \"metarocq-utils\" \\\n --dry-run 2> err > out - || (touch fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting - derivation failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: equations' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "equations" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: ExtLib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "ExtLib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: stdlib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "stdlib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "metarocq-utils" mtac2: needs: - coq @@ -4991,6 +4606,10 @@ jobs: name: 'Building/fetching previous CI target: rocq-core' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.1" --argstr job "rocq-core" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: micromega-plugin' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-9.1" --argstr job "micromega-plugin" - if: steps.stepCheck.outputs.status != 'fetched' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle @@ -5055,6 +4674,10 @@ jobs: name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.1" --argstr job "stdlib" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: micromega-plugin' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-9.1" --argstr job "micromega-plugin" - if: steps.stepCheck.outputs.status != 'fetched' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle diff --git a/.github/workflows/nix-action-rocq-9.2.yml b/.github/workflows/nix-action-rocq-9.2.yml index eb407baf75..de8c10261f 100644 --- a/.github/workflows/nix-action-rocq-9.2.yml +++ b/.github/workflows/nix-action-rocq-9.2.yml @@ -2509,84 +2509,6 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.2" --argstr job "mathcomp-algebra" - mathcomp-algebra-tactics: - needs: - - coq - - mathcomp-algebra - - coq-elpi - - mathcomp-zify - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (mathcomp-algebra-tactics) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.2\" --argstr job \"mathcomp-algebra-tactics\" \\\n --dry-run 2> - err > out || (touch fail; true)\ncat out err\nif [ -e fail ]; then echo \"\ - Error: getting derivation failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: mathcomp-ssreflect' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "mathcomp-ssreflect" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: mathcomp-algebra' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "mathcomp-algebra" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq-elpi' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "coq-elpi" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: mathcomp-zify' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "mathcomp-zify" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "mathcomp-algebra-tactics" mathcomp-analysis: needs: - coq diff --git a/.github/workflows/nix-action-rocq-master.yml b/.github/workflows/nix-action-rocq-master.yml index 493e8b1119..818efa993a 100644 --- a/.github/workflows/nix-action-rocq-master.yml +++ b/.github/workflows/nix-action-rocq-master.yml @@ -3636,84 +3636,6 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-master" --argstr job "mathcomp-algebra" - mathcomp-algebra-tactics: - needs: - - coq - - mathcomp-algebra - - coq-elpi - - mathcomp-zify - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (mathcomp-algebra-tactics) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-master\" --argstr job \"mathcomp-algebra-tactics\" \\\n --dry-run - 2> err > out || (touch fail; true)\ncat out err\nif [ -e fail ]; then echo - \"Error: getting derivation failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-master" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: mathcomp-ssreflect' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-master" --argstr job "mathcomp-ssreflect" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: mathcomp-algebra' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-master" --argstr job "mathcomp-algebra" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq-elpi' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-master" --argstr job "coq-elpi" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: mathcomp-zify' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-master" --argstr job "mathcomp-zify" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-master" --argstr job "mathcomp-algebra-tactics" mathcomp-analysis: needs: - coq diff --git a/.nix/config.nix b/.nix/config.nix index 272c34bd26..24d1e0272f 100644 --- a/.nix/config.nix +++ b/.nix/config.nix @@ -156,7 +156,6 @@ with builtins; with (import {}).lib; "itree-io" "json" "kami" - "mathcomp-algebra-tactics" "mathcomp-analysis" "mathcomp-classical" "mathcomp-reals" @@ -227,6 +226,7 @@ with builtins; with (import {}).lib; "metacoq-translations" "metacoq-utils" "metarocq" + "metarocq-common" "metarocq-erasure" "metarocq-erasure-plugin" "metarocq-pcuic" @@ -234,7 +234,10 @@ with builtins; with (import {}).lib; "metarocq-safechecker" "metarocq-safechecker-plugin" "metarocq-template-pcuic" + "metarocq-template-rocq" "metarocq-test" + "metarocq-translations" + "metarocq-utils" "rewriter" "riscvcoq" "rupicola" @@ -258,6 +261,7 @@ with builtins; with (import {}).lib; iris-examples.job = false; # Currently broken jasmin.job = false; # Currently broken, c.f., https://github.com/rocq-prover/rocq/pull/20589 CakeMLExtraction.job = false; # not in Rocq CI + verified-extraction.job = false; # not in Rocq CI ceres-bs.job = false; # not in Rocq CI CertiRocq.job = false; # not in Rocq CI ConCert.job = false; # not in Rocq CI @@ -280,6 +284,9 @@ with builtins; with (import {}).lib; # for a complete list of Coq packages available in Nix # * : is such that this will use the branch # from https://github.com// + smtcoq.override.version = "proux01:stdlib251"; + metarocq.override.version = "proux01:stdlib251"; + metarocq-test.override.version = "proux01:stdlib251"; sf.job = false; # temporarily disactivated in Rocq CI trakt.job = false; # temporarily disactivated in Rocq CI smtcoq-trakt.job = false; # temporarily disactivated in Rocq CI @@ -349,14 +356,12 @@ with builtins; with (import {}).lib; equations.override.version = "2137c8e7081f2d47ab903de0cc09fd6a05bfab01"; equations-test.job = false; fiat-parsers.job = false; # broken - metarocq.override.version = "2995003b88f3812e5649cfdd0f9a4c44ceaf0700"; - metarocq-test.override.version = "2995003b88f3812e5649cfdd0f9a4c44ceaf0700"; mtac2.override.version = "bcbefa79406fc113f878eb5f89758de241d81433"; paramcoq-test.override.version = "937537d416bc5f7b81937d4223d7783d0e687239"; relation-algebra.override.version = "4db15229396abfd8913685be5ffda4f0fdb593d9"; rewriter.override.version = "9496defb8b236f442d11372f6e0b5e48aa38acfc"; rocq-lean-import.override.version = "c3546102f242aaa1e9af921c78bdb1132522e444"; - smtcoq.override.version = "5c6033c906249fcf98a48b4112f6996053124514"; + # smtcoq.override.version = "5c6033c906249fcf98a48b4112f6996053124514"; # smtcoq-trakt.override.version = "9392f7446a174b770110445c155a07b183cdca3d"; stalmarck-tactic.override.version = "d32acd3c477c57b48dd92bdd96d53fb8fa628512"; unicoq.override.version = "28ec18aef35877829535316fc09825a25be8edf1"; diff --git a/.nix/coq-nix-toolbox.nix b/.nix/coq-nix-toolbox.nix index b6d32e70df..4f9fec949b 100644 --- a/.nix/coq-nix-toolbox.nix +++ b/.nix/coq-nix-toolbox.nix @@ -1 +1 @@ -"3b7baf61aa95441d62332d7fdad562a61a125f80" +"e0b17bf483bcde5079722f9bc494063373ee098e" diff --git a/default.nix b/default.nix index ec2742873f..4bb04e5b4c 100644 --- a/default.nix +++ b/default.nix @@ -4,8 +4,8 @@ bundle ? null, job ? null, inNixShell ? null, src ? ./., }@args: let auto = fetchGit { - url = "https://github.com/rocq-community/coq-nix-toolbox.git"; - ref = "master"; + url = "https://github.com/proux01/coq-nix-toolbox.git"; + ref = "micromega"; rev = import .nix/coq-nix-toolbox.nix; }; in From be4ff3bd88787696ed41e9a447703cb0c75c9c76 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Mon, 13 Apr 2026 08:45:23 +0200 Subject: [PATCH 11/12] [test-suite] Fix error message --- test-suite/Makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test-suite/Makefile b/test-suite/Makefile index 3f841e31c7..3cf28cf991 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -136,7 +136,8 @@ PREREQUISITELOG = $(addsuffix .log,$(wildcard prerequisite/*.v)) .csdp.cache ifeq ($(COQLIB_NOT_FOUND),true) all: @echo "" - @echo "Coq's standard library has not been installed; please run: " + @echo "The Stdli library has not been installed; please run:" + @echo " - cd .." @echo " - make" @echo " - make install" @echo "" From 1234d15b6aea87944a3ef64c97caf3a6b0aa2a6d Mon Sep 17 00:00:00 2001 From: Frederic Besson Date: Thu, 2 Apr 2026 17:57:43 +0200 Subject: [PATCH 12/12] [zify] Define zify in terms of tify_* tactics restructure components (isolate tify,zify) --- .github/workflows/nix-action-rocq-9.1.yml | 254 ++++------------- .github/workflows/nix-action-rocq-9.2.yml | 266 +++++------------- .github/workflows/nix-action-rocq-master.yml | 79 ++++++ .nix/config.nix | 31 +- .nix/coq-overlays/itauto/default.nix | 67 +++++ .nix/coq-overlays/itauto/test.nix | 38 +++ .../stdlib-refman-html/default.nix | 6 +- rocq-stdlib.opam | 1 + subcomponents/lia.v | 10 +- subcomponents/tify.v | 12 + test-suite/micromega/bug_18158.v | 2 +- test-suite/success/TifyZR.v | 86 ++++++ theories/Strings/PString.v | 2 +- theories/dune | 3 +- theories/micromega/SatDivMod.v | 4 +- theories/micromega/Tify.v | 17 ++ theories/micromega/Zify.v | 10 +- theories/micromega/ZifyBool.v | 54 ++-- theories/micromega/ZifyClasses.v | 2 +- theories/micromega/ZifyComparison.v | 28 +- theories/micromega/ZifyInst.v | 232 +++++++-------- theories/micromega/ZifyN.v | 10 +- theories/micromega/ZifyNat.v | 6 +- theories/micromega/ZifySint63.v | 48 ++-- theories/micromega/ZifyUint63.v | 62 ++-- 25 files changed, 701 insertions(+), 629 deletions(-) create mode 100644 .nix/coq-overlays/itauto/default.nix create mode 100644 .nix/coq-overlays/itauto/test.nix create mode 100644 subcomponents/tify.v create mode 100644 test-suite/success/TifyZR.v create mode 100644 theories/micromega/Tify.v diff --git a/.github/workflows/nix-action-rocq-9.1.yml b/.github/workflows/nix-action-rocq-9.1.yml index 88945a6589..20615c4f9d 100644 --- a/.github/workflows/nix-action-rocq-9.1.yml +++ b/.github/workflows/nix-action-rocq-9.1.yml @@ -1770,70 +1770,6 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.1" --argstr job "dpdgraph-test" - equations: - needs: - - coq - - stdlib - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (equations) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.1\" --argstr job \"equations\" \\\n --dry-run 2> err > out || (touch - fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting derivation - failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: stdlib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "stdlib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "equations" fcsl-pcm: needs: - coq @@ -2441,6 +2377,7 @@ jobs: - mathcomp-order - mathcomp-fingroup - hierarchy-builder + - micromega-plugin runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout @@ -3586,6 +3523,65 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.1" --argstr job "mathcomp-zify" + micromega-plugin: + needs: + - rocq-core + runs-on: ubuntu-latest + steps: + - name: Determine which commit to initially checkout + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ + github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha + }}\" >> $GITHUB_ENV\nfi\n" + - name: Git checkout + uses: actions/checkout@v6 + with: + fetch-depth: 0 + ref: ${{ env.target_commit }} + - name: Determine which commit to test + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ + github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url + }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git + merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null + 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ + \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha + }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ + \ fi\nfi\n" + - name: Git checkout + uses: actions/checkout@v6 + with: + fetch-depth: 0 + ref: ${{ env.tested_commit }} + - name: Cachix install + uses: cachix/install-nix-action@v31 + with: + nix_path: nixpkgs=channel:nixpkgs-unstable + - name: Cachix setup coq + uses: cachix/cachix-action@v16 + with: + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} + extraPullNames: coq-community, math-comp + name: coq + - id: stepGetDerivation + name: Getting derivation for current job (micromega-plugin) + run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle + \"rocq-9.1\" --argstr job \"micromega-plugin\" \\\n --dry-run 2> err > out + || (touch fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting + derivation failed\"; exit 1; fi\n" + - id: stepCheck + name: Checking presence of CI target for current job + run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs + actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ + ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ + \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ + status=fetched\" >> $GITHUB_OUTPUT\nfi\n" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: rocq-core' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-9.1" --argstr job "rocq-core" + - if: steps.stepCheck.outputs.status != 'fetched' + name: Building/fetching current CI target + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-9.1" --argstr job "micromega-plugin" mtac2: needs: - coq @@ -4359,70 +4355,6 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.1" --argstr job "simple-io" - smtcoq: - needs: - - coq - - stdlib - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (smtcoq) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.1\" --argstr job \"smtcoq\" \\\n --dry-run 2> err > out || (touch - fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting derivation - failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: stdlib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "stdlib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "smtcoq" stalmarck: needs: - coq @@ -4554,6 +4486,7 @@ jobs: stdlib: needs: - rocq-core + - micromega-plugin runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout @@ -4618,6 +4551,7 @@ jobs: needs: - rocq-core - stdlib + - micromega-plugin runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout @@ -4869,70 +4803,6 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.1" --argstr job "unicoq" - waterproof: - needs: - - coq - - stdlib - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (waterproof) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.1\" --argstr job \"waterproof\" \\\n --dry-run 2> err > out || - (touch fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting - derivation failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: stdlib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "stdlib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.1" --argstr job "waterproof" name: Nix CI for bundle rocq-9.1 on: pull_request: diff --git a/.github/workflows/nix-action-rocq-9.2.yml b/.github/workflows/nix-action-rocq-9.2.yml index de8c10261f..a6a3bfdb74 100644 --- a/.github/workflows/nix-action-rocq-9.2.yml +++ b/.github/workflows/nix-action-rocq-9.2.yml @@ -1770,70 +1770,6 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.2" --argstr job "dpdgraph-test" - equations: - needs: - - coq - - stdlib - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (equations) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.2\" --argstr job \"equations\" \\\n --dry-run 2> err > out || (touch - fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting derivation - failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: stdlib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "stdlib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "equations" fcsl-pcm: needs: - coq @@ -2441,6 +2377,7 @@ jobs: - mathcomp-order - mathcomp-fingroup - hierarchy-builder + - micromega-plugin runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout @@ -2505,6 +2442,10 @@ jobs: name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.2" --argstr job "hierarchy-builder" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: micromega-plugin' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-9.2" --argstr job "micromega-plugin" - if: steps.stepCheck.outputs.status != 'fetched' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle @@ -3582,6 +3523,65 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.2" --argstr job "mathcomp-zify" + micromega-plugin: + needs: + - rocq-core + runs-on: ubuntu-latest + steps: + - name: Determine which commit to initially checkout + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ + github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha + }}\" >> $GITHUB_ENV\nfi\n" + - name: Git checkout + uses: actions/checkout@v6 + with: + fetch-depth: 0 + ref: ${{ env.target_commit }} + - name: Determine which commit to test + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ + github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url + }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git + merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null + 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ + \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha + }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ + \ fi\nfi\n" + - name: Git checkout + uses: actions/checkout@v6 + with: + fetch-depth: 0 + ref: ${{ env.tested_commit }} + - name: Cachix install + uses: cachix/install-nix-action@v31 + with: + nix_path: nixpkgs=channel:nixpkgs-unstable + - name: Cachix setup coq + uses: cachix/cachix-action@v16 + with: + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} + extraPullNames: coq-community, math-comp + name: coq + - id: stepGetDerivation + name: Getting derivation for current job (micromega-plugin) + run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle + \"rocq-9.2\" --argstr job \"micromega-plugin\" \\\n --dry-run 2> err > out + || (touch fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting + derivation failed\"; exit 1; fi\n" + - id: stepCheck + name: Checking presence of CI target for current job + run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs + actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ + ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ + \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ + status=fetched\" >> $GITHUB_OUTPUT\nfi\n" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: rocq-core' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-9.2" --argstr job "rocq-core" + - if: steps.stepCheck.outputs.status != 'fetched' + name: Building/fetching current CI target + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-9.2" --argstr job "micromega-plugin" mtac2: needs: - coq @@ -4355,70 +4355,6 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.2" --argstr job "simple-io" - smtcoq: - needs: - - coq - - stdlib - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (smtcoq) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.2\" --argstr job \"smtcoq\" \\\n --dry-run 2> err > out || (touch - fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting derivation - failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: stdlib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "stdlib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "smtcoq" stalmarck: needs: - coq @@ -4550,6 +4486,7 @@ jobs: stdlib: needs: - rocq-core + - micromega-plugin runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout @@ -4602,6 +4539,10 @@ jobs: name: 'Building/fetching previous CI target: rocq-core' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.2" --argstr job "rocq-core" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: micromega-plugin' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-9.2" --argstr job "micromega-plugin" - if: steps.stepCheck.outputs.status != 'fetched' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle @@ -4610,6 +4551,7 @@ jobs: needs: - rocq-core - stdlib + - micromega-plugin runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout @@ -4666,6 +4608,10 @@ jobs: name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.2" --argstr job "stdlib" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: micromega-plugin' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-9.2" --argstr job "micromega-plugin" - if: steps.stepCheck.outputs.status != 'fetched' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle @@ -4911,70 +4857,6 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.2" --argstr job "unicoq" - waterproof: - needs: - - coq - - stdlib - runs-on: ubuntu-latest - steps: - - name: Determine which commit to initially checkout - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.target_commit }} - - name: Determine which commit to test - run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ - github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url - }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git - merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null - 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ - \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha - }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ - \ fi\nfi\n" - - name: Git checkout - uses: actions/checkout@v6 - with: - fetch-depth: 0 - ref: ${{ env.tested_commit }} - - name: Cachix install - uses: cachix/install-nix-action@v31 - with: - nix_path: nixpkgs=channel:nixpkgs-unstable - - name: Cachix setup coq - uses: cachix/cachix-action@v16 - with: - authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - extraPullNames: coq-community, math-comp - name: coq - - id: stepGetDerivation - name: Getting derivation for current job (waterproof) - run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle - \"rocq-9.2\" --argstr job \"waterproof\" \\\n --dry-run 2> err > out || - (touch fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: getting - derivation failed\"; exit 1; fi\n" - - id: stepCheck - name: Checking presence of CI target for current job - run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs - actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ - ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ - \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ - status=fetched\" >> $GITHUB_OUTPUT\nfi\n" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: coq' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "coq" - - if: steps.stepCheck.outputs.status != 'fetched' - name: 'Building/fetching previous CI target: stdlib' - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "stdlib" - - if: steps.stepCheck.outputs.status != 'fetched' - name: Building/fetching current CI target - run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle - "rocq-9.2" --argstr job "waterproof" name: Nix CI for bundle rocq-9.2 on: pull_request: diff --git a/.github/workflows/nix-action-rocq-master.yml b/.github/workflows/nix-action-rocq-master.yml index 818efa993a..d98ad5a635 100644 --- a/.github/workflows/nix-action-rocq-master.yml +++ b/.github/workflows/nix-action-rocq-master.yml @@ -3568,6 +3568,7 @@ jobs: - mathcomp-order - mathcomp-fingroup - hierarchy-builder + - micromega-plugin runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout @@ -3632,6 +3633,10 @@ jobs: name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-master" --argstr job "hierarchy-builder" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: micromega-plugin' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-master" --argstr job "micromega-plugin" - if: steps.stepCheck.outputs.status != 'fetched' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle @@ -5761,6 +5766,65 @@ jobs: name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-master" --argstr job "metarocq-utils" + micromega-plugin: + needs: + - rocq-core + runs-on: ubuntu-latest + steps: + - name: Determine which commit to initially checkout + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ + github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha + }}\" >> $GITHUB_ENV\nfi\n" + - name: Git checkout + uses: actions/checkout@v6 + with: + fetch-depth: 0 + ref: ${{ env.target_commit }} + - name: Determine which commit to test + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ + github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url + }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git + merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null + 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ + \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha + }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ + \ fi\nfi\n" + - name: Git checkout + uses: actions/checkout@v6 + with: + fetch-depth: 0 + ref: ${{ env.tested_commit }} + - name: Cachix install + uses: cachix/install-nix-action@v31 + with: + nix_path: nixpkgs=channel:nixpkgs-unstable + - name: Cachix setup coq + uses: cachix/cachix-action@v16 + with: + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} + extraPullNames: coq-community, math-comp + name: coq + - id: stepGetDerivation + name: Getting derivation for current job (micromega-plugin) + run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle + \"rocq-master\" --argstr job \"micromega-plugin\" \\\n --dry-run 2> err + > out || (touch fail; true)\ncat out err\nif [ -e fail ]; then echo \"Error: + getting derivation failed\"; exit 1; fi\n" + - id: stepCheck + name: Checking presence of CI target for current job + run: "if $(cat out err | grep -q \"built:\") ; then\n echo \"CI target needs + actual building\"\n if $(cat out err | grep -q \"derivations will be built:\"\ + ) ; then\n echo \"waiting a bit for derivations that should be in cache\"\ + \n sleep 30\n fi\nelse\n echo \"CI target already built\"\n echo \"\ + status=fetched\" >> $GITHUB_OUTPUT\nfi\n" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: rocq-core' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-master" --argstr job "rocq-core" + - if: steps.stepCheck.outputs.status != 'fetched' + name: Building/fetching current CI target + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-master" --argstr job "micromega-plugin" mtac2: needs: - coq @@ -6926,6 +6990,7 @@ jobs: stdlib: needs: - rocq-core + - micromega-plugin runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout @@ -6978,6 +7043,10 @@ jobs: name: 'Building/fetching previous CI target: rocq-core' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-master" --argstr job "rocq-core" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: micromega-plugin' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-master" --argstr job "micromega-plugin" - if: steps.stepCheck.outputs.status != 'fetched' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle @@ -6986,6 +7055,7 @@ jobs: needs: - rocq-core - stdlib + - micromega-plugin runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout @@ -7042,6 +7112,10 @@ jobs: name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-master" --argstr job "stdlib" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: micromega-plugin' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-master" --argstr job "micromega-plugin" - if: steps.stepCheck.outputs.status != 'fetched' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle @@ -7050,6 +7124,7 @@ jobs: needs: - rocq-core - stdlib + - micromega-plugin runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout @@ -7106,6 +7181,10 @@ jobs: name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-master" --argstr job "stdlib" + - if: steps.stepCheck.outputs.status != 'fetched' + name: 'Building/fetching previous CI target: micromega-plugin' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle + "rocq-master" --argstr job "micromega-plugin" - if: steps.stepCheck.outputs.status != 'fetched' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle diff --git a/.nix/config.nix b/.nix/config.nix index 24d1e0272f..142a42d3c1 100644 --- a/.nix/config.nix +++ b/.nix/config.nix @@ -252,7 +252,7 @@ with builtins; with (import {}).lib; // listToAttrs (forEach main (p: { name = p; value.override.version = "main"; })) // { - coq-elpi.override.version = "master"; + # coq-elpi.override.version = "master"; coq-elpi.override.elpi-version = "3.6.2"; tlc.override.version = "master-for-coq-ci"; smtcoq-trakt.override.version = "with-trakt-coq-master"; @@ -284,15 +284,28 @@ with builtins; with (import {}).lib; # for a complete list of Coq packages available in Nix # * : is such that this will use the branch # from https://github.com// + micromega-plugin.override.version = "tify"; + bedrock2.override.version = "proux01:stdlib251"; + coq-elpi.override.version = "proux01:stdlib251"; + coqutil.override.version = "proux01:stdlib251"; + itauto.override.version = "proux01:stdlib251"; + equations.override.version = "proux01:stdlib251"; + equations-test.override.version = "proux01:stdlib251"; smtcoq.override.version = "proux01:stdlib251"; metarocq.override.version = "proux01:stdlib251"; metarocq-test.override.version = "proux01:stdlib251"; + waterproof.override.version = "proux01:stdlib251"; sf.job = false; # temporarily disactivated in Rocq CI trakt.job = false; # temporarily disactivated in Rocq CI smtcoq-trakt.job = false; # temporarily disactivated in Rocq CI }; common-bundles = listToAttrs (forEach rocq-master (p: - { name = p; value.override.version = "master"; })); + { name = p; value.override.version = "master"; })) + // { + micromega-plugin.override.version = "tify"; + rocq-elpi.override.version = "proux01:stdlib251"; + rocq-elpi-test.override.version = "proux01:stdlib251"; + }; in { "rocq-master" = { rocqPackages = common-bundles // { rocq-core.override.version = "master"; @@ -318,7 +331,7 @@ with builtins; with (import {}).lib; dpdgraph-test.override.version = "7a0fba21287dd8889c55e6611f8ba219d012b81b"; coq-hammer.override.version = "1d581299c2a85af175b53bd35370ea074af922ec"; coq-hammer-tactics.override.version = "1d581299c2a85af175b53bd35370ea074af922ec"; - equations.override.version = "757662b9c875d7169a07b861d48e82157520ab1a"; + equations.job = false; equations-test.job = false; fiat-parsers.job = false; # broken metarocq.override.version = "e8f8078e756cc378b830eb5a8e4637df43d481af"; @@ -328,11 +341,13 @@ with builtins; with (import {}).lib; relation-algebra.override.version = "ba3db5783060d9e25d1db5e377fc9d71338a5160"; rewriter.override.version = "dd37fb28ed7f01a3b7edc0675a86b95dd3eb1545"; rocq-lean-import.override.version = "b8291b9dae4f5ed780112e95eea484e435199b46"; - smtcoq.override.version = "cff0a8cdb7c73b6c59965a749a4304f3c4ac01bf"; + # smtcoq.override.version = "cff0a8cdb7c73b6c59965a749a4304f3c4ac01bf"; + smtcoq.job = false; # smtcoq-trakt.override.version = "9392f7446a174b770110445c155a07b183cdca3d"; stalmarck-tactic.override.version = "d32acd3c477c57b48dd92bdd96d53fb8fa628512"; unicoq.override.version = "d52374ca86e3885197f114555e742420fa9bbe94"; - waterproof.override.version = "99ad6ff78fa700c84ba0cb1d1bda27d8e0f11e1a"; + # waterproof.override.version = "99ad6ff78fa700c84ba0cb1d1bda27d8e0f11e1a"; + waterproof.job = false; compcert.job = false; # broken VST.job = false; # depends on compcert } // listToAttrs (forEach lighten-released (p: @@ -353,7 +368,7 @@ with builtins; with (import {}).lib; dpdgraph-test.override.version = "7817def06d4e3abc2e54a2600cf6e29d63d58b8a"; coq-hammer.override.version = "8649603dcbac5d92eaf1319a6b7cdfc65cdd804b"; coq-hammer-tactics.override.version = "8649603dcbac5d92eaf1319a6b7cdfc65cdd804b"; - equations.override.version = "2137c8e7081f2d47ab903de0cc09fd6a05bfab01"; + equations.job = false; equations-test.job = false; fiat-parsers.job = false; # broken mtac2.override.version = "bcbefa79406fc113f878eb5f89758de241d81433"; @@ -362,10 +377,12 @@ with builtins; with (import {}).lib; rewriter.override.version = "9496defb8b236f442d11372f6e0b5e48aa38acfc"; rocq-lean-import.override.version = "c3546102f242aaa1e9af921c78bdb1132522e444"; # smtcoq.override.version = "5c6033c906249fcf98a48b4112f6996053124514"; + smtcoq.job = false; # smtcoq-trakt.override.version = "9392f7446a174b770110445c155a07b183cdca3d"; stalmarck-tactic.override.version = "d32acd3c477c57b48dd92bdd96d53fb8fa628512"; unicoq.override.version = "28ec18aef35877829535316fc09825a25be8edf1"; - waterproof.override.version = "dd712eb0b7f5c205870dbd156736a684d40eeb9a"; + # waterproof.override.version = "dd712eb0b7f5c205870dbd156736a684d40eeb9a"; + waterproof.job = false; compcert.job = false; # broken VST.job = false; # depends on compcert } // listToAttrs (forEach lighten-released (p: diff --git a/.nix/coq-overlays/itauto/default.nix b/.nix/coq-overlays/itauto/default.nix new file mode 100644 index 0000000000..bb50706f3b --- /dev/null +++ b/.nix/coq-overlays/itauto/default.nix @@ -0,0 +1,67 @@ +{ + lib, + callPackage, + mkCoqDerivation, + coq, + stdlib, + dune, + version ? null, +}: + +(mkCoqDerivation { + pname = "itauto"; + owner = "fbesson"; + # domain = "gitlab.inria.fr"; + + release."8.20.0".sha256 = "sha256-LYKGbI3O6yw6CiTJNUGL11PT4q4o+gJK1kQgKQL0/Hk="; + release."8.19.0".sha256 = "sha256-xKWCF4dYvvlJUVGCZcR2RLCG55vlGzu2GN30MeRvVD4="; + release."8.18.0".sha256 = "sha256-4mDDnKTeYrf27uRMkydQxO7j2tfgTFXOREW474d40eo="; + release."8.17.0".sha256 = "sha256-fgdnKchNT1Hyrq14gU8KWYnlSfg3qlsSw5A4+RoA26w="; + release."8.16.0".sha256 = "sha256-4zAUYGlw/pBcLPv2GroIduIlvbfi1+Vy+TdY8KLCqO4="; + release."8.15.0".sha256 = "sha256:10qpv4nx1p0wm9sas47yzsg9z22dhvizszfa21yff08a8fr0igya"; + release."8.14.0".sha256 = "sha256:1k6pqhv4dwpkwg81f2rlfg40wh070ks1gy9r0ravm2zhsbxqcfc9"; + release."8.13+no".sha256 = "sha256-gXoxtLcHPoyjJkt7WqvzfCMCQlh6kL2KtCGe3N6RC/A="; + inherit version; + defaultVersion = + let + case = case: out: { inherit case out; }; + in + with lib.versions; + lib.switch coq.coq-version [ + (case (isEq "8.20") "8.20.0") + (case (isEq "8.19") "8.19.0") + (case (isEq "8.18") "8.18.0") + (case (isEq "8.17") "8.17.0") + (case (isEq "8.16") "8.16.0") + (case (isEq "8.15") "8.15.0") + (case (isEq "8.14") "8.14.0") + (case (isEq "8.13") "8.13+no") + ] null; + + mlPlugin = true; + nativeBuildInputs = (with coq.ocamlPackages; [ ocamlbuild ]); + enableParallelBuilding = false; + + passthru.tests.suite = callPackage ./test.nix { }; + + propagatedBuildInputs = [ stdlib ]; + + meta = { + description = "Reflexive SAT solver parameterised by a leaf tactic and Nelson-Oppen support"; + maintainers = with lib.maintainers; [ siraben ]; + license = lib.licenses.gpl3Plus; + }; +}).overrideAttrs + ( + o: + lib.optionalAttrs (o.version == "dev" || lib.versionAtLeast o.version "8.16") { + propagatedBuildInputs = o.propagatedBuildInputs ++ [ coq.ocamlPackages.findlib ]; + } + // lib.optionalAttrs (o.version == "dev" || lib.versionAtLeast o.version "8.18") { + nativeBuildInputs = with coq.ocamlPackages; [ + ocaml + findlib + dune + ]; + } + ) diff --git a/.nix/coq-overlays/itauto/test.nix b/.nix/coq-overlays/itauto/test.nix new file mode 100644 index 0000000000..f442783904 --- /dev/null +++ b/.nix/coq-overlays/itauto/test.nix @@ -0,0 +1,38 @@ +{ + stdenv, + lib, + coq, + itauto, +}: + +let + excluded = lib.optionals (lib.versions.isEq "8.16" itauto.version) [ + "arith.v" + "refl_bool.v" + ]; +in + +stdenv.mkDerivation { + pname = "coq${coq.coq-version}-itauto-test"; + inherit (itauto) src version; + + nativeCheckInputs = [ + coq + itauto + ]; + + dontConfigure = true; + dontBuild = true; + doCheck = true; + + checkPhase = '' + cd test-suite + for m in *.v + do + echo -n ${lib.concatStringsSep " " excluded} | grep --silent $m && continue + echo $m && coqc $m + done + ''; + + installPhase = "touch $out"; +} diff --git a/.nix/rocq-overlays/stdlib-refman-html/default.nix b/.nix/rocq-overlays/stdlib-refman-html/default.nix index bdf9ed39ac..c35cf8e20c 100644 --- a/.nix/rocq-overlays/stdlib-refman-html/default.nix +++ b/.nix/rocq-overlays/stdlib-refman-html/default.nix @@ -15,8 +15,12 @@ rocqPackages.lib.overrideRocqDerivation { useDune = true; - buildPhase = '' + configurePhase = '' + export COQPATH=''${ROCQPATH} patchShebangs dev/with-rocq-wrap.sh + ''; + + buildPhase = '' dev/with-rocq-wrap.sh dune build --root . --no-buffer @refman-html ''${enableParallelBuilding:+-j $NIX_BUILD_CORES} ''; diff --git a/rocq-stdlib.opam b/rocq-stdlib.opam index 9ae8c9805d..78db1fac90 100644 --- a/rocq-stdlib.opam +++ b/rocq-stdlib.opam @@ -26,6 +26,7 @@ dev-repo: "git+https://github.com/coq/stdlib.git" depends: [ "rocq-runtime" "rocq-core" {>= "9.1"} + "micromega-plugin" {= "dev"} ] build: [ [make "-j" jobs] diff --git a/subcomponents/lia.v b/subcomponents/lia.v index 9edcd1b3ab..b1a1a6e7bb 100644 --- a/subcomponents/lia.v +++ b/subcomponents/lia.v @@ -1,11 +1,3 @@ From subcomponents Require ring. +From subcomponents Require tify. From Stdlib Require micromega.Lia. -From Stdlib Require micromega.SatDivMod. -From Stdlib Require micromega.Zify. -From Stdlib Require micromega.ZifyBool. -From Stdlib Require micromega.ZifyClasses. -From Stdlib Require micromega.ZifyComparison. -From Stdlib Require micromega.ZifyInst. -From Stdlib Require micromega.ZifyN. -From Stdlib Require micromega.ZifyNat. -From Stdlib Require micromega.ZifyPow. diff --git a/subcomponents/tify.v b/subcomponents/tify.v new file mode 100644 index 0000000000..35e44cc167 --- /dev/null +++ b/subcomponents/tify.v @@ -0,0 +1,12 @@ +From subcomponents Require integers. +From subcomponents Require ring. +From Stdlib Require micromega.Tify. +From Stdlib Require micromega.Zify. +From Stdlib Require micromega.SatDivMod. +From Stdlib Require micromega.ZifyBool. +From Stdlib Require micromega.ZifyClasses. +From Stdlib Require micromega.ZifyComparison. +From Stdlib Require micromega.ZifyInst. +From Stdlib Require micromega.ZifyN. +From Stdlib Require micromega.ZifyNat. +From Stdlib Require micromega.ZifyPow. diff --git a/test-suite/micromega/bug_18158.v b/test-suite/micromega/bug_18158.v index b863204316..f6be97463c 100644 --- a/test-suite/micromega/bug_18158.v +++ b/test-suite/micromega/bug_18158.v @@ -85,7 +85,7 @@ Goal forall x y , -> Z.le (Z.shiftr y 8) 255 -> Z.le (Z.shiftr x 24) 255. intros. - Zify.zify_saturate. + Tify.tify_saturate. (* [mp_lia zchecker] used to raise a [Stack overflow] error. It is supposed to fail normally. *) assert_fails (mp_lia zchecker). Abort. diff --git a/test-suite/success/TifyZR.v b/test-suite/success/TifyZR.v new file mode 100644 index 0000000000..799a5f3ee2 --- /dev/null +++ b/test-suite/success/TifyZR.v @@ -0,0 +1,86 @@ +From Stdlib Require Import Tify. +From Stdlib Require Import ZifyClasses. +From Stdlib Require Import Reals. +From Stdlib Require Import Lra. +(* [zify] instances are already loaded *) + +Goal forall (y:nat), + (Z.of_nat y + 1)%Z = Z.of_nat (y + 1). +Proof. + tify Z. + change ((Z.of_nat y + 1)%Z = (Z.of_nat y + 1)%Z). + reflexivity. +Qed. + +Goal forall (y:nat), + (Z.of_nat y + 1)%Z = Z.of_nat (y + 1). +Proof. + tify R. (* This is no known way to map to R, default to Z *) + change ((Z.of_nat y + 1)%Z = (Z.of_nat y + 1)%Z). + reflexivity. +Qed. + +(* Define instances for R *) +Lemma inj_IZR_iff : forall n m, n = m <-> (IZR n = IZR m)%R. +Proof. + split. + apply f_equal. + apply eq_IZR. +Qed. + +(* For the test, we lose the information that Z is discrete *) +#[global] +Instance Inj_Z_R : InjTyp Z R := + mkinj _ _ IZR (fun x => True) (fun _ => I). +Add Tify InjTyp Inj_Z_R. + +#[global] +Instance Inj_nat_R : InjTyp nat R := + mkinj _ _ INR (fun x => 0 <= x)%R pos_INR. +Add Tify InjTyp Inj_nat_R. + +#[global] +Instance Inj_R_R : InjTyp R R := + mkinj _ _ (fun x=> x) (fun x => True) (fun _ => I). +Add Tify InjTyp Inj_R_R. + +#[global] +Instance Op_eq_Z_R : BinRel (T:=R) (@eq Z) := + { TR := @eq R ; TRInj := inj_IZR_iff }. +Add Tify BinRel Op_eq_Z_R. + +#[global] +Instance Op_plus_R : BinOp Z.add := + { TBOp := Rplus; TBOpInj := plus_IZR }. +Add Tify BinOp Op_plus_R. + +#[global] +Instance Op_plus_nat_R : BinOp Nat.add := + { TBOp := Rplus; TBOpInj := plus_INR }. +Add Tify BinOp Op_plus_nat_R. + +#[global] +Instance Op_Z_of_nat_R : UnOp (T1:= R) (T2:=R) Z.of_nat:= + { TUOp x := x ; TUOpInj x := eq_sym (INR_IZR_INZ x) }. +Add Tify UnOp Op_Z_of_nat_R. + +#[global] +Instance Op_S_R : UnOp (T1:= R) (T2:=R) S := + { TUOp := (fun x => Rplus x 1) ; TUOpInj := S_INR }. +Add Tify UnOp Op_S_R. + +#[global] +Instance Op_O : CstOp (T:= R) O:= + { TCst := 0%R ; TCstInj := INR_0 }. +Add Tify CstOp Op_O. + +Goal forall (y:nat), + (Z.of_nat y + 1)%Z = Z.of_nat (y + 1). +Proof. + intros. + Fail lra. (* Does not reason over Z *) + Fail (tify Z; change ((INR y + 1)%R = (INR y + R1)%R)). + tify R. + change ((INR y + 1)%R = (INR y + R1)%R). + lra. +Qed. diff --git a/theories/Strings/PString.v b/theories/Strings/PString.v index 73f8e3d5b3..34bbb1de48 100644 --- a/theories/Strings/PString.v +++ b/theories/Strings/PString.v @@ -14,7 +14,7 @@ From Stdlib Require Import ZArith. #[local] Instance Op_max_length : ZifyClasses.CstOp max_length := { TCst := 16777211%Z ; TCstInj := eq_refl }. -Add Zify CstOp Op_max_length. +Add Tify CstOp Op_max_length. #[local] Ltac case_if := lazymatch goal with diff --git a/theories/dune b/theories/dune index c15615087c..3f3e31397d 100644 --- a/theories/dune +++ b/theories/dune @@ -1,7 +1,8 @@ (include_subdirs qualified) (coq.theory (name Stdlib) - (package rocq-stdlib)) + (package rocq-stdlib) + (theories micromega_plugin)) (env (dev diff --git a/theories/micromega/SatDivMod.v b/theories/micromega/SatDivMod.v index 871527d9be..4fbe7f6968 100644 --- a/theories/micromega/SatDivMod.v +++ b/theories/micromega/SatDivMod.v @@ -29,7 +29,7 @@ Instance SatDiv : Saturate Z.div := PRes := fun _ _ r => 0 <= r; SatOk := Z_div_nonneg_nonneg |}. -Add Zify Saturate SatDiv. +Add Tify Saturate SatDiv. #[global] Instance SatMod : Saturate Z.modulo := @@ -39,4 +39,4 @@ Instance SatMod : Saturate Z.modulo := PRes := fun _ _ r => 0 <= r; SatOk := Z_mod_nonneg_nonneg |}. -Add Zify Saturate SatMod. +Add Tify Saturate SatMod. diff --git a/theories/micromega/Tify.v b/theories/micromega/Tify.v new file mode 100644 index 0000000000..7750902644 --- /dev/null +++ b/theories/micromega/Tify.v @@ -0,0 +1,17 @@ +(************************************************************************) +(* * The Rocq Prover / The Rocq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* proj2 IFF H). Qed. - +#[global] Set Warnings "-zify". (** Registering constants for use by the plugin *) Register eq_iff as ZifyClasses.eq_iff. diff --git a/theories/micromega/ZifyComparison.v b/theories/micromega/ZifyComparison.v index 8b360fe25d..b5d32f97cb 100644 --- a/theories/micromega/ZifyComparison.v +++ b/theories/micromega/ZifyComparison.v @@ -10,7 +10,6 @@ From Stdlib Require Import Bool BinInt. From Stdlib Require Import Zify ZifyClasses. -From Stdlib Require Import Lia. #[local] Open Scope Z_scope. (** [Z_of_comparison] is the injection function for comparison *) @@ -29,7 +28,7 @@ Qed. #[global] Instance Inj_comparison_Z : InjTyp comparison Z := { inj := Z_of_comparison ; pred :=(fun x => -1 <= x <= 1) ; cstr := Z_of_comparison_bound}. -Add Zify InjTyp Inj_comparison_Z. +Add Tify InjTyp Inj_comparison_Z. Definition ZcompareZ (x y : Z) := Z_of_comparison (Z.compare x y). @@ -37,27 +36,27 @@ Definition ZcompareZ (x y : Z) := #[global] Program Instance BinOp_Zcompare : BinOp Z.compare := { TBOp := ZcompareZ }. -Add Zify BinOp BinOp_Zcompare. +Add Tify BinOp BinOp_Zcompare. #[global] Instance Op_eq_comparison : BinRel (@eq comparison) := {TR := @eq Z ; TRInj := ltac:(intros [] []; simpl ; intuition congruence) }. -Add Zify BinRel Op_eq_comparison. +Add Tify BinRel Op_eq_comparison. #[global] Instance Op_Eq : CstOp Eq := { TCst := 0 ; TCstInj := eq_refl }. -Add Zify CstOp Op_Eq. +Add Tify CstOp Op_Eq. #[global] Instance Op_Lt : CstOp Lt := { TCst := -1 ; TCstInj := eq_refl }. -Add Zify CstOp Op_Lt. +Add Tify CstOp Op_Lt. #[global] Instance Op_Gt : CstOp Gt := { TCst := 1 ; TCstInj := eq_refl }. -Add Zify CstOp Op_Gt. +Add Tify CstOp Op_Gt. Lemma Zcompare_spec : forall x y, @@ -71,11 +70,18 @@ Proof. intros. destruct (x ?= y) eqn:C; simpl. - rewrite Z.compare_eq_iff in C. - lia. + subst. rewrite Z.gt_lt_iff. + specialize (Z.lt_irrefl y). + tauto. - rewrite Z.compare_lt_iff in C. - lia. + rewrite Z.gt_lt_iff. + generalize (Z.lt_neq _ _ C). + generalize (Z.lt_asymm _ _ C). + tauto. - rewrite Z.compare_gt_iff in C. - lia. + generalize (not_eq_sym (Z.lt_neq _ _ C)). + generalize (Z.lt_asymm _ _ C). + tauto. Qed. #[global] @@ -86,4 +92,4 @@ Instance ZcompareSpec : BinOpSpec ZcompareZ := /\ (x < y -> r = -1) ; BSpec := Zcompare_spec|}. -Add Zify BinOpSpec ZcompareSpec. +Add Tify BinOpSpec ZcompareSpec. diff --git a/theories/micromega/ZifyInst.v b/theories/micromega/ZifyInst.v index af523af3ac..4bab384ab7 100644 --- a/theories/micromega/ZifyInst.v +++ b/theories/micromega/ZifyInst.v @@ -14,7 +14,7 @@ From Stdlib Require Import BinInt BinNat Znat Nnat. From Stdlib Require Import ZifyClasses. -From micromega_plugin Require Zify. +From micromega_plugin Require Tify. #[local] Open Scope Z_scope. Ltac refl := @@ -26,154 +26,154 @@ Ltac refl := #[global] Instance Inj_Z_Z : InjTyp Z Z := mkinj _ _ (fun x => x) (fun x => True ) (fun _ => I). -Add Zify InjTyp Inj_Z_Z. +Add Tify InjTyp Inj_Z_Z. (** Support for nat *) #[global] Instance Inj_nat_Z : InjTyp nat Z := mkinj _ _ Z.of_nat (fun x => 0 <= x ) Nat2Z.is_nonneg. -Add Zify InjTyp Inj_nat_Z. +Add Tify InjTyp Inj_nat_Z. (* zify_nat_rel *) #[global] Instance Op_ge : BinRel ge := { TR := Z.ge; TRInj := Nat2Z.inj_ge }. -Add Zify BinRel Op_ge. +Add Tify BinRel Op_ge. #[global] Instance Op_lt : BinRel lt := { TR := Z.lt; TRInj := Nat2Z.inj_lt }. -Add Zify BinRel Op_lt. +Add Tify BinRel Op_lt. #[global] Instance Op_Nat_lt : BinRel Nat.lt := Op_lt. -Add Zify BinRel Op_Nat_lt. +Add Tify BinRel Op_Nat_lt. #[global] Instance Op_gt : BinRel gt := { TR := Z.gt; TRInj := Nat2Z.inj_gt }. -Add Zify BinRel Op_gt. +Add Tify BinRel Op_gt. #[global] Instance Op_le : BinRel le := { TR := Z.le; TRInj := Nat2Z.inj_le }. -Add Zify BinRel Op_le. +Add Tify BinRel Op_le. #[global] Instance Op_Nat_le : BinRel Nat.le := Op_le. -Add Zify BinRel Op_Nat_le. +Add Tify BinRel Op_Nat_le. #[global] Instance Op_eq_nat : BinRel (@eq nat) := { TR := @eq Z ; TRInj x y := iff_sym (Nat2Z.inj_iff x y) }. -Add Zify BinRel Op_eq_nat. +Add Tify BinRel Op_eq_nat. #[global] Instance Op_Nat_eq : BinRel (Nat.eq) := Op_eq_nat. -Add Zify BinRel Op_Nat_eq. +Add Tify BinRel Op_Nat_eq. (* zify_nat_op *) #[global] Instance Op_plus : BinOp Nat.add := { TBOp := Z.add; TBOpInj := Nat2Z.inj_add }. -Add Zify BinOp Op_plus. +Add Tify BinOp Op_plus. #[global] Instance Op_sub : BinOp Nat.sub := { TBOp n m := Z.max 0 (n - m) ; TBOpInj := Nat2Z.inj_sub_max }. -Add Zify BinOp Op_sub. +Add Tify BinOp Op_sub. #[global] Instance Op_mul : BinOp Nat.mul := { TBOp := Z.mul ; TBOpInj := Nat2Z.inj_mul }. -Add Zify BinOp Op_mul. +Add Tify BinOp Op_mul. #[global] Instance Op_min : BinOp Nat.min := { TBOp := Z.min ; TBOpInj := Nat2Z.inj_min }. -Add Zify BinOp Op_min. +Add Tify BinOp Op_min. #[global] Instance Op_max : BinOp Nat.max := { TBOp := Z.max ; TBOpInj := Nat2Z.inj_max }. -Add Zify BinOp Op_max. +Add Tify BinOp Op_max. #[global] Instance Op_pred : UnOp Nat.pred := { TUOp n := Z.max 0 (n - 1) ; TUOpInj := Nat2Z.inj_pred_max }. -Add Zify UnOp Op_pred. +Add Tify UnOp Op_pred. #[global] Instance Op_S : UnOp S := { TUOp x := Z.add x 1 ; TUOpInj := Nat2Z.inj_succ }. -Add Zify UnOp Op_S. +Add Tify UnOp Op_S. #[global] Instance Op_O : CstOp O := { TCst := Z0 ; TCstInj := eq_refl (Z.of_nat 0) }. -Add Zify CstOp Op_O. +Add Tify CstOp Op_O. #[global] Instance Op_Z_abs_nat : UnOp Z.abs_nat := { TUOp := Z.abs ; TUOpInj := Zabs2Nat.id_abs }. -Add Zify UnOp Op_Z_abs_nat. +Add Tify UnOp Op_Z_abs_nat. #[global] Instance Op_nat_div2 : UnOp Nat.div2 := { TUOp x := x / 2 ; TUOpInj x := ltac:(now rewrite Nat2Z.inj_div2, Z.div2_div) }. -Add Zify UnOp Op_nat_div2. +Add Tify UnOp Op_nat_div2. #[global] Instance Op_nat_double : UnOp Nat.double := {| TUOp := Z.mul 2 ; TUOpInj := Nat2Z.inj_double |}. -Add Zify UnOp Op_nat_double. +Add Tify UnOp Op_nat_double. (** Support for positive *) #[global] Instance Inj_pos_Z : InjTyp positive Z := { inj := Zpos ; pred x := 0 < x ; cstr := Pos2Z.pos_is_pos }. -Add Zify InjTyp Inj_pos_Z. +Add Tify InjTyp Inj_pos_Z. #[global] Instance Op_pos_to_nat : UnOp Pos.to_nat := {TUOp x := x ; TUOpInj := positive_nat_Z}. -Add Zify UnOp Op_pos_to_nat. +Add Tify UnOp Op_pos_to_nat. #[global] Instance Inj_N_Z : InjTyp N Z := mkinj _ _ Z.of_N (fun x => 0 <= x ) N2Z.is_nonneg. -Add Zify InjTyp Inj_N_Z. +Add Tify InjTyp Inj_N_Z. #[global] Instance Op_N_to_nat : UnOp N.to_nat := { TUOp x := x ; TUOpInj := N_nat_Z }. -Add Zify UnOp Op_N_to_nat. +Add Tify UnOp Op_N_to_nat. (* zify_positive_rel *) #[global] Instance Op_pos_ge : BinRel Pos.ge := { TR := Z.ge; TRInj x y := iff_refl (Z.pos x >= Z.pos y) }. -Add Zify BinRel Op_pos_ge. +Add Tify BinRel Op_pos_ge. #[global] Instance Op_pos_lt : BinRel Pos.lt := { TR := Z.lt; TRInj x y := iff_refl (Z.pos x < Z.pos y) }. -Add Zify BinRel Op_pos_lt. +Add Tify BinRel Op_pos_lt. #[global] Instance Op_pos_gt : BinRel Pos.gt := { TR := Z.gt; TRInj x y := iff_refl (Z.pos x > Z.pos y) }. -Add Zify BinRel Op_pos_gt. +Add Tify BinRel Op_pos_gt. #[global] Instance Op_pos_le : BinRel Pos.le := { TR := Z.le; TRInj x y := iff_refl (Z.pos x <= Z.pos y) }. -Add Zify BinRel Op_pos_le. +Add Tify BinRel Op_pos_le. Lemma eq_pos_inj x y : x = y <-> Z.pos x = Z.pos y. Proof. @@ -183,265 +183,265 @@ Qed. #[global] Instance Op_eq_pos : BinRel (@eq positive) := { TR := @eq Z ; TRInj := eq_pos_inj }. -Add Zify BinRel Op_eq_pos. +Add Tify BinRel Op_eq_pos. (* zify_positive_op *) #[global] Instance Op_Z_of_N : UnOp Z.of_N := { TUOp x := x ; TUOpInj x := eq_refl (Z.of_N x) }. -Add Zify UnOp Op_Z_of_N. +Add Tify UnOp Op_Z_of_N. #[global] Instance Op_Z_to_N : UnOp Z.to_N := { TUOp x := Z.max 0 x ; TUOpInj x := ltac:(now destruct x) }. -Add Zify UnOp Op_Z_to_N. +Add Tify UnOp Op_Z_to_N. #[global] Instance Op_Z_neg : UnOp Z.neg := { TUOp := Z.opp ; TUOpInj x := eq_refl (Zneg x) }. -Add Zify UnOp Op_Z_neg. +Add Tify UnOp Op_Z_neg. #[global] Instance Op_Z_pos : UnOp Z.pos := { TUOp x := x ; TUOpInj x := eq_refl (Z.pos x) }. -Add Zify UnOp Op_Z_pos. +Add Tify UnOp Op_Z_pos. #[global] Instance Op_pos_succ : UnOp Pos.succ := { TUOp x := x + 1 ; TUOpInj := Pos2Z.inj_succ }. -Add Zify UnOp Op_pos_succ. +Add Tify UnOp Op_pos_succ. #[global] Instance Op_pos_pred_double : UnOp Pos.pred_double := { TUOp x := 2 * x - 1 ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_pos_pred_double. +Add Tify UnOp Op_pos_pred_double. #[global] Instance Op_pos_pred : UnOp Pos.pred := { TUOp x := Z.max 1 (x - 1) ; TUOpInj x := ltac:(rewrite <- Pos.sub_1_r; apply Pos2Z.inj_sub_max) }. -Add Zify UnOp Op_pos_pred. +Add Tify UnOp Op_pos_pred. #[global] Instance Op_pos_predN : UnOp Pos.pred_N := { TUOp x := x - 1 ; TUOpInj x := ltac: (now destruct x; rewrite N.pos_pred_spec) }. -Add Zify UnOp Op_pos_predN. +Add Tify UnOp Op_pos_predN. #[global] Instance Op_pos_of_succ_nat : UnOp Pos.of_succ_nat := { TUOp x := x + 1 ; TUOpInj := Zpos_P_of_succ_nat }. -Add Zify UnOp Op_pos_of_succ_nat. +Add Tify UnOp Op_pos_of_succ_nat. #[global] Instance Op_pos_of_nat : UnOp Pos.of_nat := { TUOp x := Z.max 1 x ; TUOpInj x := ltac: (now destruct x; [|rewrite <- Pos.of_nat_succ, <- (Nat2Z.inj_max 1)]) }. -Add Zify UnOp Op_pos_of_nat. +Add Tify UnOp Op_pos_of_nat. #[global] Instance Op_pos_add : BinOp Pos.add := { TBOp := Z.add ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_pos_add. +Add Tify BinOp Op_pos_add. #[global] Instance Op_pos_add_carry : BinOp Pos.add_carry := { TBOp x y := x + y + 1 ; TBOpInj := ltac:(now intros; rewrite Pos.add_carry_spec, Pos2Z.inj_succ) }. -Add Zify BinOp Op_pos_add_carry. +Add Tify BinOp Op_pos_add_carry. #[global] Instance Op_pos_sub : BinOp Pos.sub := { TBOp n m := Z.max 1 (n - m) ; TBOpInj := Pos2Z.inj_sub_max }. -Add Zify BinOp Op_pos_sub. +Add Tify BinOp Op_pos_sub. #[global] Instance Op_pos_mul : BinOp Pos.mul := { TBOp := Z.mul ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_pos_mul. +Add Tify BinOp Op_pos_mul. #[global] Instance Op_pos_min : BinOp Pos.min := { TBOp := Z.min ; TBOpInj := Pos2Z.inj_min }. -Add Zify BinOp Op_pos_min. +Add Tify BinOp Op_pos_min. #[global] Instance Op_pos_max : BinOp Pos.max := { TBOp := Z.max ; TBOpInj := Pos2Z.inj_max }. -Add Zify BinOp Op_pos_max. +Add Tify BinOp Op_pos_max. #[global] Instance Op_pos_pow : BinOp Pos.pow := { TBOp := Z.pow ; TBOpInj := Pos2Z.inj_pow }. -Add Zify BinOp Op_pos_pow. +Add Tify BinOp Op_pos_pow. #[global] Instance Op_pos_square : UnOp Pos.square := { TUOp := Z.square ; TUOpInj := Pos2Z.inj_square }. -Add Zify UnOp Op_pos_square. +Add Tify UnOp Op_pos_square. #[global] Instance Op_Pos_Nsucc_double : UnOp Pos.Nsucc_double := { TUOp x := 2 * x + 1 ; TUOpInj x := ltac:(now destruct x) }. -Add Zify UnOp Op_Pos_Nsucc_double. +Add Tify UnOp Op_Pos_Nsucc_double. #[global] Instance Op_Pos_Ndouble : UnOp Pos.Ndouble := { TUOp x := 2 * x ; TUOpInj x := ltac:(now destruct x) }. -Add Zify UnOp Op_Pos_Ndouble. +Add Tify UnOp Op_Pos_Ndouble. #[global] Instance Op_xO : UnOp xO := { TUOp x := 2 * x ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_xO. +Add Tify UnOp Op_xO. #[global] Instance Op_xI : UnOp xI := { TUOp x := 2 * x + 1 ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_xI. +Add Tify UnOp Op_xI. #[global] Instance Op_xH : CstOp xH := { TCst := 1%Z ; TCstInj := eq_refl }. -Add Zify CstOp Op_xH. +Add Tify CstOp Op_xH. #[global] Instance Op_Z_of_nat : UnOp Z.of_nat:= { TUOp x := x ; TUOpInj x := eq_refl (Z.of_nat x) }. -Add Zify UnOp Op_Z_of_nat. +Add Tify UnOp Op_Z_of_nat. (* zify_N_rel *) #[global] Instance Op_N_ge : BinRel N.ge := { TR := Z.ge ; TRInj := N2Z.inj_ge }. -Add Zify BinRel Op_N_ge. +Add Tify BinRel Op_N_ge. #[global] Instance Op_N_lt : BinRel N.lt := { TR := Z.lt ; TRInj := N2Z.inj_lt }. -Add Zify BinRel Op_N_lt. +Add Tify BinRel Op_N_lt. #[global] Instance Op_N_gt : BinRel N.gt := { TR := Z.gt ; TRInj := N2Z.inj_gt }. -Add Zify BinRel Op_N_gt. +Add Tify BinRel Op_N_gt. #[global] Instance Op_N_le : BinRel N.le := { TR := Z.le ; TRInj := N2Z.inj_le }. -Add Zify BinRel Op_N_le. +Add Tify BinRel Op_N_le. #[global] Instance Op_eq_N : BinRel (@eq N) := { TR := @eq Z ; TRInj x y := iff_sym (N2Z.inj_iff x y) }. -Add Zify BinRel Op_eq_N. +Add Tify BinRel Op_eq_N. (* zify_N_op *) #[global] Instance Op_N_N0 : CstOp N0 := { TCst := Z0 ; TCstInj := eq_refl }. -Add Zify CstOp Op_N_N0. +Add Tify CstOp Op_N_N0. #[global] Instance Op_N_Npos : UnOp Npos := { TUOp x := x ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_N_Npos. +Add Tify UnOp Op_N_Npos. #[global] Instance Op_N_of_nat : UnOp N.of_nat := { TUOp x := x ; TUOpInj := nat_N_Z }. -Add Zify UnOp Op_N_of_nat. +Add Tify UnOp Op_N_of_nat. #[global] Instance Op_Z_abs_N : UnOp Z.abs_N := { TUOp := Z.abs ; TUOpInj := N2Z.inj_abs_N }. -Add Zify UnOp Op_Z_abs_N. +Add Tify UnOp Op_Z_abs_N. #[global] Instance Op_N_pos : UnOp N.pos := { TUOp x := x ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_N_pos. +Add Tify UnOp Op_N_pos. #[global] Instance Op_N_add : BinOp N.add := { TBOp := Z.add ; TBOpInj := N2Z.inj_add }. -Add Zify BinOp Op_N_add. +Add Tify BinOp Op_N_add. #[global] Instance Op_N_min : BinOp N.min := { TBOp := Z.min ; TBOpInj := N2Z.inj_min }. -Add Zify BinOp Op_N_min. +Add Tify BinOp Op_N_min. #[global] Instance Op_N_max : BinOp N.max := { TBOp := Z.max ; TBOpInj := N2Z.inj_max }. -Add Zify BinOp Op_N_max. +Add Tify BinOp Op_N_max. #[global] Instance Op_N_mul : BinOp N.mul := { TBOp := Z.mul ; TBOpInj := N2Z.inj_mul }. -Add Zify BinOp Op_N_mul. +Add Tify BinOp Op_N_mul. #[global] Instance Op_N_sub : BinOp N.sub := { TBOp x y := Z.max 0 (x - y) ; TBOpInj := N2Z.inj_sub_max }. -Add Zify BinOp Op_N_sub. +Add Tify BinOp Op_N_sub. #[global] Instance Op_N_div : BinOp N.div := { TBOp := Z.div ; TBOpInj := N2Z.inj_div }. -Add Zify BinOp Op_N_div. +Add Tify BinOp Op_N_div. #[global] Instance Op_N_mod : BinOp N.modulo := { TBOp := Z.rem ; TBOpInj := N2Z.inj_rem }. -Add Zify BinOp Op_N_mod. +Add Tify BinOp Op_N_mod. #[global] Instance Op_N_pred : UnOp N.pred := { TUOp x := Z.max 0 (x - 1) ; TUOpInj x := ltac:(rewrite N.pred_sub; apply N2Z.inj_sub_max) }. -Add Zify UnOp Op_N_pred. +Add Tify UnOp Op_N_pred. #[global] Instance Op_N_succ : UnOp N.succ := { TUOp x := x + 1 ; TUOpInj := N2Z.inj_succ }. -Add Zify UnOp Op_N_succ. +Add Tify UnOp Op_N_succ. #[global] Instance Op_N_succ_double : UnOp N.succ_double := { TUOp x := 2 * x + 1 ; TUOpInj x := ltac:(now destruct x) }. -Add Zify UnOp Op_N_succ_double. +Add Tify UnOp Op_N_succ_double. #[global] Instance Op_N_double : UnOp N.double := { TUOp x := 2 * x ; TUOpInj x := ltac:(now destruct x) }. -Add Zify UnOp Op_N_double. +Add Tify UnOp Op_N_double. #[global] Instance Op_N_succ_pos : UnOp N.succ_pos := { TUOp x := x + 1 ; TUOpInj x := ltac:(now destruct x; simpl; [| rewrite Pplus_one_succ_r]) }. -Add Zify UnOp Op_N_succ_pos. +Add Tify UnOp Op_N_succ_pos. #[global] Instance Op_N_div2 : UnOp N.div2 := { TUOp x := x / 2 ; TUOpInj x := ltac:(now rewrite N2Z.inj_div2, Z.div2_div) }. -Add Zify UnOp Op_N_div2. +Add Tify UnOp Op_N_div2. #[global] Instance Op_N_pow : BinOp N.pow := { TBOp := Z.pow ; TBOpInj := N2Z.inj_pow }. -Add Zify BinOp Op_N_pow. +Add Tify BinOp Op_N_pow. #[global] Instance Op_N_square : UnOp N.square := { TUOp x := x * x ; TUOpInj x := ltac:(now rewrite N.square_spec, N2Z.inj_mul) }. -Add Zify UnOp Op_N_square. +Add Tify UnOp Op_N_square. (** Support for Z - injected to itself *) @@ -449,137 +449,137 @@ Add Zify UnOp Op_N_square. #[global] Instance Op_Z_ge : BinRel Z.ge := { TR := Z.ge ; TRInj x y := iff_refl (x>= y) }. -Add Zify BinRel Op_Z_ge. +Add Tify BinRel Op_Z_ge. #[global] Instance Op_Z_lt : BinRel Z.lt := { TR := Z.lt ; TRInj x y := iff_refl (x < y) }. -Add Zify BinRel Op_Z_lt. +Add Tify BinRel Op_Z_lt. #[global] Instance Op_Z_gt : BinRel Z.gt := { TR := Z.gt ;TRInj x y := iff_refl (x > y) }. -Add Zify BinRel Op_Z_gt. +Add Tify BinRel Op_Z_gt. #[global] Instance Op_Z_le : BinRel Z.le := { TR := Z.le ;TRInj x y := iff_refl (x <= y) }. -Add Zify BinRel Op_Z_le. +Add Tify BinRel Op_Z_le. #[global] Instance Op_eqZ : BinRel (@eq Z) := { TR := @eq Z ; TRInj x y := iff_refl (x = y) }. -Add Zify BinRel Op_eqZ. +Add Tify BinRel Op_eqZ. #[global] Instance Op_Z_Z0 : CstOp Z0 := { TCst := Z0 ; TCstInj := eq_refl }. -Add Zify CstOp Op_Z_Z0. +Add Tify CstOp Op_Z_Z0. #[global] Instance Op_Z_add : BinOp Z.add := { TBOp := Z.add ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_add. +Add Tify BinOp Op_Z_add. #[global] Instance Op_Z_min : BinOp Z.min := { TBOp := Z.min ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_min. +Add Tify BinOp Op_Z_min. #[global] Instance Op_Z_max : BinOp Z.max := { TBOp := Z.max ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_max. +Add Tify BinOp Op_Z_max. #[global] Instance Op_Z_mul : BinOp Z.mul := { TBOp := Z.mul ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_mul. +Add Tify BinOp Op_Z_mul. #[global] Instance Op_Z_sub : BinOp Z.sub := { TBOp := Z.sub ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_sub. +Add Tify BinOp Op_Z_sub. #[global] Instance Op_Z_div : BinOp Z.div := { TBOp := Z.div ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_div. +Add Tify BinOp Op_Z_div. #[global] Instance Op_Z_mod : BinOp Z.modulo := { TBOp := Z.modulo ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_mod. +Add Tify BinOp Op_Z_mod. #[global] Instance Op_Z_rem : BinOp Z.rem := { TBOp := Z.rem ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_rem. +Add Tify BinOp Op_Z_rem. #[global] Instance Op_Z_quot : BinOp Z.quot := { TBOp := Z.quot ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_quot. +Add Tify BinOp Op_Z_quot. #[global] Instance Op_Z_succ : UnOp Z.succ := { TUOp x := x + 1 ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_Z_succ. +Add Tify UnOp Op_Z_succ. #[global] Instance Op_Z_pred : UnOp Z.pred := { TUOp x := x - 1 ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_Z_pred. +Add Tify UnOp Op_Z_pred. #[global] Instance Op_Z_opp : UnOp Z.opp := { TUOp := Z.opp ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_Z_opp. +Add Tify UnOp Op_Z_opp. #[global] Instance Op_Z_abs : UnOp Z.abs := { TUOp := Z.abs ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_Z_abs. +Add Tify UnOp Op_Z_abs. #[global] Instance Op_Z_sgn : UnOp Z.sgn := { TUOp := Z.sgn ; TUOpInj _ := eq_refl }. -Add Zify UnOp Op_Z_sgn. +Add Tify UnOp Op_Z_sgn. #[global] Instance Op_Z_pow : BinOp Z.pow := { TBOp := Z.pow ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_pow. +Add Tify BinOp Op_Z_pow. #[global] Instance Op_Z_pow_pos : BinOp Z.pow_pos := { TBOp := Z.pow ; TBOpInj _ _ := eq_refl }. -Add Zify BinOp Op_Z_pow_pos. +Add Tify BinOp Op_Z_pow_pos. #[global] Instance Op_Z_double : UnOp Z.double := { TUOp := Z.mul 2 ; TUOpInj := Z.double_spec }. -Add Zify UnOp Op_Z_double. +Add Tify UnOp Op_Z_double. #[global] Instance Op_Z_pred_double : UnOp Z.pred_double := { TUOp x := 2 * x - 1 ; TUOpInj := Z.pred_double_spec }. -Add Zify UnOp Op_Z_pred_double. +Add Tify UnOp Op_Z_pred_double. #[global] Instance Op_Z_succ_double : UnOp Z.succ_double := { TUOp x := 2 * x + 1 ; TUOpInj := Z.succ_double_spec }. -Add Zify UnOp Op_Z_succ_double. +Add Tify UnOp Op_Z_succ_double. #[global] Instance Op_Z_square : UnOp Z.square := { TUOp x := x * x ; TUOpInj := Z.square_spec }. -Add Zify UnOp Op_Z_square. +Add Tify UnOp Op_Z_square. #[global] Instance Op_Z_div2 : UnOp Z.div2 := { TUOp x := x / 2 ; TUOpInj := Z.div2_div }. -Add Zify UnOp Op_Z_div2. +Add Tify UnOp Op_Z_div2. Local Lemma Zquot2_quot n : Z.quot2 n = n ÷ 2. Proof. @@ -590,7 +590,7 @@ Qed. #[global] Instance Op_Z_quot2 : UnOp Z.quot2 := { TUOp x := Z.quot x 2 ; TUOpInj := Zquot2_quot }. -Add Zify UnOp Op_Z_quot2. +Add Tify UnOp Op_Z_quot2. Lemma of_nat_to_nat_eq x : Z.of_nat (Z.to_nat x) = Z.max 0 x. Proof. @@ -603,37 +603,37 @@ Qed. #[global] Instance Op_Z_to_nat : UnOp Z.to_nat := { TUOp x := Z.max 0 x ; TUOpInj := of_nat_to_nat_eq }. -Add Zify UnOp Op_Z_to_nat. +Add Tify UnOp Op_Z_to_nat. #[global] Instance Op_Z_to_pos : UnOp Z.to_pos := { TUOp x := Z.max 1 x ; TUOpInj x := ltac:(now simpl; destruct x; [| rewrite <- Pos2Z.inj_max; rewrite Pos.max_1_l |]) }. -Add Zify UnOp Op_Z_to_pos. +Add Tify UnOp Op_Z_to_pos. (** Specification of derived operators over Z *) #[global] Instance ZmaxSpec : BinOpSpec Z.max := { BPred n m r := n < m /\ r = m \/ m <= n /\ r = n ; BSpec := Z.max_spec }. -Add Zify BinOpSpec ZmaxSpec. +Add Tify BinOpSpec ZmaxSpec. #[global] Instance ZminSpec : BinOpSpec Z.min := { BPred n m r := n < m /\ r = n \/ m <= n /\ r = m ; BSpec := Z.min_spec }. -Add Zify BinOpSpec ZminSpec. +Add Tify BinOpSpec ZminSpec. #[global] Instance ZsgnSpec : UnOpSpec Z.sgn := { UPred n r := 0 < n /\ r = 1 \/ 0 = n /\ r = 0 \/ n < 0 /\ r = - 1 ; USpec := Z.sgn_spec }. -Add Zify UnOpSpec ZsgnSpec. +Add Tify UnOpSpec ZsgnSpec. #[global] Instance ZabsSpec : UnOpSpec Z.abs := { UPred n r := 0 <= n /\ r = n \/ n < 0 /\ r = - n ; USpec := Z.abs_spec }. -Add Zify UnOpSpec ZabsSpec. +Add Tify UnOpSpec ZabsSpec. (** Saturate positivity constraints *) @@ -643,7 +643,7 @@ Instance SatPowPos : Saturate Z.pow := PArg2 y := 0 <= y; PRes _ _ r := 0 < r; SatOk := fun x y => Z.pow_pos_nonneg x y}. -Add Zify Saturate SatPowPos. +Add Tify Saturate SatPowPos. #[global] Instance SatPowNonneg : Saturate Z.pow := @@ -651,6 +651,6 @@ Instance SatPowNonneg : Saturate Z.pow := PArg2 y := True; PRes _ _ r := 0 <= r; SatOk a b Ha _ := @Z.pow_nonneg a b Ha }. -Add Zify Saturate SatPowNonneg. +Add Tify Saturate SatPowNonneg. (* TODO #14736 for compatibility only, should be removed after deprecation *) diff --git a/theories/micromega/ZifyN.v b/theories/micromega/ZifyN.v index 6b22d6882f..3bcae6c7f6 100644 --- a/theories/micromega/ZifyN.v +++ b/theories/micromega/ZifyN.v @@ -23,17 +23,17 @@ Existing Instance Inj_N_Z. #[global] Instance Op_N_div : BinOp N.div := {| TBOp := Z.div ; TBOpInj := N2Z.inj_div |}. -Add Zify BinOp Op_N_div. +Add Tify BinOp Op_N_div. #[global] Instance Op_N_mod : BinOp N.modulo := {| TBOp := Z.rem ; TBOpInj := N2Z.inj_rem |}. -Add Zify BinOp Op_N_mod. +Add Tify BinOp Op_N_mod. #[global] Instance Op_N_pow : BinOp N.pow := {| TBOp := Z.pow ; TBOpInj := N2Z.inj_pow|}. -Add Zify BinOp Op_N_pow. +Add Tify BinOp Op_N_pow. #[local] Open Scope Z_scope. @@ -64,7 +64,7 @@ Instance SatDiv : Saturate Z.div := PRes := fun _ _ r => 0 <= r; SatOk := Z_div_nonneg_nonneg |}. -Add Zify Saturate SatDiv. +Add Tify Saturate SatDiv. #[global] Instance SatMod : Saturate Z.modulo := @@ -74,4 +74,4 @@ Instance SatMod : Saturate Z.modulo := PRes := fun _ _ r => 0 <= r; SatOk := Z_mod_nonneg_nonneg |}. -Add Zify Saturate SatMod. +Add Tify Saturate SatMod. diff --git a/theories/micromega/ZifyNat.v b/theories/micromega/ZifyNat.v index ea752a3ab4..130a367158 100644 --- a/theories/micromega/ZifyNat.v +++ b/theories/micromega/ZifyNat.v @@ -23,14 +23,14 @@ Existing Instance Inj_nat_Z. #[global] Instance Op_mod : BinOp Nat.modulo := {| TBOp := Z.modulo ; TBOpInj := Nat2Z.inj_mod |}. -Add Zify BinOp Op_mod. +Add Tify BinOp Op_mod. #[global] Instance Op_div : BinOp Nat.div := {| TBOp := Z.div ; TBOpInj := Nat2Z.inj_div |}. -Add Zify BinOp Op_div. +Add Tify BinOp Op_div. #[global] Instance Op_pow : BinOp Nat.pow := {| TBOp := Z.pow ; TBOpInj := Nat2Z.inj_pow |}. -Add Zify BinOp Op_pow. +Add Tify BinOp Op_pow. diff --git a/theories/micromega/ZifySint63.v b/theories/micromega/ZifySint63.v index 15a860a3fb..aa25fde6bb 100644 --- a/theories/micromega/ZifySint63.v +++ b/theories/micromega/ZifySint63.v @@ -11,32 +11,32 @@ Proof. now apply to_Z_bounded. Qed. Instance Inj_int_Z : InjTyp int Z := mkinj _ _ to_Z (fun x => -4611686018427387904 <= x <= 4611686018427387903)%Z to_Z_bounded. -Add Zify InjTyp Inj_int_Z. +Add Tify InjTyp Inj_int_Z. #[global] Instance Op_max_int : CstOp max_int := { TCst := 4611686018427387903 ; TCstInj := eq_refl }. -Add Zify CstOp Op_max_int. +Add Tify CstOp Op_max_int. #[global] Instance Op_min_int : CstOp min_int := { TCst := -4611686018427387904 ; TCstInj := eq_refl }. -Add Zify CstOp Op_min_int. +Add Tify CstOp Op_min_int. #[global] Instance Op_digits : CstOp digits := { TCst := 63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_digits. +Add Tify CstOp Op_digits. #[global] Instance Op_size : CstOp size := { TCst := 63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_size. +Add Tify CstOp Op_size. #[global] Instance Op_wB : CstOp wB := { TCst := 2^63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_wB. +Add Tify CstOp Op_wB. Lemma ltb_lt : forall n m, (n (to_Z n = to_Z m)%sint63. Proof. @@ -89,7 +89,7 @@ Qed. #[global] Instance Op_eq : BinRel (@eq int) := {| TR := @eq Z; TRInj := eq_int_inj |}. -Add Zify BinRel Op_eq. +Add Tify BinRel Op_eq. Notation cmodwB x := ((x + 4611686018427387904) mod 9223372036854775808 - 4611686018427387904)%Z. @@ -97,42 +97,42 @@ Notation cmodwB x := #[global] Instance Op_add : BinOp add := {| TBOp := fun x y => cmodwB (x + y); TBOpInj := add_spec |}%Z. -Add Zify BinOp Op_add. +Add Tify BinOp Op_add. #[global] Instance Op_sub : BinOp sub := {| TBOp := fun x y => cmodwB (x - y); TBOpInj := sub_spec |}%Z. -Add Zify BinOp Op_sub. +Add Tify BinOp Op_sub. #[global] Instance Op_opp : UnOp Uint63.opp := {| TUOp := fun x => cmodwB (- x); TUOpInj := (sub_spec 0) |}%Z. -Add Zify UnOp Op_opp. +Add Tify UnOp Op_opp. #[global] Instance Op_succ : UnOp succ := {| TUOp := fun x => cmodwB (x + 1); TUOpInj := succ_spec |}%Z. -Add Zify UnOp Op_succ. +Add Tify UnOp Op_succ. #[global] Instance Op_pred : UnOp Uint63.pred := {| TUOp := fun x => cmodwB (x - 1); TUOpInj := pred_spec |}%Z. -Add Zify UnOp Op_pred. +Add Tify UnOp Op_pred. #[global] Instance Op_mul : BinOp mul := {| TBOp := fun x y => cmodwB (x * y); TBOpInj := mul_spec |}%Z. -Add Zify BinOp Op_mul. +Add Tify BinOp Op_mul. #[global] Instance Op_mod : BinOp PrimInt63.mods := {| TBOp := Z.rem ; TBOpInj := mod_spec |}. -Add Zify BinOp Op_mod. +Add Tify BinOp Op_mod. #[global] Instance Op_asr : BinOp asr := {| TBOp := fun x y => x / 2^ y ; TBOpInj := asr_spec |}%Z. -Add Zify BinOp Op_asr. +Add Tify BinOp Op_asr. Definition quots (x d : Z) : Z := if ((x =? -4611686018427387904)%Z && (d =? -1)%Z)%bool then @@ -155,7 +155,7 @@ Qed. #[global] Instance Op_div : BinOp div := {| TBOp := quots ; TBOpInj := div_quots |}. -Add Zify BinOp Op_div. +Add Tify BinOp Op_div. Lemma quots_spec (x y : Z) : ((x = -4611686018427387904 /\ y = -1 /\ quots x y = -4611686018427387904) @@ -172,17 +172,17 @@ Instance quotsSpec : BinOpSpec quots := ((x = -4611686018427387904 /\ d = -1 /\ r = -4611686018427387904) \/ ((x <> -4611686018427387904 \/ d <> -1) /\ r = Z.quot x d))%Z; BSpec := quots_spec |}. -Add Zify BinOpSpec quotsSpec. +Add Tify BinOpSpec quotsSpec. #[global] Instance Op_of_Z : UnOp of_Z := { TUOp := fun x => cmodwB x; TUOpInj := of_Z_spec }. -Add Zify UnOp Op_of_Z. +Add Tify UnOp Op_of_Z. #[global] Instance Op_to_Z : UnOp to_Z := { TUOp := fun x => x ; TUOpInj := fun x : int => eq_refl }. -Add Zify UnOp Op_to_Z. +Add Tify UnOp Op_to_Z. Lemma is_zeroE : forall n : int, is_zero n = (to_Z n =? 0)%Z. Proof. @@ -195,11 +195,11 @@ Qed. #[global] Instance Op_is_zero : UnOp is_zero := { TUOp := (Z.eqb 0) ; TUOpInj := is_zeroE }. -Add Zify UnOp Op_is_zero. +Add Tify UnOp Op_is_zero. #[global] Instance Op_abs : UnOp abs := { TUOp := fun x => cmodwB (Z.abs x) ; TUOpInj := abs_spec }. -Add Zify UnOp Op_abs. +Add Tify UnOp Op_abs. Ltac Zify.zify_convert_to_euclidean_division_equations_flag ::= constr:(true). diff --git a/theories/micromega/ZifyUint63.v b/theories/micromega/ZifyUint63.v index 7deed6a801..5cd22cb92f 100644 --- a/theories/micromega/ZifyUint63.v +++ b/theories/micromega/ZifyUint63.v @@ -9,27 +9,27 @@ Proof. apply to_Z_bounded. Qed. #[global] Instance Inj_int_Z : InjTyp int Z := mkinj _ _ to_Z (fun x => 0 <= x < 9223372036854775808)%Z to_Z_bounded. -Add Zify InjTyp Inj_int_Z. +Add Tify InjTyp Inj_int_Z. #[global] Instance Op_max_int : CstOp max_int := { TCst := 9223372036854775807 ; TCstInj := eq_refl }. -Add Zify CstOp Op_max_int. +Add Tify CstOp Op_max_int. #[global] Instance Op_digits : CstOp digits := { TCst := 63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_digits. +Add Tify CstOp Op_digits. #[global] Instance Op_size : CstOp size := { TCst := 63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_size. +Add Tify CstOp Op_size. #[global] Instance Op_wB : CstOp wB := { TCst := 2^63 ; TCstInj := eq_refl }. -Add Zify CstOp Op_wB. +Add Tify CstOp Op_wB. Lemma ltb_lt : forall n m, (n (φ n = φ m)%uint63. Proof. @@ -82,112 +82,112 @@ Qed. #[global] Instance Op_eq : BinRel (@eq int) := {| TR := @eq Z; TRInj := eq_int_inj |}. -Add Zify BinRel Op_eq. +Add Tify BinRel Op_eq. #[global] Instance Op_add : BinOp add := {| TBOp := fun x y => (x + y) mod 9223372036854775808%Z; TBOpInj := add_spec |}%Z. -Add Zify BinOp Op_add. +Add Tify BinOp Op_add. #[global] Instance Op_sub : BinOp sub := {| TBOp := fun x y => (x - y) mod 9223372036854775808%Z; TBOpInj := sub_spec |}%Z. -Add Zify BinOp Op_sub. +Add Tify BinOp Op_sub. #[global] Instance Op_opp : UnOp Uint63.opp := {| TUOp := (fun x => (- x) mod 9223372036854775808)%Z; TUOpInj := (sub_spec 0) |}%Z. -Add Zify UnOp Op_opp. +Add Tify UnOp Op_opp. #[global] Instance Op_oppcarry : UnOp oppcarry := {| TUOp := (fun x => 2^63 - x - 1)%Z; TUOpInj := oppcarry_spec |}%Z. -Add Zify UnOp Op_oppcarry. +Add Tify UnOp Op_oppcarry. #[global] Instance Op_succ : UnOp succ := {| TUOp := (fun x => (x + 1) mod 2^63)%Z; TUOpInj := succ_spec |}%Z. -Add Zify UnOp Op_succ. +Add Tify UnOp Op_succ. #[global] Instance Op_pred : UnOp Uint63.pred := {| TUOp := (fun x => (x - 1) mod 2^63)%Z; TUOpInj := pred_spec |}%Z. -Add Zify UnOp Op_pred. +Add Tify UnOp Op_pred. #[global] Instance Op_mul : BinOp mul := {| TBOp := fun x y => (x * y) mod 9223372036854775808%Z; TBOpInj := mul_spec |}%Z. -Add Zify BinOp Op_mul. +Add Tify BinOp Op_mul. #[global] Instance Op_gcd : BinOp gcd:= {| TBOp := (fun x y => Zgcd_alt.Zgcdn (2 * 63)%nat y x) ; TBOpInj := to_Z_gcd |}. -Add Zify BinOp Op_gcd. +Add Tify BinOp Op_gcd. #[global] Instance Op_mod : BinOp Uint63.mod := {| TBOp := Z.modulo ; TBOpInj := mod_spec |}. -Add Zify BinOp Op_mod. +Add Tify BinOp Op_mod. #[global] Instance Op_subcarry : BinOp subcarry := {| TBOp := (fun x y => (x - y - 1) mod 2^63)%Z ; TBOpInj := subcarry_spec |}. -Add Zify BinOp Op_subcarry. +Add Tify BinOp Op_subcarry. #[global] Instance Op_addcarry : BinOp addcarry := {| TBOp := (fun x y => (x + y + 1) mod 2^63)%Z ; TBOpInj := addcarry_spec |}. -Add Zify BinOp Op_addcarry. +Add Tify BinOp Op_addcarry. #[global] Instance Op_lsr : BinOp lsr := {| TBOp := (fun x y => x / 2^ y)%Z ; TBOpInj := lsr_spec |}. -Add Zify BinOp Op_lsr. +Add Tify BinOp Op_lsr. #[global] Instance Op_lsl : BinOp lsl := {| TBOp := (fun x y => (x * 2^ y) mod 2^ 63)%Z ; TBOpInj := lsl_spec |}. -Add Zify BinOp Op_lsl. +Add Tify BinOp Op_lsl. #[global] Instance Op_lor : BinOp Uint63.lor := {| TBOp := Z.lor ; TBOpInj := lor_spec' |}. -Add Zify BinOp Op_lor. +Add Tify BinOp Op_lor. #[global] Instance Op_land : BinOp Uint63.land := {| TBOp := Z.land ; TBOpInj := land_spec' |}. -Add Zify BinOp Op_land. +Add Tify BinOp Op_land. #[global] Instance Op_lxor : BinOp Uint63.lxor := {| TBOp := Z.lxor ; TBOpInj := lxor_spec' |}. -Add Zify BinOp Op_lxor. +Add Tify BinOp Op_lxor. #[global] Instance Op_div : BinOp div := {| TBOp := Z.div ; TBOpInj := div_spec |}. -Add Zify BinOp Op_div. +Add Tify BinOp Op_div. #[global] Instance Op_bit : BinOp bit := {| TBOp := Z.testbit ; TBOpInj := bitE |}. -Add Zify BinOp Op_bit. +Add Tify BinOp Op_bit. #[global] Instance Op_of_Z : UnOp of_Z := { TUOp := (fun x => x mod 9223372036854775808)%Z; TUOpInj := of_Z_spec }. -Add Zify UnOp Op_of_Z. +Add Tify UnOp Op_of_Z. #[global] Instance Op_to_Z : UnOp to_Z := { TUOp := fun x => x ; TUOpInj := fun x : int => eq_refl }. -Add Zify UnOp Op_to_Z. +Add Tify UnOp Op_to_Z. #[global] Instance Op_is_zero : UnOp is_zero := { TUOp := (Z.eqb 0) ; TUOpInj := is_zeroE }. -Add Zify UnOp Op_is_zero. +Add Tify UnOp Op_is_zero. Lemma is_evenE : forall x, is_even x = Z.even (φ%uint63 x). @@ -203,7 +203,7 @@ Qed. #[global] Instance Op_is_even : UnOp is_even := { TUOp := Z.even ; TUOpInj := is_evenE }. -Add Zify UnOp Op_is_even. +Add Tify UnOp Op_is_even. Ltac Zify.zify_convert_to_euclidean_division_equations_flag ::= constr:(true).