From 018a404df84844145286660f43dab9cfc62cfc3e Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 6 Aug 2025 14:34:15 +0200 Subject: [PATCH 01/14] Move a few list functions to ListDef.v In preparation of move to Corelib. --- theories/Lists/List.v | 31 +++++-------------------------- theories/Lists/ListDef.v | 36 ++++++++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+), 26 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..0eaaaa8699 100644 --- a/theories/Lists/ListDef.v +++ b/theories/Lists/ListDef.v @@ -1 +1,37 @@ From Corelib Require Export ListDef. + +(* Rocq 9.2 additions *) + +#[local] Set Implicit Arguments. + +Fixpoint rev_append A (l l' : list A) : list A := + match l with + | nil => l' + | a :: l => rev_append l (a :: l') + end. + +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 + | nil => a0 + | b :: l => fold_left l (f a0 b) + end. + +End Fold_Left_Recursor. + +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 + | nil => a0 + | b :: l => f b (fold_right l) + end. + +End Fold_Right_Recursor. From 1e59f2f3ad2a35d055e296f22f6a8cf255bd2131 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Fri, 15 Aug 2025 15:00:49 +0200 Subject: [PATCH 02/14] Move a few things to PosDef.v In preparation of move to Corelib. --- theories/BinNums/PosDef.v | 93 +++++++++++++++++++++++++++++++++++++ theories/PArith/BinPosDef.v | 85 --------------------------------- 2 files changed, 93 insertions(+), 85 deletions(-) diff --git a/theories/BinNums/PosDef.v b/theories/BinNums/PosDef.v index ad44d4bb38..8ccb1dfdcb 100644 --- a/theories/BinNums/PosDef.v +++ b/theories/BinNums/PosDef.v @@ -1 +1,94 @@ From Corelib Require Export PosDef. + +(* Rocq 9.2 additions *) + +Module Pos. +Include Pos. + +(** ** Predecessor *) + +Definition pred x := + match x with + | xI p => xO p + | xO p => pred_double p + | xH => xH + end. + +(** ** Conversion with a decimal representation for printing/parsing *) + +#[local] Notation ten := (1~0~1~0)%positive. + +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)%positive. + +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. +End Pos. diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index 9a4ad9a4c2..369a2586b3 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -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 774beb2dda5429b15db06ef68e310f33debff98e Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Fri, 15 Aug 2025 14:47:17 +0200 Subject: [PATCH 03/14] Move a few things to NatDef.v In preparation of move to Corelib. --- theories/BinNums/NatDef.v | 63 +++++++++++++++++++++++++++++++++++++ theories/NArith/BinNatDef.v | 45 -------------------------- 2 files changed, 63 insertions(+), 45 deletions(-) diff --git a/theories/BinNums/NatDef.v b/theories/BinNums/NatDef.v index 41a5777d30..e8f4477197 100644 --- a/theories/BinNums/NatDef.v +++ b/theories/BinNums/NatDef.v @@ -1 +1,64 @@ +From Stdlib Require Import PosDef. From Corelib Require Export NatDef. + +(* Rocq 9.2 additions *) + +#[local] Set Implicit Arguments. + +Module N. +Include N. +(** ** Successor *) + +Definition succ n := + match n with + | N0 => Npos xH + | Npos p => Npos (Pos.succ p) + end. + +(** ** Addition *) + +Definition add n m := + match n, m with + | N0, _ => m + | _, N0 => n + | Npos p, Npos q => Npos (Pos.add p q) + end. + +(** Multiplication *) + +Definition mul n m := + match n, m with + | N0, _ => N0 + | _, N0 => N0 + | Npos p, Npos q => Npos (Pos.mul p q) + end. + +(** Boolean equality and comparison *) + +Definition eqb n m := + match n, m with + | N0, N0 => true + | Npos p, Npos q => Pos.eqb p q + | _, _ => false + end. + +(** Translation from [N] to [nat] and back. *) + +Definition to_nat (a : N) := + match a with + | N0 => O + | Npos p => Pos.to_nat p + end. + +(** 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. +End N. diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index 699a2d589a..530cdfd671 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -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 df9aad4f1c591f22c0a22ab13a1adeed7e26753a Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 6 Aug 2025 11:09:30 +0200 Subject: [PATCH 04/14] Prepare move of RatDef.v to Corelib --- subcomponents/corelib_wrapper.v | 1 + theories/BinNums/RatDef.v | 49 +++++++++++++++++++++++++++++++++ theories/Numbers/DecimalR.v | 4 +-- theories/Numbers/HexadecimalR.v | 4 +-- theories/QArith/QArith_base.v | 45 ++++++++++++------------------ 5 files changed, 72 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..caaecc1df0 --- /dev/null +++ b/theories/BinNums/RatDef.v @@ -0,0 +1,49 @@ +From Corelib Require Import PosDef IntDef. + +(* Rocq 9.2 additions *) + +(** * Rational numbers to serve as interface for the micromega plugin + +Beware: this type is useful for effective computations but it is +known that attempting any proof on rational numbers using it +is a very bad idea, due to its lack of canonicity +(for instance 2/3 and 4/6 are not definitionally equal). *) + +(** Rationals are pairs of [Z] and [positive] numbers. *) + +Record Q : Set := Qmake {Qnum : Z; Qden : positive}. + +Register Q as rat.Q.type. +Register Qmake as rat.Q.Qmake. + +Definition Qeq_bool x y := + Z.eqb (Z.mul (Qnum x) (Zpos (Qden y))) (Z.mul (Qnum y) (Zpos (Qden x))). + +Definition Qle_bool x y := + Z.leb (Z.mul (Qnum x) (Zpos (Qden y))) (Z.mul (Qnum y) (Zpos (Qden x))). + +(** * Addition, multiplication and opposite *) + +(** The addition, multiplication and opposite are defined + in the straightforward way: *) + +Definition Qplus (x y : Q) := + Qmake (Z.add (Z.mul (Qnum x) (Zpos (Qden y))) (Z.mul (Qnum y) (Zpos (Qden x)))) + (Pos.mul (Qden x) (Qden y)). + +Definition Qmult (x y : Q) := + Qmake (Z.mul (Qnum x) (Qnum y)) (Pos.mul (Qden x) (Qden y)). + +Definition Qopp (x : Q) := Qmake (Z.opp (Qnum x)) (Qden x). + +Definition Qminus (x y : Q) := Qplus x (Qopp y). + +Definition Qinv (x : Q) := + match Qnum x with + | Z0 => Qmake Z0 1 + | Zpos p => Qmake (Zpos (Qden x)) p + | Zneg p => Qmake (Zneg (Qden x)) p + end. + +Definition Q0 := Qmake Z0 xH. +Definition Q1 := Qmake (Zpos xH) xH. 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 c4770e9477..568ea9535e 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 c88467ed0ecbe344aa6710c75bd112cac3c015f0 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Tue, 2 Sep 2025 13:12:56 +0200 Subject: [PATCH 05/14] Prepare move of ring_checker.v to Corelib --- 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 | 579 ++++++++++++++++++++++++++ theories/setoid_ring/ring_eval.v | 87 ++++ 8 files changed, 921 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 8930df5ba5..901873ca25 100644 --- a/subcomponents/ring.v +++ b/subcomponents/ring.v @@ -21,4 +21,5 @@ 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. 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 2073200316..5fa1f84d7c 100644 --- a/theories/setoid_ring/Field_theory.v +++ b/theories/setoid_ring/Field_theory.v @@ -1515,7 +1515,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..06ce0719f0 --- /dev/null +++ b/theories/setoid_ring/ring_checker.v @@ -0,0 +1,579 @@ +(************************************************************************) +(* * The Rocq Prover / The Rocq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* = 9.2 + and use the identical file in Corelib instead *) + +From Stdlib Require Import PosDef IntDef. + +Set Implicit Arguments. + +(** The ring tactic is a decision procedure for ring equalities. +See [ring_checker] at the end of the file for the main definition. +This file contains the computational part of the ring tactic, to get a full +tactic, one needs in addition an input term reifier, a proof of correctness +of the computational part and a tactic gluing everything together. *) + +(** Definition of polynomial expressions *) +Inductive PExpr {C} : 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. +Arguments PExpr : clear implicits. +Arguments PEX : clear implicits. + +(** Definition of multivariable polynomials with coefficients in C : +Type [Pol] represents [X1 ... Xn]. +The representation is Horner's where a [n] variable polynomial +(C[X1..Xn]) is seen as a polynomial on [X1] whose coefficients +are polynomials with [n-1] variables (C[X2..Xn]). +There are several optimisations to make the repr more compact: +- [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 {C} : Type := +| Pc : C -> Pol +| Pinj : positive -> Pol -> Pol +| PX : Pol -> positive -> Pol -> Pol. +Arguments Pol : clear implicits. + +(** 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. + +(** * Basic arithmetic operations on Horner polynomials [Pol] + +One can prove that an eval function [Peval] commutes with +each operation, e.g., [Peval l (Padd P P') = Peval l P + Peval l P'] *) +Section PolOps. + +(** Coefficients *) +Variable (C : Type) (cO cI : C) (cadd cmul csub : C -> C -> C) (copp : C -> C). +Variable ceqb : C -> C -> bool. + +Implicit Type P : Pol C. + +(** Equality *) +Fixpoint Peq P P' {struct P'} : bool := + match P, P' with + | Pc c, Pc c' => ceqb c c' + | Pinj j Q, Pinj j' Q' => + match Pos.compare j j' with + | Eq => Peq Q Q' + | _ => false + end + | PX P i Q, PX P' i' Q' => + match Pos.compare i i' with + | Eq => if Peq P P' then Peq Q Q' else false + | _ => false + end + | _, _ => false + end. + +(** Constructors *) + +Definition P0 := Pc cO. +Definition P1 := Pc cI. + +Definition mkPinj j P := + match P with + | Pc _ => P + | Pinj j' Q => Pinj (Pos.add 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 mkX j := mkPinj_pred j (PX P1 1 P0). + +Definition mkPX P i Q := + match P with + | Pc c => if ceqb c cO then mkPinj xH Q else PX P i Q + | Pinj _ _ => PX P i Q + | PX P' i' Q' => if Peq Q' P0 then PX P' (Pos.add i' i) Q else PX P i Q + end. + +(** Opposite *) +Fixpoint Popp P : Pol C := + match P with + | Pc c => Pc (copp c) + | Pinj j Q => Pinj j (Popp Q) + | PX P i Q => PX (Popp P) i (Popp Q) + end. + +(** Addition and subtraction *) + +Fixpoint PaddC P c : Pol C := + match P with + | Pc c1 => Pc (cadd c1 c) + | Pinj j Q => Pinj j (PaddC Q c) + | PX P i Q => PX P i (PaddC Q c) + end. + +Fixpoint PsubC P c : Pol C := + match P with + | Pc c1 => Pc (csub 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 C -> Pol C -> Pol C. +Variable Q : Pol C. + +(** [P + Pinj j Q], assuming [Pop . Q] is [. + Q] *) +Fixpoint PaddI (j : positive) P : Pol C := + 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. + +(** [P - Pinj j Q], assuming [Pop . Q] is [. - Q] *) +Fixpoint PsubI (j : positive) P : Pol C := + match P with + | Pc c => mkPinj j (PaddC (Popp 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 C. + +(** [P + PX P' i' P0], assuming [Pop . P'] is [. + P'] *) +Fixpoint PaddX (i' : positive) P : Pol C := + 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. + +(** [P - PX P' i' P0], assuming [Pop . P'] is [. - P'] *) +Fixpoint PsubX (i' : positive) P : Pol C := + match P with + | Pc c => PX (Popp P') i' P + | Pinj j Q' => + match j with + | xH => PX (Popp P') i' Q' + | xO j => PX (Popp P') i' (Pinj (Pos.pred_double j) Q') + | xI j => PX (Popp 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' {struct P'} : Pol C := + 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. + +Fixpoint Psub P P' {struct P'} : Pol C := + 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 (Popp P') i' (PaddC (Popp Q') c) + | Pinj j Q => + match j with + | xH => PX (Popp P') i' (Psub Q Q') + | xO j => PX (Popp P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') + | xI j => PX (Popp 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. + +(** Multiplication *) + +Fixpoint PmulC_aux P c : Pol C := + match P with + | Pc c' => Pc (cmul 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 ceqb c cO then P0 else + if ceqb c cI then P else PmulC_aux P c. + +(** [P * Pinj j Q], assuming [Pmul . Q] is [. * Q] *) +Section PmulI. +Variable Pmul : Pol C -> Pol C -> Pol C. +Variable Q : Pol C. +Fixpoint PmulI (j : positive) P : Pol C := + 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'' {struct P''} : Pol C := + 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 + Padd (mkPX (Padd (mkPX PP' i P0) QP') i' P0) (mkPX PQ' i QQ') + end + end. + +Fixpoint Psquare P : Pol C := + match P with + | Pc c => Pc (cmul c c) + | Pinj j Q => Pinj j (Psquare Q) + | PX P i Q => + let twoPQ := Pmul P (mkPinj xH (PmulC Q (cadd cI cI))) in + let Q2 := Psquare Q in + let P2 := Psquare P in + mkPX (Padd (mkPX P2 i P0) twoPQ) i Q2 + end. + +Fixpoint Ppow_pos (res P : Pol C) (p : positive) : Pol C := + match p with + | xH => Pmul res P + | xO p => Ppow_pos (Ppow_pos res P p) P p + | xI p => Pmul (Ppow_pos (Ppow_pos res P p) P p) P + end. + +Definition Ppow_N P n := match n with N0 => P1 | Npos p => Ppow_pos P1 P p end. + +End PolOps. + +Section MonOps. + +(** Coefficients *) +Variable (C : Type) (cO cI : C) (cadd cmul : C -> C -> C). +Variable (ceqb : C -> C -> bool) (cdiv : C -> C -> C * C). +(* only requirement on cdiv is: +[forall x y, let (q, r) := cdiv x y in x = y * q + r] *) + +Implicit Type P : Pol C. +Implicit Type M : Mon. + +#[local] Notation Peq := (Peq ceqb). +#[local] Notation P0 := (P0 cO). +#[local] Notation mkPX := (mkPX cO ceqb). +#[local] Notation Padd := (Padd cO cadd ceqb). +#[local] Notation Pmul := (Pmul cO cI cadd cmul ceqb). + +(** Constructors *) + +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 (Pos.add i i') m + end. + +(** [forall l P c, let (Q, R) := CFactor P c in +Peval l P = Peval l Q + R_of_C c * Peval l R] *) +Fixpoint CFactor P (c : C) {struct P} : Pol C * Pol C := + 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. + +(** [forall l P c M, let (Q, R) := MFactor P c M in +Peval l P = Peval l Q + cMeval l (c, M) * Peval l R] *) +Fixpoint MFactor P c (M : Mon) {struct P} : Pol C * Pol C := + 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 Pos.compare 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 (Pos.sub 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 Pos.compare 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 (Pos.sub 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 (Pos.sub i j) (Pc cO)) + end + end. + +(** [forall l P1 cM1 P2 P3, POneSubst P1 cM1 P2 = Some P3 -> +cMeval l cM1 = Peval l P2 -> Peval l P1 = Peval l P3] *) +Definition POneSubst P1 (cM1 : C * Mon) P2 : option (Pol C) := + let (c, M1) := cM1 in + let (Q1, R1) := MFactor P1 c M1 in + match R1 with + | (Pc c) => if ceqb c cO then None else Some (Padd Q1 (Pmul P2 R1)) + | _ => Some (Padd Q1 (Pmul P2 R1)) + end. + +(** [forall l n P1 cM1 P2, cMeval l cM1 = Peval l P2 -> +Peval l P1 = Peval l (PNSubst1 P1 cM1 P2 n)] *) +Fixpoint PNSubst1 P1 (cM1 : C * Mon) P2 n : Pol C := + match POneSubst P1 cM1 P2 with + | Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | O => P3 end + | None => P1 + end. + +(** [forall l n P1 cM1 P2 P3, PNSubst P1 cM1 P2 n = Some P3 -> +cMeval l cM1 = Peval l P2 -> Peval l P1 = Peval l P3] *) +Definition PNSubst P1 (cM1 : C * Mon) P2 n : option (Pol C) := + match POneSubst P1 cM1 P2 with + | Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end + | None => None + end. + +(** [forall l n LM1 P1, all (fun MP => cMeval l MP.1 = Peval l MP.2) LM1 -> +Peval l P1 = Peval l (PSubstL1 P1 LM1 n)] *) +Fixpoint PSubstL1 P1 (LM1 : list ((C * Mon) * Pol C)) n : Pol C := + match LM1 with + | cons (M1, P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n + | nil => P1 + end. + +(** [forall l n LM1 P1 P2, PSubstL P1 LM1 n = Some P2 -> + all (fun MP => cMeval l MP.1 = Peval l MP.2) LM1 -> +Peval l P1 = Peval l P2] *) +Fixpoint PSubstL P1 (LM1 : list ((C * Mon) * Pol C)) n : option (Pol C) := + 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 + | nil => None + end. + +(** [forall l m n LM1 P1, + all (fun MP => cMeval l MP.1 = Peval l MP.2) LM1 -> +Peval l P1 = Peval l (PNSubstL P1 LM1 m n)] *) +Fixpoint PNSubstL P1 (LM1: list ((C * Mon) * Pol C)) m n : Pol C := + match PSubstL P1 LM1 n with + | Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | O => P3 end + | None => P1 + end. + +(** [forall l P m, Mon_of_Pol P = Some m -> cMeval l m = Peval l P] *) +Fixpoint Mon_of_Pol P : option (C * Mon) := + match P with + | Pc c => if ceqb 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. + +End MonOps. + +(** * Checker for the ring tactic *) +Section RingChecker. + +Variables (C : Type) (cO cI : C) (cadd cmul csub : C -> C -> C) (copp : C -> C). +Variables (ceqb : C -> C -> bool) (cdiv : C -> C -> C * C). +(* only requirement on cdiv is: +[forall x y, let (q, r) := cdiv x y in x = y * q + r] *) + +#[local] Notation P0 := (P0 cO). +#[local] Notation P1 := (P1 cI). +#[local] Notation mkX := (mkX cO cI). +#[local] Notation Peq := (Peq ceqb). +#[local] Notation Popp := (Popp copp). +#[local] Notation Padd := (Padd cO cadd ceqb). +#[local] Notation Psub := (Psub cO cadd csub copp ceqb). +#[local] Notation Pmul := (Pmul cO cI cadd cmul ceqb). +#[local] Notation Ppow_N := (Ppow_N cO cI cadd cmul ceqb). +#[local] Notation PNSubstL := (PNSubstL cO cI cadd cmul ceqb cdiv). +#[local] Notation Mon_of_Pol := (Mon_of_Pol cO ceqb). + +(** [forall l pe, Peval l (Pol_of_Pexpr pe) = PEeval l pe] *) +Fixpoint Pol_of_PExpr (pe : PExpr C) : Pol C := + match pe with + | PEO => P0 + | PEI => P1 + | PEc c => Pc c + | PEX _ j => mkX j + | PEadd (PEopp pe1) pe2 => Psub (Pol_of_PExpr pe2) (Pol_of_PExpr pe1) + | PEadd pe1 (PEopp pe2) => Psub (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) + | PEadd pe1 pe2 => Padd (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) + | PEsub pe1 pe2 => Psub (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) + | PEmul pe1 pe2 => Pmul (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) + | PEopp pe1 => Popp (Pol_of_PExpr pe1) + | PEpow pe1 n => Ppow_N (Pol_of_PExpr pe1) n + end. + +(** [forall n l lpe pe, + all (fun PP => PEeval l PP.1 = PEeval l PP.2) lpe -> +Peval l (norm_subst n (mk_monpol_list lpe) pe) = PEeval l pe] *) +Definition norm_subst (n : nat) (lmp : list (C * Mon * Pol C)) pe := + PNSubstL (Pol_of_PExpr pe) lmp n n. + +(** [forall l lpe, + all (fun PP => PEeval l PP.1 = PEeval l PP.2) lpe -> +all (fun MP => cMeval l MP.1 = Peval l MP.2) (mk_monpol_list lpe)] *) +Fixpoint mk_monpol_list (lpe : list (PExpr C * PExpr C)) : + list (C * Mon * Pol C) := + match lpe with + | nil => nil + | cons (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. + +(** [forall n l lpe pe1 pe2, PEeval_eqs l lpe -> ring_checker n lpe pe1 pe2 -> +PEeval l pe1 = PEeval l pe2] *) +Definition ring_checker n lpe pe1 pe2 := + let lmp := mk_monpol_list lpe in + Peq (norm_subst n lmp pe1) (norm_subst n lmp pe2). + +End RingChecker. + +(** a trivial implementation for cdiv *) +Definition triv_div (C : Type) (cO cI : C) (ceqb : C -> C -> bool) x y := + if ceqb x y then (cI, cO) else (cO, x). diff --git a/theories/setoid_ring/ring_eval.v b/theories/setoid_ring/ring_eval.v new file mode 100644 index 0000000000..04e40a3af8 --- /dev/null +++ b/theories/setoid_ring/ring_eval.v @@ -0,0 +1,87 @@ +(************************************************************************) +(* * The Rocq Prover / The Rocq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* = 9.2 + and use the identical file in Corelib instead *) + +From Corelib Require Import BinNums. +From Stdlib Require Import ring_checker. + +Set Implicit Arguments. + +Section PEeval. +Variables (P : Type) (ptrue : P) (pand : P -> P -> P). +Variables (R : Type) (rO rI : R) (radd rmul rsub: R -> R -> R) (ropp : R -> R). +Variables (Cpow : Type) (Cpow_of_N : N -> Cpow) (rpow : R -> Cpow -> R). +Variables (req : R -> R -> P). +Variables (C : Type) (R_of_C : C -> R). +Variables (Env : Type). +Variables (env_jump : positive -> Env -> Env) (env_nth : positive -> Env -> R). + +Fixpoint PEeval l pe : R := + match pe with + | PEO => rO + | PEI => rI + | PEc c => R_of_C c + | PEX _ j => env_nth j l + | PEadd pe1 pe2 => radd (PEeval l pe1) (PEeval l pe2) + | PEsub pe1 pe2 => rsub (PEeval l pe1) (PEeval l pe2) + | PEmul pe1 pe2 => rmul (PEeval l pe1) (PEeval l pe2) + | PEopp pe1 => ropp (PEeval l pe1) + | PEpow pe1 n => rpow (PEeval l pe1) (Cpow_of_N n) + end. + +Fixpoint PEeval_eqs l (lpe : list (PExpr C * PExpr C)) : P := + match lpe with + | nil => ptrue + | cons (me, pe) nil => req (PEeval l me) (PEeval l pe) + | cons (me, pe) lpe => + pand (req (PEeval l me) (PEeval l pe)) (PEeval_eqs l lpe) + end. + +Fixpoint Peval l P : R := + match P with + | Pc c => R_of_C c + | Pinj j Q => Peval (env_jump j l) Q + | PX P i Q => + radd (rmul (Peval l P) (rpow (env_nth xH l) (Cpow_of_N (Npos i)))) + (Peval (env_jump xH l) Q) + end. + +Fixpoint Meval l M : R := + match M with + | mon0 => rI + | zmon j M1 => Meval (env_jump j l) M1 + | vmon i M1 => + rmul (Meval (env_jump xH l) M1) (rpow (env_nth xH l) (Cpow_of_N (Npos i))) + end. + +Definition cMeval l cM := rmul (R_of_C (fst cM)) (Meval l (snd cM)). +End PEeval. + +Fixpoint PEmap T T' (f : T -> T') (e : PExpr T) : PExpr T' := + match e with + | PEO => PEO + | PEI => PEI + | PEc c => PEc (f c) + | PEX _ p => PEX _ p + | PEadd e1 e2 => PEadd (PEmap f e1) (PEmap f e2) + | PEsub e1 e2 => PEsub (PEmap f e1) (PEmap f e2) + | PEmul e1 e2 => PEmul (PEmap f e1) (PEmap f e2) + | PEopp e => PEopp (PEmap f e) + | PEpow e n => PEpow (PEmap f e) n + end. + +Fixpoint Pmap T T' (f : T -> T') (P : Pol T) : Pol T' := + match P with + | Pc c => Pc (f c) + | Pinj j P => Pinj j (Pmap f P) + | PX P i Q => PX (Pmap f P) i (Pmap f Q) + end. From 007f3d336f5b58f38c826fea4e1a858d35982ff4 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Sat, 30 Aug 2025 19:03:56 +0200 Subject: [PATCH 06/14] Prepare move of field_checker.v to Corelib --- subcomponents/field.v | 1 + theories/setoid_ring/Field_theory.v | 273 ++++----------------- theories/setoid_ring/field_checker.v | 340 +++++++++++++++++++++++++++ theories/setoid_ring/field_eval.v | 70 ++++++ 4 files changed, 455 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 54175ff749..f7945d5de2 100644 --- a/subcomponents/field.v +++ b/subcomponents/field.v @@ -1,2 +1,3 @@ From subcomponents Require zarith. 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 5fa1f84d7c..b28c00ed09 100644 --- a/theories/setoid_ring/Field_theory.v +++ b/theories/setoid_ring/Field_theory.v @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +From Stdlib Require Export field_checker. From Stdlib Require Ring. Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List Morphisms. From Stdlib Require Import BinNat BinInt. @@ -554,23 +555,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. @@ -579,7 +567,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. @@ -599,15 +587,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. @@ -618,16 +607,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. @@ -638,29 +617,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. @@ -674,16 +635,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. @@ -698,16 +649,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. @@ -732,18 +675,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 @@ -764,10 +696,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). (*************************************************************************** @@ -808,9 +737,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. @@ -826,35 +753,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. @@ -874,7 +774,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. @@ -901,7 +801,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. @@ -950,33 +850,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 @@ -988,7 +869,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. @@ -1019,8 +900,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. @@ -1047,54 +926,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 *) (* @@ -1460,11 +1293,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. @@ -1501,14 +1330,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. @@ -1516,6 +1338,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. @@ -1523,13 +1347,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. @@ -1564,14 +1382,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. @@ -1595,7 +1406,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. @@ -1826,5 +1638,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..3b219e9fe6 --- /dev/null +++ b/theories/setoid_ring/field_checker.v @@ -0,0 +1,340 @@ +(************************************************************************) +(* * The Rocq Prover / The Rocq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* = 9.2 + and use the identical file in Corelib instead *) + +From Stdlib Require Import PosDef IntDef NatDef. +From Stdlib Require Import ring_checker. + +Set Implicit Arguments. + +(** The field tactic is essentially a preprocessing step to the ring tactic +(see file ring_checker.v). *) + +(** Definition of field expressions *) +Inductive FExpr {C} : 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. +Arguments FExpr : clear implicits. + +Section FieldChecker. +Variables (C : Type) (cO cI : C) (cadd cmul csub : C -> C -> C) (copp : C -> C). +Variables (pow_pos : C -> positive -> C). +Variables (ceqb : C -> C -> bool) (cdiv : C -> C -> C * C). +(* only requirement on cdiv is: +[forall x y, let (q, r) := cdiv x y in x = y * q + r] *) + +(** forall l e1 e2, PEeval l (NPEadd e1 e2) = PEeval l (PEadd e1 e2) *) +Definition NPEadd e1 e2 := + match e1, e2 with + | PEc c1, PEc c2 => PEc (cadd c1 c2) + | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2 + | _, PEc c => if ceqb c cO then e1 else PEadd e1 e2 + | _, _ => PEadd e1 e2 + end. + +(** forall l e1 e2, PEeval l (NPEsub e1 e2) = PEeval l (PEsub e1 e2) *) +Definition NPEsub e1 e2 := + match e1, e2 with + | PEc c1, PEc c2 => PEc (csub c1 c2) + | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2 + | _, PEc c => if ceqb c cO then e1 else PEsub e1 e2 + | _, _ => PEsub e1 e2 + end. + +(** forall l e, PEeval l (NPEopp e) = PEeval l (PEopp e) *) +Definition NPEopp e := match e with PEc c => PEc (copp c) | _ => PEopp e end. + +(** forall l e n, PEeval l (NPEpow e n) = PEeval l (PEpow e n) *) +Definition NPEpow x n := + match n with + | N0 => PEc cI + | Npos p => + if Pos.eqb p xH then x else + match x with + | PEc c => + if ceqb c cI then PEc cI else if ceqb c cO then PEc cO + else PEc (pow_pos c p) + | _ => PEpow x n + end + end. + +(** forall l e1 e2, PEeval l (NPEmul e1 e2) = PEeval l (PEmul e1 e2) *) +Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := + match x, y with + | PEc c1, PEc c2 => PEc (cmul c1 c2) + | PEc c, _ => if ceqb c cI then y else if ceqb c cO then PEO else PEmul x y + | _, PEc c => if ceqb c cI then x else if ceqb c cO then PEO else PEmul x y + | PEpow e1 n1, PEpow e2 n2 => + if N.eqb n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y + | _, _ => PEmul x y + end. + +(** forall e1 e2, (e1 = e2) <-> (PExpr_eq e1 e2 = true) *) +Fixpoint PExpr_eq (e e' : PExpr C) {struct e} : bool := + match e, e' with + | PEO, PEO | PEI, PEI => true + | PEc c, PEc c' => ceqb c c' + | PEX _ p, PEX _ p' => Pos.eqb p p' + | PEadd e1 e2, PEadd e1' e2' => andb (PExpr_eq e1 e1') (PExpr_eq e2 e2') + | PEsub e1 e2, PEsub e1' e2' => andb (PExpr_eq e1 e1') (PExpr_eq e2 e2') + | PEmul e1 e2, PEmul e1' e2' => andb (PExpr_eq e1 e1') (PExpr_eq e2 e2') + | PEopp e, PEopp e' => PExpr_eq e e' + | PEpow e n, PEpow e' n' => andb (N.eqb n n') (PExpr_eq e e') + | _, _ => false + end. + +(** forall l e1 p1 e2 p2 n e3, default_isIn e1 p1 e2 p2 = Some (n, e3) -> +(Pos.to_nat p1 > N.to_nat n + /\ PEeval l (PEpow e2 (Npos p2)) + = PEeval l (PEmul (PEpow e1 (N.sub (Npos p1) n)) e3)) *) +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, PEc cI) + | Z0 => Some (N0, PEc cI) + | Zneg p => Some (N0, NPEpow e2 (Npos p)) + end + else None. + +(** forall l e1 p1 e2 p2 n e3, isIn e1 p1 e2 p2 = Some (n, e3) -> +(Pos.to_nat p1 > N.to_nat n + /\ PEeval l (PEpow e2 (Npos p2)) + = PEeval l (PEmul (PEpow e1 (N.sub (Npos p1) n)) e3)) *) +Fixpoint isIn e1 p1 e2 p2 {struct e2}: option (N * PExpr C) := + match e2 with + | PEmul e3 e4 => + match isIn e1 p1 e3 p2 with + | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2))) + | Some (Npos p, e5) => + match isIn e1 p e4 p2 with + | Some (n, e6) => Some (n, NPEmul e5 e6) + | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2))) + end + | None => + match isIn e1 p1 e4 p2 with + | Some (n, e5) => Some (n, NPEmul (NPEpow e3 (Npos p2)) e5) + | None => None + end + end + | PEpow e3 N0 => None + | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pos.mul p3 p2) + | _ => default_isIn e1 p1 e2 p2 + end. + +Record rsplit : Type := mk_rsplit { + rsplit_left : PExpr C; + rsplit_common : PExpr C; + rsplit_right : PExpr C; +}. + +(** forall l e1 p e2, +PEeval l (PEpow e1 (Npos p)) += PEeval l (PEmul (rsplit_left (split_aux e1 p e2)) + (rsplit_common (split_aux e1 p e2))) +/\ PEeval l e2 + = PEeval l (PEmul (rsplit_right (split_aux e1 p e2)) + (rsplit_common (split_aux e1 p e2))) *) +Fixpoint split_aux e1 p e2 {struct e1} : rsplit := + match e1 with + | PEmul e3 e4 => + let r1 := split_aux e3 p e2 in + let r2 := split_aux e4 p (rsplit_right r1) in + mk_rsplit (NPEmul (rsplit_left r1) (rsplit_left r2)) + (NPEmul (rsplit_common r1) (rsplit_common r2)) + (rsplit_right r2) + | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2 + | PEpow e3 (Npos p3) => split_aux e3 (Pos.mul p3 p) e2 + | _ => + match isIn e1 p e2 xH with + | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 + | Some (Npos q, e3) => + mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (Pos.sub p q))) e3 + | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 + end + end. + +(** +* forall l e1 e2, + PEeval l e1 + = PEeval l (PEmul (rsplit_left (split e1 e2)) + (rsplit_common (split e1 e2))) +* forall l e1 e2, + PEeval l e2 + = PEeval l (PEmul (rsplit_right (split e1 e2)) + (rsplit_common (split e1 e2))) +* forall l e1 e2, + PEeval l e1 != 0 -> PEeval l (rsplit_left (split e1 e2)) != 0 +* forall l e1 e2, + PEeval l e2 != 0 -> PEeval l (rsplit_right (split e1 e2)) != 0 *) +Definition split e1 e2 := split_aux e1 xH e2. + +Record linear : Type := mk_linear { + num : PExpr C; + denum : PExpr C; + condition : list (PExpr C); +}. + +(** main normalisation function +* [forall l e, PCond l (condition (Fnorm e)) -> + PEeval l (denum (Fnorm e)) != 0] +* [forall l e : PCond l (condition (Fnorm e)) -> + FEeval l e = PEeval l (num (Fnorm e)) / PEeval l (denum (Fnorm e))] *) +Fixpoint Fnorm (e : FExpr C) : linear := + match e with + | FEO => mk_linear (PEc cO) (PEc cI) nil + | FEI => mk_linear (PEc cI) (PEc cI) nil + | FEc c => mk_linear (PEc c) (PEc cI) nil + | FEX x => mk_linear (PEX C x) (PEc cI) nil + | FEadd e1 e2 => + let x := Fnorm e1 in + let y := Fnorm e2 in + let s := split (denum x) (denum y) in + mk_linear + (NPEadd (NPEmul (num x) (rsplit_right s)) + (NPEmul (num y) (rsplit_left s))) + (NPEmul (rsplit_left s) (NPEmul (rsplit_right s) (rsplit_common s))) + (condition x ++ condition y) + | FEsub e1 e2 => + let x := Fnorm e1 in + let y := Fnorm e2 in + let s := split (denum x) (denum y) in + mk_linear + (NPEsub (NPEmul (num x) (rsplit_right s)) + (NPEmul (num y) (rsplit_left s))) + (NPEmul (rsplit_left s) (NPEmul (rsplit_right s) (rsplit_common s))) + (condition x ++ condition y) + | 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 (NPEmul (rsplit_left s1) (rsplit_left s2)) + (NPEmul (rsplit_right s2) (rsplit_right s1)) + (condition x ++ condition y) + | 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 (NPEmul (rsplit_left s1) (rsplit_right s2)) + (NPEmul (rsplit_left s2) (rsplit_right s1)) + (num y :: condition x ++ condition y) + | FEpow e1 n => + let x := Fnorm e1 in + mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x) + end. + +#[local] Notation mk_monpol_list := (mk_monpol_list + cO cI cadd cmul csub copp ceqb cdiv). +#[local] Notation Pol_of_PExpr := (Pol_of_PExpr cO cI cadd cmul csub copp ceqb). +#[local] Notation norm_subst := (norm_subst + cO cI cadd cmul csub copp ceqb cdiv). + +(** Main function, when [field_checker] returns [Some lc], The equality +[FEeval l fe1 = FEeval l fe2] holds under the hypotheses given by [lc], that is: +[forall cond_norm (cond_normP : forall l el, PCond l (cond_norm el) -> + PCond l el) n l lpe fe1 fe2 lc, + PEeval_eqs l lpe -> + field_checker cond_norm n lpe fe1 fe2 = Some lc -> + PCond l lc -> + FEeval l fe1 = FEeval l fe2] +[cond_norm] is used to normalise the resulting conditions, +see below for implementations. *) +Definition field_checker cond_norm n lpe fe1 fe2 : option (list (PExpr C)) := + let lmp := mk_monpol_list lpe in + let ne1 := Fnorm fe1 in + let ne2 := Fnorm fe2 in + let res := + Peq ceqb + (norm_subst n lmp (PEmul (num ne1) (denum ne2))) + (norm_subst n lmp (PEmul (num ne2) (denum ne1))) in + if res then Some (cond_norm (app (condition ne1) (condition ne2))) else None. + +(* Some general simpifications of the condition: eliminate duplicates, + split multiplications *) + +(* eliminate duplicates (through normal forms comparison) +[forall l a el, PCond l (Fcons0 a el) -> PEeval l a != 0 /\ PCond l el] *) +Fixpoint Fcons0 (e : PExpr C) (l : list (PExpr C)) {struct l} := + match l with + | nil => cons e nil + | cons a l1 => + if Peq ceqb (Pol_of_PExpr e) (Pol_of_PExpr a) then l + else cons a (Fcons0 e l1) + end. + +(* split factorized denominators +[forall l a el, PCond l (Fcons00 a el) -> PEeval l a != 0 /\ PCond l el] *) +Fixpoint Fcons00 (e : PExpr C) (l : list (PExpr C)) {struct e} := + match e with + | PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l) + | PEpow e1 _ => Fcons00 e1 l + | _ => Fcons0 e l + end. + +(* An unsatisfiable condition: issued when a division by zero is detected *) +Definition absurd_PCond := cons (PEc cO) nil. + +(* [forall l a el, PCond l (Fcons1 a el) -> PEeval l a != 0 /\ PCond l el] *) +Fixpoint Fcons1 (e : PExpr C) (l : list (PExpr C)) {struct e} := + match e with + | PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) + | PEpow e _ => Fcons1 e l + | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l + | PEc c => if ceqb c cO then absurd_PCond else l + | _ => Fcons0 e l + end. + +(* simplification [forall l e, PEeval l (PEsimp e) = PEeval l e] *) +Fixpoint PEsimp (e : PExpr C) : PExpr C := + match e with + | PEadd e1 e2 => NPEadd (PEsimp e1) (PEsimp e2) + | PEmul e1 e2 => NPEmul (PEsimp e1) (PEsimp e2) + | PEsub e1 e2 => NPEsub (PEsimp e1) (PEsimp e2) + | PEopp e1 => NPEopp (PEsimp e1) + | PEpow e1 n1 => NPEpow (PEsimp e1) n1 + | _ => e + end. + +(** [forall l a el, PCond l (Fcons2 a el) -> PEeval l a != 0 /\ PCond l el] *) +Definition Fcons2 e l := Fcons1 (PEsimp e) l. + +Section Fapp. +Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C). +(** [forall l el el', + (forall l e el, PCond l (Fcons e el) -> PEeval l e != 0 /\ PCond l el) -> +PCond l (Fapp Fcons el el') -> PCond l el /\ PCond l el'] *) +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. +End Fapp. + +(** [forall Fcons l el, + (forall l e el, PCond l (Fcons e el) -> PEeval l e != 0 /\ PCond l el) -> +PCond l (cond_norm Fcons el) -> PCond l el] *) +Definition cond_norm Fcons l := Fapp Fcons l nil. + +End FieldChecker. diff --git a/theories/setoid_ring/field_eval.v b/theories/setoid_ring/field_eval.v new file mode 100644 index 0000000000..2e2467695e --- /dev/null +++ b/theories/setoid_ring/field_eval.v @@ -0,0 +1,70 @@ +(************************************************************************) +(* * The Rocq Prover / The Rocq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* = 9.2 + and use the identical file in Corelib instead *) + +From Corelib Require Import BinNums. +From Stdlib Require Import ring_checker ring_eval field_checker. + +Set Implicit Arguments. + +Section FEeval. +Variables (P : Type) (ptrue : P) (pneg : P -> P) (pand : P -> P -> P). +Variables (R : Type) (rO rI : R) (radd rmul rsub: R -> R -> R) (ropp : R -> R). +Variables (rdiv : R -> R -> R) (rinv : R -> R). +Variables (Cpow : Type) (Cpow_of_N : N -> Cpow) (rpow : R -> Cpow -> R). +Variables (req : R -> R -> P). +Variables (C : Type) (R_of_C : C -> R). +Variables (Env : Type). +Variables (env_jump : positive -> Env -> Env) (env_nth : positive -> Env -> R). + +Fixpoint FEeval l (pe : FExpr C) {struct pe} : R := + match pe with + | FEO => rO + | FEI => rI + | FEc c => R_of_C c + | FEX x => env_nth x l + | FEadd x y => radd (FEeval l x) (FEeval l y) + | FEsub x y => rsub (FEeval l x) (FEeval l y) + | FEmul x y => rmul (FEeval l x) (FEeval l y) + | FEopp x => ropp (FEeval l x) + | FEinv x => rinv (FEeval l x) + | FEdiv x y => rdiv (FEeval l x) (FEeval l y) + | FEpow x n => rpow (FEeval l x) (Cpow_of_N n) + end. + +#[local] Notation PEeval := (PEeval rO rI radd rmul rsub ropp + Cpow_of_N rpow R_of_C env_nth). + +Fixpoint PCond l (le : list (PExpr C)) {struct le} : P := + match le with + | nil => ptrue + | cons e1 nil => pneg (req (PEeval l e1) rO) + | cons e1 l1 => pand (pneg (req (PEeval l e1) rO)) (PCond l l1) + end. + +End FEeval. +Arguments PCond : simpl nomatch. + +Fixpoint FEmap T T' (f : T -> T') (e : FExpr T) : FExpr T' := + match e with + | FEO => FEO + | FEI => FEI + | FEc c => FEc (f c) + | FEX p => FEX p + | FEadd e1 e2 => FEadd (FEmap f e1) (FEmap f e2) + | FEsub e1 e2 => FEsub (FEmap f e1) (FEmap f e2) + | FEmul e1 e2 => FEmul (FEmap f e1) (FEmap f e2) + | FEopp e => FEopp (FEmap f e) + | FEinv e => FEinv (FEmap f e) + | FEdiv e1 e2 => FEdiv (FEmap f e1) (FEmap f e2) + | FEpow e n => FEpow (FEmap f e) n + end. From e9e8f1d3aa733d0ecadfbd429e31ee2b5288b6a9 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 6 Aug 2025 10:47:03 +0200 Subject: [PATCH 07/14] Prepare move of micromega_formula.v to Corelib --- theories/micromega/EnvRing.v | 25 +----- theories/micromega/QMicromega.v | 8 +- theories/micromega/RMicromega.v | 8 +- theories/micromega/RingMicromega.v | 26 ------ theories/micromega/Tauto.v | 78 +++++------------ theories/micromega/ZMicromega.v | 22 ++--- theories/micromega/micromega_formula.v | 112 +++++++++++++++++++++++++ 7 files changed, 153 insertions(+), 126 deletions(-) create mode 100644 theories/micromega/micromega_formula.v diff --git a/theories/micromega/EnvRing.v b/theories/micromega/EnvRing.v index fb9f1ea13b..c2d5030217 100644 --- a/theories/micromega/EnvRing.v +++ b/theories/micromega/EnvRing.v @@ -11,34 +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 Stdlib Require Export micromega_formula. 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 diff --git a/theories/micromega/QMicromega.v b/theories/micromega/QMicromega.v index c823961e09..c404f1ae23 100644 --- a/theories/micromega/QMicromega.v +++ b/theories/micromega/QMicromega.v @@ -153,7 +153,7 @@ Proof. - apply Qlt_bool_iff. Qed. -Definition Qeval_op2 (k:Tauto.kind) : Op2 -> Q -> Q -> Tauto.rtyp k:= +Definition Qeval_op2 (k:kind) : Op2 -> Q -> Q -> Tauto.rtyp k:= if k as k0 return (Op2 -> Q -> Q -> Tauto.rtyp k0) then Qeval_pop2 else Qeval_bop2. @@ -166,7 +166,7 @@ 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' := @@ -237,10 +237,10 @@ Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool. Definition normQ := norm 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Declare Equivalent Keys normQ RingMicromega.norm. -Definition cnfQ (Annot:Type) (TX: Tauto.kind -> Type) (AF: Type) (k: Tauto.kind) (f: TFormula (Formula Q) Annot TX AF k) := +Definition cnfQ (Annot:Type) (TX: kind -> Type) (AF: Type) (k: 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 := +Definition QTautoChecker (f : BFormula (Formula Q) isProp) (w: list QWitness) : bool := @tauto_checker (Formula Q) (NFormula Q) unit qunsat qdeduce (Qnormalise unit) diff --git a/theories/micromega/RMicromega.v b/theories/micromega/RMicromega.v index 2abca8acf2..f852ff689e 100644 --- a/theories/micromega/RMicromega.v +++ b/theories/micromega/RMicromega.v @@ -419,7 +419,7 @@ Proof. - apply Rlt_not_le in H. tauto. Qed. -Definition Reval_op2 (k: Tauto.kind) : Op2 -> R -> R -> Tauto.rtyp k:= +Definition Reval_op2 (k: kind) : Op2 -> R -> R -> Tauto.rtyp k:= if k as k0 return (Op2 -> R -> R -> Tauto.rtyp k0) then Reval_pop2 else Reval_bop2. @@ -431,7 +431,7 @@ 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). @@ -461,7 +461,7 @@ Qed. Definition QReval_expr := eval_pexpr 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). @@ -514,7 +514,7 @@ 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 := +Definition RTautoChecker (f : BFormula (Formula Rcst) isProp) (w: list RWitness) : bool := @tauto_checker (Formula Q) (NFormula Q) unit runsat rdeduce (Rnormalise unit) (Rnegate unit) diff --git a/theories/micromega/RingMicromega.v b/theories/micromega/RingMicromega.v index c5eea752e3..e4dda0ffae 100644 --- a/theories/micromega/RingMicromega.v +++ b/theories/micromega/RingMicromega.v @@ -627,21 +627,6 @@ 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 @@ -655,21 +640,10 @@ end. 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). - (* We normalize Formulas by moving terms to one side *) Definition norm := norm_aux cO cI cplus ctimes cminus copp ceqb. diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index 27b2621475..c59aff0f69 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -14,6 +14,7 @@ (* *) (************************************************************************) +From Stdlib Require Export micromega_formula. From Stdlib Require Import List. From Stdlib Require Import Refl. From Stdlib Require Import Bool. @@ -21,14 +22,6 @@ 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. - Inductive Trace (A : Type) := | null : Trace A | push : A -> Trace A -> Trace A @@ -41,29 +34,7 @@ Section S. 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. @@ -72,7 +43,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) @@ -92,7 +63,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 @@ -118,7 +89,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 @@ -162,31 +133,31 @@ Section S. 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 + match f in micromega_formula.GFormula k' return rtyp 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. Lemma eval_f_rew : forall k (f:GFormula k), eval_f f = - match f in GFormula k' return rtyp k' with + match f in micromega_formula.GFormula k' return rtyp 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. @@ -289,23 +260,12 @@ Section S. End S. - - -(** 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. - -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 diff --git a/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v index 3f546c77d9..dbf4cac858 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -185,7 +185,7 @@ Proof. - rewrite <- Z.gtb_gt; tauto. Qed. -Definition Zeval_op2 (k: Tauto.kind) : Op2 -> Z -> Z -> Tauto.rtyp k:= +Definition Zeval_op2 (k: kind) : Op2 -> Z -> Z -> Tauto.rtyp k:= if k as k0 return (Op2 -> Z -> Z -> Tauto.rtyp k0) then Zeval_pop2 else Zeval_bop2. @@ -199,23 +199,23 @@ 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). -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. @@ -336,7 +336,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'. @@ -440,7 +440,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. @@ -484,7 +484,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. @@ -498,10 +498,10 @@ 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 : TFormula (Formula Z) Annot TX AF k) := rxcnf Zunsat Zdeduce normalise negate true f. -Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z) Tauto.isProp) : bool := +Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z) isProp) : bool := @tauto_checker (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZWitness (fun cl => ZWeakChecker (List.map fst cl)) f w. (* To get a complete checker, the proof format has to be enriched *) @@ -1731,7 +1731,7 @@ Proof. apply Nat.lt_succ_diag_r. Qed. -Definition ZTautoChecker (f : BFormula (Formula Z) Tauto.isProp) (w: list ZArithProof): bool := +Definition ZTautoChecker (f : BFormula (Formula Z) 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. Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_bf (Zeval_formula env) f. diff --git a/theories/micromega/micromega_formula.v b/theories/micromega/micromega_formula.v new file mode 100644 index 0000000000..3f7a59b030 --- /dev/null +++ b/theories/micromega/micromega_formula.v @@ -0,0 +1,112 @@ +(************************************************************************) +(* * The Rocq Prover / The Rocq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* = 9.2 + and use the identical file in Corelib instead *) + +From Stdlib Require Import PosDef. + +Set Implicit Arguments. + +(** 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. + +Variant 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. + +#[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. + +(** Formulae are either interpreted over Prop or bool. *) +Variant kind : Type := isProp | isBool. + +Register isProp as micromega.kind.isProp. +Register isBool as micromega.kind.isBool. + +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. +End S. + +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. + +Definition eKind (k : kind) := if k then Prop else bool. + +Register eKind as micromega.eKind. + +(** Typical boolean formulae *) +Definition BFormula (A : Type) := @GFormula A eKind unit unit. + +Register BFormula as micromega.BFormula.type. From 766bf941af8ad68661aedf54995b6b12fc13adc9 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Sun, 10 Aug 2025 16:03:16 +0200 Subject: [PATCH 08/14] Remove rtyp Was purely redundant with eKind --- theories/micromega/QMicromega.v | 4 +- theories/micromega/RMicromega.v | 6 +-- theories/micromega/Tauto.v | 88 ++++++++++++++++----------------- theories/micromega/ZMicromega.v | 4 +- 4 files changed, 50 insertions(+), 52 deletions(-) diff --git a/theories/micromega/QMicromega.v b/theories/micromega/QMicromega.v index c404f1ae23..d3ce6e6193 100644 --- a/theories/micromega/QMicromega.v +++ b/theories/micromega/QMicromega.v @@ -153,8 +153,8 @@ Proof. - apply Qlt_bool_iff. Qed. -Definition Qeval_op2 (k: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 f852ff689e..c4b9e49251 100644 --- a/theories/micromega/RMicromega.v +++ b/theories/micromega/RMicromega.v @@ -419,8 +419,8 @@ Proof. - apply Rlt_not_le in H. tauto. Qed. -Definition Reval_op2 (k: 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 +526,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 c59aff0f69..7bbc6a14d4 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -98,42 +98,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 micromega_formula.GFormula k' return rtyp k' with + Fixpoint eval_f (k: kind) (f:GFormula k) {struct f}: eKind k := + match f in micromega_formula.GFormula k' return eKind k' with | TT tk => eTT tk | FF tk => eFF tk | A k a _ => ea k a @@ -148,7 +146,7 @@ Section S. Lemma eval_f_rew : forall k (f:GFormula k), eval_f f = - match f in micromega_formula.GFormula k' return rtyp k' with + match f in micromega_formula.GFormula k' return eKind k' with | TT tk => eTT tk | FF tk => eFF tk | A k a _ => ea k a @@ -167,29 +165,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. @@ -237,7 +235,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)). @@ -1672,13 +1670,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. @@ -1754,13 +1752,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. @@ -1810,16 +1808,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. @@ -1849,8 +1847,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 @@ -2012,19 +2010,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 dbf4cac858..4798d374c6 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -185,8 +185,8 @@ Proof. - rewrite <- Z.gtb_gt; tauto. Qed. -Definition Zeval_op2 (k: 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 60f9129c6c0b4e862912a40f93b19d0dea328942 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 6 Aug 2025 11:09:35 +0200 Subject: [PATCH 09/14] Prepare move of micromega_witness.v to Corelib --- theories/micromega/EnvRing.v | 35 +--------- theories/micromega/QMicromega.v | 5 -- theories/micromega/RingMicromega.v | 44 ++++--------- theories/micromega/Tauto.v | 2 +- theories/micromega/ZMicromega.v | 23 +------ theories/micromega/micromega_witness.v | 89 ++++++++++++++++++++++++++ 6 files changed, 106 insertions(+), 92 deletions(-) create mode 100644 theories/micromega/micromega_witness.v diff --git a/theories/micromega/EnvRing.v b/theories/micromega/EnvRing.v index c2d5030217..09dd8095fd 100644 --- a/theories/micromega/EnvRing.v +++ b/theories/micromega/EnvRing.v @@ -11,7 +11,7 @@ For big polynomials, this is inefficient -- linear access. I have modified the code to use binary trees -- logarithmic access. *) -From Stdlib Require Export micromega_formula. +From Stdlib Require Export micromega_formula micromega_witness. From Stdlib Require Import Setoid Morphisms Env BinPos BinNat BinInt. From Stdlib Require Export Ring_theory. @@ -20,39 +20,6 @@ Set Implicit Arguments. #[local] Open Scope positive_scope. Import RingSyntax. - (* 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 *) diff --git a/theories/micromega/QMicromega.v b/theories/micromega/QMicromega.v index d3ce6e6193..5a16ba1095 100644 --- a/theories/micromega/QMicromega.v +++ b/theories/micromega/QMicromega.v @@ -203,11 +203,6 @@ 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. From Stdlib Require Import List. diff --git a/theories/micromega/RingMicromega.v b/theories/micromega/RingMicromega.v index e4dda0ffae..47a8bcc15a 100644 --- a/theories/micromega/RingMicromega.v +++ b/theories/micromega/RingMicromega.v @@ -291,25 +291,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 @@ -365,14 +347,14 @@ Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula | None => None | Some f => eval_Psatz (f::l) p2 end - | PsatzIn n => Some (nth n l (Pc cO, Equal)) + | 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 *) + | PsatzZ _ => Some (Pc cO, Equal) (* Just to make life easier *) end. @@ -508,19 +490,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. @@ -1043,17 +1025,17 @@ Qed. (** Some syntactic simplifications of expressions *) -Definition simpl_cone (e:Psatz) : Psatz := +Definition simpl_cone (e:Psatz C) : Psatz C := 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 @@ -1066,8 +1048,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 diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index 7bbc6a14d4..d6a2b2f67c 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -14,7 +14,7 @@ (* *) (************************************************************************) -From Stdlib Require Export micromega_formula. +From Stdlib Require Export micromega_formula micromega_witness. From Stdlib Require Import List. From Stdlib Require Import Refl. From Stdlib Require Import Bool. diff --git a/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v index 4798d374c6..22f00499a1 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -250,7 +250,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. @@ -558,26 +558,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 -| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof -| ExProof : positive -> ZArithProof -> ZArithProof -(*ExProof x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) -. - - -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 EnumProof as micromega.ZArithProof.EnumProof. -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 diff --git a/theories/micromega/micromega_witness.v b/theories/micromega/micromega_witness.v new file mode 100644 index 0000000000..5939f5524c --- /dev/null +++ b/theories/micromega/micromega_witness.v @@ -0,0 +1,89 @@ +(************************************************************************) +(* * The Rocq Prover / The Rocq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* = 9.2 + and use the identical file in Corelib instead *) + +From Stdlib Require Import BinNums RatDef. + +Set Implicit Arguments. + +(** 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] whose coefficients + are polynomials with [n-1] variables (C[X2..Xn]). + There are several optimisations to make the repr more compact: + - [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. + +Inductive Psatz (C : Type) : Type := +| PsatzLet: Psatz C -> Psatz C -> Psatz C +| PsatzIn : nat -> Psatz C +| PsatzSquare : Pol C -> Psatz C +| PsatzMulC : Pol C -> Psatz C -> Psatz C +| PsatzMulE : Psatz C -> Psatz C -> Psatz C +| PsatzAdd : Psatz C -> Psatz C -> Psatz C +| PsatzC : C -> Psatz C +| PsatzZ : Psatz C. + +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. + +Definition QWitness := Psatz Q. + +Register QWitness as micromega.QWitness.type. + +Definition ZWitness := Psatz Z. + +Inductive ZArithProof := +| DoneProof +| RatProof : ZWitness -> ZArithProof -> ZArithProof +| CutProof : ZWitness -> ZArithProof -> ZArithProof +| SplitProof : Pol Z -> ZArithProof -> ZArithProof -> ZArithProof +| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof +| ExProof : positive -> ZArithProof -> ZArithProof +(*ExProof x : exists z t, x = z - t /\ z >= 0 /\ t >= 0 *) +. + +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 EnumProof as micromega.ZArithProof.EnumProof. +Register ExProof as micromega.ZArithProof.ExProof. From 33f57e0f531fe3778e57de2cc51e34c0339ceecd Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 13 Aug 2025 13:49:04 +0200 Subject: [PATCH 10/14] Prepare move of micromega_tactics.v to Corelib --- theories/micromega/Lia.v | 3 +- theories/micromega/Lqa.v | 3 +- theories/micromega/Lra.v | 3 +- theories/micromega/Psatz.v | 3 +- theories/micromega/micromega_tactics.v | 48 ++++++++++++++++++++++++++ 5 files changed, 52 insertions(+), 8 deletions(-) create mode 100644 theories/micromega/micromega_tactics.v diff --git a/theories/micromega/Lia.v b/theories/micromega/Lia.v index e268cef643..6d423eb683 100644 --- a/theories/micromega/Lia.v +++ b/theories/micromega/Lia.v @@ -17,8 +17,7 @@ From Stdlib Require Import PreOmega ZMicromega RingMicromega VarMap DeclConstantZ. From Stdlib Require Import BinNums. From Stdlib.micromega Require Tauto. -Declare ML Module "rocq-runtime.plugins.micromega_core". -Declare ML Module "rocq-runtime.plugins.micromega". +From Stdlib Require Export micromega_tactics. Ltac zchecker := let __wit := fresh "__wit" in diff --git a/theories/micromega/Lqa.v b/theories/micromega/Lqa.v index f2a71f288d..ea9a1872f8 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 Stdlib Require Export micromega_tactics. Ltac rchange := let __wit := fresh "__wit" in diff --git a/theories/micromega/Lra.v b/theories/micromega/Lra.v index 46f80c5d5a..870eb35802 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 Stdlib Require Export micromega_tactics. Ltac rchange := let __wit := fresh "__wit" in diff --git a/theories/micromega/Psatz.v b/theories/micromega/Psatz.v index 48d7d444fd..e339e0edc4 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 Stdlib Require Export micromega_tactics. Ltac lia := Lia.lia. diff --git a/theories/micromega/micromega_tactics.v b/theories/micromega/micromega_tactics.v new file mode 100644 index 0000000000..ceb913088a --- /dev/null +++ b/theories/micromega/micromega_tactics.v @@ -0,0 +1,48 @@ +(************************************************************************) +(* * The Rocq Prover / The Rocq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* = 9.2 + and use the identical file in Corelib instead *) + +From Stdlib Require Import BinNums RatDef micromega_formula micromega_witness. + +(** This file provide access to the witness generation tactics +of the micromega OCaml plugin. The following tactics are provided, +where [ff : BFormula (Formula Q) isProp]: +- wlra_Q wit ff : set [wit] to a value of type [Psatz Q] +- wlia wit ff : set [wit] to a value of type [ZArithProof] +- wnia wit ff : set [wit] to a value of type [ZArithProof] +- wnra_Q wit ff : set [wit] to a value of type [Psatz Q] +- wsos_Q wit ff : set [wit] to a value of type [Psatz Q] +- wsos_Z wit ff : set [wit] to a value of type [Psatz Z] +- wpsatz_Z wit ff : set [wit] to a value of type [ZArithProof] +- wpsatz_Q wit ff : set [wit] to a value of type [Psatz Q] +The last four require the external Csdp numerical solver. + +Beware that all tactic expect an Ltac name for [wit] and an actual +value for [ff] (not just an identifier). That is, the following works +<< + pose (ff := ...). + let ff' := eval unfold ff in ff in wlra_Q wit ff'. +>> +but not +<< + pose (ff := ...). + wlra_Q wit ff. +>> +See test-suite/micromega/witness_tactics.v for an example. *) + +Declare ML Module "rocq-runtime.plugins.micromega". From 0668e567bce44b40a06baf1f639777b9e0c4f467 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 6 Aug 2025 11:30:04 +0200 Subject: [PATCH 11/14] Prepare move of micromega_checker.v to Corelib --- test-suite/output/MExtraction.v | 1 + theories/micromega/EnvRing.v | 317 +--------- theories/micromega/QMicromega.v | 28 +- theories/micromega/RMicromega.v | 19 +- theories/micromega/RingMicromega.v | 213 +------ theories/micromega/Tauto.v | 222 ++----- theories/micromega/ZMicromega.v | 32 +- theories/micromega/micromega_checker.v | 770 +++++++++++++++++++++++++ 8 files changed, 903 insertions(+), 699 deletions(-) create mode 100644 theories/micromega/micromega_checker.v diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v index a31c993666..55bc55604b 100644 --- a/test-suite/output/MExtraction.v +++ b/test-suite/output/MExtraction.v @@ -18,6 +18,7 @@ Don't forget to update it in Rocq core when editing this MExtraction.v file or MExtraction.out *) +From Stdlib Require Import micromega_checker. From Stdlib Require Extraction. From Stdlib Require Import ZMicromega. From Stdlib Require Import QMicromega. diff --git a/theories/micromega/EnvRing.v b/theories/micromega/EnvRing.v index 09dd8095fd..91d45f5ea9 100644 --- a/theories/micromega/EnvRing.v +++ b/theories/micromega/EnvRing.v @@ -12,6 +12,7 @@ I have modified the code to use binary trees -- logarithmic access. *) From Stdlib Require Export micromega_formula micromega_witness. +From Stdlib Require Export micromega_checker. From Stdlib Require Import Setoid Morphisms Env BinPos BinNat BinInt. From Stdlib Require Export Ring_theory. @@ -103,275 +104,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 @@ -919,9 +679,6 @@ 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 := @@ -949,18 +706,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) -> @@ -971,6 +716,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. @@ -991,20 +738,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. @@ -1053,7 +786,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. diff --git a/theories/micromega/QMicromega.v b/theories/micromega/QMicromega.v index 5a16ba1095..5febdbe2aa 100644 --- a/theories/micromega/QMicromega.v +++ b/theories/micromega/QMicromega.v @@ -203,7 +203,8 @@ Proof. exact (fun env d =>eval_nformula_dec Qsor (fun x => x) env d). Qed. -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. @@ -221,27 +222,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: kind -> Type) (AF: Type) (k: kind) (f: TFormula (Formula Q) Annot TX AF k) := - rxcnf qunsat qdeduce (Qnormalise Annot) (Qnegate Annot) true f. - -Definition QTautoChecker (f : BFormula (Formula Q) 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 c4b9e49251..27cca3f48f 100644 --- a/theories/micromega/RMicromega.v +++ b/theories/micromega/RMicromega.v @@ -489,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. @@ -507,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. - -Definition runsat := check_inconsistent 0%Q Qeq_bool Qle_bool. - -Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool. +#[local] Notation Qcnf_of_GFormula := (Ccnf_of_GFormula + Q0 Q1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool). Definition RTautoChecker (f : BFormula (Formula Rcst) 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. + micromega_checker.tauto_checker (fun cl => RWeakChecker (List.map fst cl)) (Qcnf_of_GFormula (map_bformula (map_Formula Q_of_Rcst) f)) w. Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_bf (Reval_formula env) f. Proof. @@ -544,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 47a8bcc15a..28f6d5ac70 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 *) @@ -299,64 +250,15 @@ Qed. 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' -> @@ -550,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), @@ -582,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), @@ -628,28 +509,12 @@ Definition eval_formula (env : PolEnv) (f : Formula C) : Prop := (* 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 @@ -733,31 +598,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). @@ -793,15 +636,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. @@ -1025,7 +861,7 @@ Qed. (** Some syntactic simplifications of expressions *) -Definition simpl_cone (e:Psatz C) : Psatz C := +Definition simpl_cone (e:Psatz) : Psatz := match e with | PsatzSquare t => match t with @@ -1059,6 +895,11 @@ Definition simpl_cone (e:Psatz C) : Psatz C := 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). (* Local Variables: *) (* coding: utf-8 *) diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index d6a2b2f67c..7fba469a20 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -15,6 +15,7 @@ (************************************************************************) From Stdlib Require Export micromega_formula micromega_witness. +From Stdlib Require Export micromega_checker. From Stdlib Require Import List. From Stdlib Require Import Refl. From Stdlib Require Import Bool. @@ -307,136 +308,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 _. @@ -445,28 +344,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. @@ -1206,13 +1083,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) @@ -1353,6 +1231,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. @@ -1449,14 +1328,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. @@ -1465,7 +1343,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. @@ -1474,7 +1351,6 @@ Section S. { apply is_cnf_tt_inv in F3. subst. - unfold and_cnf. rewrite eval_cnf_app. rewrite eval_cnf_tt. tauto. @@ -1596,9 +1472,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. @@ -1776,7 +1650,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]. @@ -1827,7 +1700,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); @@ -1880,7 +1752,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. @@ -1920,7 +1791,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. @@ -1976,17 +1846,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. @@ -2010,10 +1871,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, @eval_f _ _ _ unit e_eKind (eval env) _ t. Proof. unfold tauto_checker. intros t w H env. @@ -2037,6 +1895,14 @@ Section S. End S. +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 22f00499a1..7c8370348c 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -119,15 +119,11 @@ Fixpoint Zeval_const (e: PExpr Z) : option Z := match e with | PEc c => Some c | PEX x => None - | PEadd e1 e2 => map_option2 (fun x y => Some (x + y)) - (Zeval_const e1) (Zeval_const e2) - | PEmul e1 e2 => map_option2 (fun x y => Some (x * y)) - (Zeval_const e1) (Zeval_const e2) - | PEpow e1 n => map_option (fun x => Some (Z.pow x (Z.of_N n))) - (Zeval_const e1) - | PEsub e1 e2 => map_option2 (fun x y => Some (x - y)) - (Zeval_const e1) (Zeval_const e2) - | PEopp e => map_option (fun x => Some (Z.opp x)) (Zeval_const e) + | 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. @@ -498,11 +494,23 @@ Proof. apply xnegate_correct. Qed. -Definition cnfZ (Annot: Type) (TX : kind -> Type) (AF : Type) (k: 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 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 (Formula Z) (NFormula Z) unit Zunsat Zdeduce normalise negate ZWitness (fun cl => ZWeakChecker (List.map fst cl)) f w. + 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 *) @@ -1713,7 +1721,7 @@ Proof. Qed. Definition ZTautoChecker (f : BFormula (Formula Z) 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. + 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. diff --git a/theories/micromega/micromega_checker.v b/theories/micromega/micromega_checker.v new file mode 100644 index 0000000000..91a465d716 --- /dev/null +++ b/theories/micromega/micromega_checker.v @@ -0,0 +1,770 @@ +(************************************************************************) +(* * The Rocq Prover / The Rocq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* = 9.2 + and use the identical file in Corelib instead *) + +From Stdlib Require Import ListDef BinNums PosDef IntDef RatDef. +From Stdlib Require Export micromega_formula micromega_witness. + +(** This file provides the computational part (checker) of the micromega +tactics. This checker uses the reified formula to be proved +(see micromega_formula.v) and a witness provided, from the formula, +by the micromega OCaml plugin (see micromega_witness.v for the type). +One can prove that if the checker returns true, then the formula holds. +Comments below give indications on how that proof should go. +See test-suite/micromega/witness_tactics.v for an example. *) + +Set Implicit Arguments. + +(** ** A few utility functions +Essentially copied from ssrfun, should probably go in Corelib *) +Definition apply_option aT rT (f : aT -> rT) x u := + match u with Some y => f y | None => x end. +Definition bind_option aT rT (f : aT -> option rT) := apply_option f None. +Definition map_option aT rT (f : aT -> rT) := bind_option (fun x => Some (f x)). +Definition bind_option2 aT a'T rT (f : aT -> a'T -> option rT) o o' := + bind_option (fun o => bind_option (f o) o') o. +Definition map_option2 aT a'T rT (f : aT -> a'T -> rT) := + bind_option2 (fun x y => Some (f x y)). + +(** * Basic arithmetic operations on Horner polynomials [Pol] + +One can prove that an eval function [Peval] commutes with +each operation, e.g., [Peval l (Padd P P') = Peval l P + Peval l P'] *) +Section PolOps. + +(** Coefficients *) +Variable (C : Type) (cO cI : C) (cadd cmul csub : C -> C -> C) (copp : C -> C). +Variable ceqb : C -> C -> bool. + +Implicit Type P : Pol C. + +(** Equality *) +Fixpoint Peq P P' {struct P'} : bool := + match P, P' with + | Pc c, Pc c' => ceqb c c' + | Pinj j Q, Pinj j' Q' => + match Pos.compare j j' with + | Eq => Peq Q Q' + | _ => false + end + | PX P i Q, PX P' i' Q' => + match Pos.compare i i' with + | Eq => if Peq P P' then Peq Q Q' else false + | _ => false + end + | _, _ => false + end. + +(** Constructors *) + +Definition P0 := Pc cO. +Definition P1 := Pc cI. + +Definition mkPinj j P := + match P with + | Pc _ => P + | Pinj j' Q => Pinj (Pos.add 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 mkX j := mkPinj_pred j (PX P1 1 P0). + +Definition mkPX P i Q := + match P with + | Pc c => if ceqb c cO then mkPinj xH Q else PX P i Q + | Pinj _ _ => PX P i Q + | PX P' i' Q' => if Peq Q' P0 then PX P' (Pos.add i' i) Q else PX P i Q + end. + +(** Opposite *) +Fixpoint Popp P : Pol C := + match P with + | Pc c => Pc (copp c) + | Pinj j Q => Pinj j (Popp Q) + | PX P i Q => PX (Popp P) i (Popp Q) + end. + +(** Addition and subtraction *) + +Fixpoint PaddC P c : Pol C := + match P with + | Pc c1 => Pc (cadd c1 c) + | Pinj j Q => Pinj j (PaddC Q c) + | PX P i Q => PX P i (PaddC Q c) + end. + +Fixpoint PsubC P c : Pol C := + match P with + | Pc c1 => Pc (csub 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 C -> Pol C -> Pol C. +Variable Q : Pol C. + +(** [P + Pinj j Q], assuming [Pop . Q] is [. + Q] *) +Fixpoint PaddI (j : positive) P : Pol C := + 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. + +(** [P - Pinj j Q], assuming [Pop . Q] is [. - Q] *) +Fixpoint PsubI (j : positive) P : Pol C := + match P with + | Pc c => mkPinj j (PaddC (Popp 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 C. + +(** [P + PX P' i' P0], assumin [Pop . P'] is [. + P'] *) +Fixpoint PaddX (i' : positive) P : Pol C := + 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. + +(** [P - PX P' i' P0], assumin [Pop . P'] is [. - P'] *) +Fixpoint PsubX (i' : positive) P : Pol C := + match P with + | Pc c => PX (Popp P') i' P + | Pinj j Q' => + match j with + | xH => PX (Popp P') i' Q' + | xO j => PX (Popp P') i' (Pinj (Pos.pred_double j) Q') + | xI j => PX (Popp 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' {struct P'} : Pol C := + 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. + +Fixpoint Psub P P' {struct P'} : Pol C := + 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 (Popp P') i' (PaddC (Popp Q') c) + | Pinj j Q => + match j with + | xH => PX (Popp P') i' (Psub Q Q') + | xO j => PX (Popp P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') + | xI j => PX (Popp 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. + +(** Multiplication *) + +Fixpoint PmulC_aux P c : Pol C := + match P with + | Pc c' => Pc (cmul 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 ceqb c cO then P0 else + if ceqb c cI then P else PmulC_aux P c. + +(** [P * Pinj j Q], assuming [Pmul . Q] is [. * Q] *) +Section PmulI. +Variable Pmul : Pol C -> Pol C -> Pol C. +Variable Q : Pol C. +Fixpoint PmulI (j : positive) P : Pol C := + 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'' {struct P''} : Pol C := + 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 + Padd (mkPX (Padd (mkPX PP' i P0) QP') i' P0) (mkPX PQ' i QQ') + end + end. + +Fixpoint Psquare P : Pol C := + match P with + | Pc c => Pc (cmul c c) + | Pinj j Q => Pinj j (Psquare Q) + | PX P i Q => + let twoPQ := Pmul P (mkPinj xH (PmulC Q (cadd cI cI))) in + let Q2 := Psquare Q in + let P2 := Psquare P in + mkPX (Padd (mkPX P2 i P0) twoPQ) i Q2 + end. + +Fixpoint Ppow_pos (res P : Pol C) (p : positive) : Pol C := + match p with + | xH => Pmul res P + | xO p => Ppow_pos (Ppow_pos res P p) P p + | xI p => Pmul (Ppow_pos (Ppow_pos res P p) P p) P + end. + +Definition Ppow_N P n := match n with N0 => P1 | Npos p => Ppow_pos P1 P p end. + +End PolOps. + +(** * Boolean formulas in Conjunctive Normal Form (CNF) *) +Section CNF. + +(** Type parameters *) +Variable Term : Type. (** literals *) +Variable Annot : Type. (** annotation put on each literal *) + +(** [is_tauto t t' = true] means that [t \/ t'] is true *) +Variable is_tauto : Term -> Term -> bool. + +Definition clause : Type := list (Term * Annot). +Definition cnf : Type := list clause. + +Definition cnf_tt : cnf := nil. +Definition cnf_ff : cnf := nil :: nil. + +Definition is_cnf_tt (f : cnf) : bool := + match f with nil => true | _ => false end. + +Definition is_cnf_ff (f : cnf) : bool := + match f with cons nil nil => true | _ => false end. + +(** Our cnf is optimised, simplifying on the fly the clauses that are true. *) + +(** t \/ cl, [None] means t \/ cl is true *) +Fixpoint add_term (t : Term * Annot) (cl : clause) : option clause := + match cl with + | nil => if is_tauto (fst t) (fst t) then None else Some (t :: nil) + | t' :: cl => + if is_tauto (fst t) (fst t') then None else + match add_term t cl with + | None => None + | Some cl' => Some (t' :: cl') + end + end. + +(** cl1 \/ cl2, [None] means cl1 \/ cl2 is true *) +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. + +(** cl \/ f *) +Definition or_clause_cnf (cl : clause) (f : cnf) : cnf := + match cl with nil => f | _ => + fold_left + (fun acc cl' => + match or_clause cl cl' with + | None => acc + | Some cl'' => cl'' :: acc + end) + f nil + end. + +(** f1 \/ f2 *) +Fixpoint or_cnf_aux (f1 : cnf) (f2 : cnf) {struct f1} : cnf := + match f1 with + | nil => cnf_tt + | cl :: rst => rev_append (or_cnf_aux rst f2) (or_clause_cnf cl f2) + end. + +(** f1 \/ f2 *) +Definition or_cnf (f1 : cnf) (f2 : cnf) : cnf := + if orb (is_cnf_tt f1) (is_cnf_tt f2) then cnf_tt + else if is_cnf_ff f2 then f1 + else or_cnf_aux f1 f2. + +(** f1 /\ f2 *) +Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := + if orb (is_cnf_ff f1) (is_cnf_ff f2) then cnf_ff + else if is_cnf_tt f2 then f1 + else rev_append f1 f2. + +End CNF. + +(** * Normalisation of formulas **) +Section FormulaNormalisation. + +Variable C : Type. +Variables cO cI : C. +Variables cadd cmul csub : C -> C -> C. +Variable copp : C -> C. +Variables ceqb cleb : C -> C -> bool. + +Definition cneqb (x y : C) := negb (ceqb x y). +Definition cltb (x y : C) := andb (cleb x y) (cneqb x y). + +Variant Op1 : Set := (** relations with 0 *) +| Equal (** == 0 *) +| NonEqual (** ~= 0 *) +| Strict (** > 0 *) +| NonStrict (** >= 0 *). + +Definition NFormula : Type := Pol C * Op1. (** normalized formula *) + +#[local] Notation mkX := (mkX cO cI). +#[local] Notation Popp := (Popp copp). +#[local] Notation Padd := (Padd cO cadd ceqb). +#[local] Notation Psub := (Psub cO cadd csub copp ceqb). +#[local] Notation Pmul := (Pmul cO cI cadd cmul ceqb). +#[local] Notation Ppow_N := (Ppow_N cO cI cadd cmul ceqb). + +Fixpoint Pol_of_PExpr (pe : PExpr C) : Pol C := + match pe with + | PEc c => Pc c + | PEX j => mkX j + | PEadd (PEopp pe1) pe2 => Psub (Pol_of_PExpr pe2) (Pol_of_PExpr pe1) + | PEadd pe1 (PEopp pe2) => Psub (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) + | PEadd pe1 pe2 => Padd (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) + | PEsub pe1 pe2 => Psub (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) + | PEmul pe1 pe2 => Pmul (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) + | PEopp pe1 => Popp (Pol_of_PExpr pe1) + | PEpow pe1 n => Ppow_N (Pol_of_PExpr pe1) n + end. + +(** We normalize Formulas by moving terms to one side *) +Definition normalise (f : Formula C) : NFormula := + let (lhs, op, rhs) := f in + let lhs := Pol_of_PExpr lhs in + let rhs := Pol_of_PExpr 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. + +(** Check that a normalised formula f is inconsistent +by comparing the normalised 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 => cltb c cO + | Strict => cleb c cO + | NonEqual => ceqb c cO + end + | _ => false (** not a constant *) + end. + +(** Normalisation to CNF + +This removes the non convex operator [NonEqual] and negates the formula. +We will later need the negated literals, so we can just as well have the CNF +contain negated lterals yet (as misleading as it can be). +Thus we later denote [eval_cnf (fun g => ~ NFeval l g)] the eval function +for CNFs (where [NFeval l g] evaluates literal [g] in environment [l]). *) + +(** Normalise and negate the formula +[forall T (tg : T) l f, + eval_cnf (fun g => ~ NFeval l g) (map (fun nf => (nf, tg)) (normalise_aux f)) + <-> NFeval l f] *) +Definition normalise_aux (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. + +(** Normalise and negate twice the formula (so actually doesn't negate anything) +[forall T (tg : T) l f, + eval_cnf (fun g => ~ NFeval l g) (map (fun nf => (nf, tg)) (normalise_aux f)) + <-> ~ NFeval l f] *) +Definition negate_aux (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. + +(** [forall T (tg : T) l f, + eval_cnf (fun g => ~ NFeval l g) (cnf_of_list f tg) + <-> eval_cnf (fun g => ~ NFeval l g) (map (fun g => (g, tg)) f)] *) +Definition cnf_of_list {T : Type} (l : list NFormula) (tg : T) : + cnf NFormula T := + fold_right + (fun x acc => + if check_inconsistent x then acc else ((x, tg) :: nil) :: acc) + (cnf_tt _ _) l. + +(** [forall T (tg : T) l f, + eval_cnf (fun g => ~ NFeval l g) (cnf_normalise f tg) <-> Feval l f] *) +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 (normalise_aux f) tg. + +(** [forall T (tg : T) l f, + eval_cnf (fun g => ~ NFeval l g) (cnf_negate f tg) <-> ~ Feval l f] *) +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 (negate_aux f) tg. + +End FormulaNormalisation. + +(** * Normalise input [GFormula] as CNF whose literals are [NFormula] *) +Section GFormulaNormalisation. + +(** Type parameters *) +Variable Term : Type. (** literals of non normalized formulas *) +Variable Annot : Type. (** annotation put on each literal *) + +Variable cnf : Type. (** Type of normalised formulas *) +Variable cnf_tt : cnf. +Variable cnf_ff : cnf. +Variable or_cnf : cnf -> cnf -> cnf. +Variable and_cnf : cnf -> cnf -> cnf. + +Variable normalise : Term -> Annot -> cnf. +Variable negate : Term -> Annot -> cnf. + +Section REC. +Context {TX : kind -> Type} {AF : Type}. +(** The formulas we are normalizing +- TX is Prop in Rocq and EConstr.constr in Ocaml. +- AF is unit in Rocq and Names.Id.t in Ocaml *) +#[local] Notation TFormula := (@GFormula Term TX Annot AF). + +(** Normalisation function, if [pol] is false, produces the negation *) +Variable REC : forall (pol : bool) (k : kind) (f : TFormula k), cnf. + +Definition mk_and (k : kind) (pol : bool) (f1 f2 : TFormula k) := + (if pol then and_cnf else or_cnf) (REC pol f1) (REC pol f2). + +Definition mk_or (k : kind) (pol : bool) (f1 f2 : TFormula k) := + (if pol then or_cnf else and_cnf) (REC pol f1) (REC pol f2). + +Definition mk_impl (k : kind) (pol : bool) (f1 f2 : TFormula k) := + (if pol then or_cnf else and_cnf) (REC (negb pol) f1) (REC pol f2). + +Definition mk_iff (k : kind) (pol : bool) (f1 f2 : TFormula k) := + or_cnf (and_cnf (REC (negb pol) f1) (REC false f2)) + (and_cnf (REC pol f1) (REC true f2)). +End REC. + +Definition is_bool {TX : kind -> Type} {AF : Type} (k : kind) + (f : @GFormula Term TX Annot AF k) := + match f with + | TT _ => Some true + | FF _ => Some false + | _ => None + end. + +(** Normalisation function, if [pol] is false, produces the negation +Assuming [is_tauto_correct : forall l (f g : NFormula rat), + is_tauto f g -> ~ NFeval l f \/ ~ NFeval l g] +we have [forall l pol k (f : GFormula k), + eval_cnf (fun g => ~ NFeval l g) (@cnf_of_GFormula eKind unit pol k f) -> + (if pol then id else not) (GFeval Feval l f)]*) +Fixpoint cnf_of_GFormula {TX : kind -> Type} {AF : Type} (pol : bool) (k : kind) + (f : @GFormula Term TX Annot 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 + | AND e1 e2 => mk_and cnf_of_GFormula pol e1 e2 + | OR e1 e2 => mk_or cnf_of_GFormula pol e1 e2 + | NOT e => cnf_of_GFormula (negb pol) e + | IMPL e1 _ e2 => mk_impl cnf_of_GFormula pol e1 e2 + | IFF e1 e2 => + match is_bool e2 with + | Some isb => cnf_of_GFormula (if isb then pol else negb pol) e1 + | None => mk_iff cnf_of_GFormula pol e1 e2 + end + | EQ e1 e2 => + match is_bool e2 with + | Some isb => cnf_of_GFormula (if isb then pol else negb pol) e1 + | None => mk_iff cnf_of_GFormula pol e1 e2 + end + end. + +End GFormulaNormalisation. + +(** * Core of the checker, checking individual literals *) +Section FormulaChecker. + +Variable C : Type. +Variables cO cI : C. +Variables cplus ctimes cminus: C -> C -> C. +Variable copp : C -> C. +Variables ceqb cleb : C -> C -> bool. + +#[local] Notation NFormula := (NFormula C). + +(** Rule of "signs" for multiplication and addition. +An arbitrary result is coded by None. *) + +Definition OpMult (o o' : Op1) : option Op1 := + match o, o' with + | Equal, _ | _, Equal => Some Equal + | NonEqual, _ | _, NonEqual => None (** NonEqual no longer present here *) + | Strict, _ => Some o' + | _, Strict => Some o + | NonStrict, NonStrict => Some NonStrict + end. + +Definition OpAdd (o o': Op1) : option Op1 := + match o, o' with + | Equal, _ => Some o' + | _, Equal => Some o + | NonEqual, _ | _, NonEqual => None + | Strict, _ | _, Strict => Some Strict + | NonStrict, NonStrict => Some NonStrict + end. + +(** Given a list [l] of NFormula and an extended polynomial expression [e], +if [eval_Psatz l e] succeeds (= Some f) then [f] is a logic consequence +of the conjunction of the formulas in l. +Moreover, the polynomial expression is obtained by replacing the +(PsatzIn n) by the nth polynomial expression in [l] and the sign is +computed by the "rule of sign". *) + +(** [forall l e f f', NFeval l f -> +pexpr_times_nformula e f = Some f' -> NFeval l f'] *) +Definition pexpr_times_nformula (e : Pol C) (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. + +(** [forall l f f' f'', NFeval l f -> NFeval l f' -> +nformula_times_nformula f f' = Some f'' -> NFeval l f''] *) +Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula := + let (e1, o1) := f1 in + let (e2, o2) := f2 in + map_option (fun x => (Pmul cO cI cplus ctimes ceqb e1 e2, x)) (OpMult o1 o2). + +(** [forall l f f' f'', NFeval l f -> NFeval l f' -> +nformula_plus_nformula f f' = Some f'' -> NFeval l f''] *) +Definition nformula_plus_nformula (f1 f2 : NFormula) : option NFormula := + let (e1, o1) := f1 in + let (e2, o2) := f2 in + map_option (fun x => (Padd cO cplus ceqb e1 e2, x)) (OpAdd o1 o2). + +(** [forall l f g, is_tauto f g -> ~ NFeval l f \/ ~ NFeval l g] *) +Definition is_tauto (f1 f2 : NFormula) : bool := + match nformula_plus_nformula f1 f2 with + | None => false + | Some u => check_inconsistent cO ceqb cleb u + end. + +(** [forall l (lf : list (NFormula C)) (w : Psatz C), all (NFeval l) lf -> +forall f : NFormula C, eval_Psatz lf w = Some f -> NFeval l f] *) +Fixpoint eval_Psatz (l : list NFormula) (e : Psatz C) {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 => bind_option (pexpr_times_nformula re) (eval_Psatz l e) + | PsatzMulE f1 f2 => + bind_option2 nformula_times_nformula (eval_Psatz l f1) (eval_Psatz l f2) + | PsatzAdd f1 f2 => + bind_option2 nformula_plus_nformula (eval_Psatz l f1) (eval_Psatz l f2) + | PsatzC c => if cltb ceqb cleb cO c then Some (Pc c, Strict) else None + (** This could also handle 0, or <> 0 -- but these cases are useless *) + | PsatzZ _ => Some (Pc cO, Equal) (** Just to make life easier *) + end. + +(** [forall l (lf : list (NFormula C)) (w : Psatz C), +check_normalised_formulas lf w -> has (fun f => ~ NFeval l f) lf] *) +Definition check_normalised_formulas (l : list NFormula) (cm : Psatz C) : + bool := + match eval_Psatz l cm with + | None => false + | Some f => check_inconsistent cO ceqb cleb f + end. + +End FormulaChecker. + +(** * The checker itself, checking entire CNF formulas *) +Section TautoChecker. + +(** Type parameters *) +Variable clause : Type. (** normalised clauses *) +Variable Witness : Type. + +Variable checker : clause -> Witness -> bool. + +Fixpoint cnf_checker (f : list clause) (wl : list Witness) {struct f} : bool := + match f with + | nil => true + | cl :: f => + match wl with + | nil => false + | w :: wl => andb (checker cl w) (cnf_checker f wl) + end + end. + +(** [forall l (f : cnf (NFormula C) unit) (w : seq (Psatz C)), +tauto_checker f w -> eval_cnf (fun g => ~ NFeval l g) f] *) +Definition tauto_checker (f : list clause) (w : list Witness) : bool := + cnf_checker f w. + +End TautoChecker. + +(** * Putting everything together *) +Section CTautoChecker. +Variable C : Type. +Variables (cO cI : C) (cadd cmul csub : C -> C -> C) (copp : C -> C). +Variables ceqb cleb : C -> C -> bool. + +Definition CWeakChecker := check_normalised_formulas cO cI cadd cmul ceqb cleb. +Definition Cnormalise := @cnf_normalise C cO cI cadd cmul csub copp ceqb cleb. +Definition Cnegate := @cnf_negate C cO cI cadd cmul csub copp ceqb cleb. +Definition Cis_tauto := @is_tauto C cO cadd ceqb cleb. + +Definition Ccnf_of_GFormula := @cnf_of_GFormula _ _ _ + (cnf_tt _ _) (cnf_ff _ _) (or_cnf Cis_tauto) (@and_cnf _ _) + (@Cnormalise unit) (@Cnegate unit) eKind unit true isProp. + +(** [forall l f w : CTautoChecker f w -> GFeval Feval l f] *) +Definition CTautoChecker (f : BFormula (Formula C) isProp) : + list (Psatz C) -> bool := + tauto_checker (fun cl => CWeakChecker (map fst cl)) (Ccnf_of_GFormula f). + +End CTautoChecker. + +(** Instantiate on Q *) +Definition QTautoChecker := CTautoChecker + Q0 Q1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. From 05ea29553bd63a741abcc0eee30769e3c12167fe Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Sun, 10 Aug 2025 15:57:33 +0200 Subject: [PATCH 12/14] Prepare move of micromega_eval.v to Corelib --- test-suite/output/MExtraction.out | 3306 ++++++++++++++------------- test-suite/output/MExtraction.v | 4 +- theories/micromega/EnvRing.v | 17 +- theories/micromega/QMicromega.v | 34 +- theories/micromega/RMicromega.v | 6 +- theories/micromega/RingMicromega.v | 46 +- theories/micromega/Tauto.v | 85 +- theories/micromega/ZMicromega.v | 22 +- theories/micromega/micromega_eval.v | 181 ++ 9 files changed, 1941 insertions(+), 1760 deletions(-) create mode 100644 theories/micromega/micromega_eval.v diff --git a/test-suite/output/MExtraction.out b/test-suite/output/MExtraction.out index 7a08d63147..3e126a4ea6 100644 --- a/test-suite/output/MExtraction.out +++ b/test-suite/output/MExtraction.out @@ -57,43 +57,6 @@ module Coq__1 = struct 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 @@ -123,17 +86,17 @@ module Pos = match x with | XI p -> (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) + | XI q2 -> XO (add_carry p q2) + | XO q2 -> XI (add p q2) | XH -> XO (succ p)) | XO p -> (match y with - | XI q0 -> XI (add p q0) - | XO q0 -> XO (add p q0) + | XI q2 -> XI (add p q2) + | XO q2 -> XO (add p q2) | XH -> XI p) | XH -> (match y with - | XI q0 -> XO (succ q0) - | XO q0 -> XI q0 + | XI q2 -> XO (succ q2) + | XO q2 -> XI q2 | XH -> XO XH) (** val add_carry : positive -> positive -> positive **) @@ -142,18 +105,18 @@ module Pos = match x with | XI p -> (match y with - | XI q0 -> XI (add_carry p q0) - | XO q0 -> XO (add_carry p q0) + | XI q2 -> XI (add_carry p q2) + | XO q2 -> XO (add_carry p q2) | XH -> XI (succ p)) | XO p -> (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) + | XI q2 -> XO (add_carry p q2) + | XO q2 -> XI (add p q2) | XH -> XO (succ p)) | XH -> (match y with - | XI q0 -> XI (succ q0) - | XO q0 -> XO (succ q0) + | XI q2 -> XI (succ q2) + | XO q2 -> XO (succ q2) | XH -> XI XH) (** val pred_double : positive -> positive **) @@ -189,13 +152,13 @@ module Pos = match x with | XI p -> (match y with - | XI q0 -> compare_cont r p q0 - | XO q0 -> compare_cont Gt p q0 + | XI q2 -> compare_cont r p q2 + | XO q2 -> compare_cont Gt p q2 | XH -> Gt) | XO p -> (match y with - | XI q0 -> compare_cont Lt p q0 - | XO q0 -> compare_cont r p q0 + | XI q2 -> compare_cont Lt p q2 + | XO q2 -> compare_cont r p q2 | XH -> Gt) | XH -> (match y with | XH -> r @@ -208,15 +171,15 @@ module Pos = (** val eqb : positive -> positive -> bool **) - let rec eqb p q0 = + let rec eqb p q2 = match p with - | XI p2 -> (match q0 with - | XI q1 -> eqb p2 q1 + | XI p2 -> (match q2 with + | XI q3 -> eqb p2 q3 | _ -> false) - | XO p2 -> (match q0 with - | XO q1 -> eqb p2 q1 + | XO p2 -> (match q2 with + | XO q3 -> eqb p2 q3 | _ -> false) - | XH -> (match q0 with + | XH -> (match q2 with | XH -> true | _ -> false) @@ -227,520 +190,369 @@ module Pos = | 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 **) +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 - 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) +type op2 = +| OpEq +| OpNEq +| OpLe +| OpGe +| OpLt +| OpGt - (** val add_carry : positive -> positive -> positive **) +type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } - 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) +type kind = +| IsProp +| IsBool - (** val pred_double : positive -> positive **) +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 - let rec pred_double = function - | XI p -> XI (XO p) - | XO p -> XI (pred_double p) - | XH -> XH +type eKind = __ - type mask = Pos.mask = - | IsNul - | IsPos of positive - | IsNeg +type 'a bFormula = ('a, eKind, unit0, unit0) gFormula - (** val succ_double_mask : mask -> mask **) +module Z = + struct + (** val double : z -> z **) - let succ_double_mask = function - | IsNul -> IsPos XH - | IsPos p -> IsPos (XI p) - | IsNeg -> IsNeg + let double = function + | Z0 -> Z0 + | Zpos p -> Zpos (XO p) + | Zneg p -> Zneg (XO p) - (** val double_mask : mask -> mask **) + (** val succ_double : z -> z **) - let double_mask = function - | IsPos p -> IsPos (XO p) - | x0 -> x0 + let succ_double = function + | Z0 -> Zpos XH + | Zpos p -> Zpos (XI p) + | Zneg p -> Zneg (Pos.pred_double p) - (** val double_pred_mask : positive -> mask **) + (** val pred_double : z -> z **) - let double_pred_mask = function - | XI p -> IsPos (XO (XO p)) - | XO p -> IsPos (XO (pred_double p)) - | XH -> IsNul + let pred_double = function + | Z0 -> Zneg XH + | Zpos p -> Zpos (Pos.pred_double p) + | Zneg p -> Zneg (XI p) - (** val sub_mask : positive -> positive -> mask **) + (** val pos_sub : positive -> positive -> z **) - let rec sub_mask x y = + let rec pos_sub 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)) + | XI q2 -> double (pos_sub p q2) + | XO q2 -> succ_double (pos_sub p q2) + | XH -> Zpos (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) + | XI q2 -> pred_double (pos_sub p q2) + | XO q2 -> double (pos_sub p q2) + | XH -> Zpos (Pos.pred_double p)) + | XH -> + (match y with + | XI q2 -> Zneg (XO q2) + | XO q2 -> Zneg (Pos.pred_double q2) + | XH -> Z0) - (** val sub_mask_carry : positive -> positive -> mask **) + (** val add : z -> z -> z **) - and sub_mask_carry x y = + let add x y = match x with - | XI p -> + | Z0 -> y + | Zpos x' -> (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 -> + | Z0 -> x + | Zpos y' -> Zpos (Pos.add x' y') + | Zneg y' -> pos_sub x' y') + | Zneg x' -> (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 + | Z0 -> x + | Zpos y' -> pos_sub y' x' + | Zneg y' -> Zneg (Pos.add x' y')) - (** val mul : positive -> positive -> positive **) + (** val opp : z -> z **) - let rec mul x y = - match x with - | XI p -> add y (XO (mul p y)) - | XO p -> XO (mul p y) - | XH -> y + let opp = function + | Z0 -> Z0 + | Zpos x0 -> Zneg x0 + | Zneg x0 -> Zpos x0 - (** val compare_cont : comparison -> positive -> positive -> comparison **) + (** val mul : z -> z -> z **) - let rec compare_cont r x y = + let mul x y = match x with - | XI p -> + | Z0 -> Z0 + | Zpos x' -> (match y with - | XI q0 -> compare_cont r p q0 - | XO q0 -> compare_cont Gt p q0 - | XH -> Gt) - | XO p -> + | Z0 -> Z0 + | Zpos y' -> Zpos (Pos.mul x' y') + | Zneg y' -> Zneg (Pos.mul x' y')) + | Zneg x' -> (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) + | Z0 -> Z0 + | Zpos y' -> Zneg (Pos.mul x' y') + | Zneg y' -> Zpos (Pos.mul x' y')) - (** val compare : positive -> positive -> comparison **) + (** val compare : z -> z -> comparison **) - let compare = - compare_cont Eq + 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 : positive -> positive -> bool **) + (** val leb : z -> z -> 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 eqb : z -> z -> bool **) - (** val max : positive -> positive -> positive **) + let eqb x y = + match x with + | Z0 -> (match y with + | Z0 -> true + | _ -> false) + | Zpos p -> (match y with + | Zpos q2 -> Pos.eqb p q2 + | _ -> false) + | Zneg p -> (match y with + | Zneg q2 -> Pos.eqb p q2 + | _ -> false) + end - let max p p' = - match compare p p' with - | Gt -> p - | _ -> p' +type q = { qnum : z; qden : positive } - (** val gcdn : nat -> positive -> positive -> positive **) +(** val qeq_bool : q -> q -> bool **) - 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 qeq_bool x y = + Z.eqb (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) - let gcd a b = - gcdn (Coq__1.add (size_nat a) (size_nat b)) a b - end +(** val qle_bool : q -> q -> bool **) -module N = - struct - (** val of_nat : nat -> n **) +let qle_bool x y = + Z.leb (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) - let of_nat = function - | O -> N0 - | S n' -> Npos (Pos.of_succ_nat n') - end +(** val qplus : q -> q -> q **) -(** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) +let qplus x y = + { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))); + qden = (Pos.mul x.qden y.qden) } -let rec pow_pos rmul x = function -| XI i0 -> let p = pow_pos rmul x i0 in rmul x (rmul p p) -| XO i0 -> let p = pow_pos rmul x i0 in rmul p p -| XH -> x +(** val qmult : q -> q -> q **) -module Z = - struct - (** val double : z -> z **) +let qmult x y = + { qnum = (Z.mul x.qnum y.qnum); qden = (Pos.mul x.qden y.qden) } - let double = function - | Z0 -> Z0 - | Zpos p -> Zpos (XO p) - | Zneg p -> Zneg (XO p) +(** val qopp : q -> q **) - (** val succ_double : z -> z **) +let qopp x = + { qnum = (Z.opp x.qnum); qden = x.qden } - let succ_double = function - | Z0 -> Zpos XH - | Zpos p -> Zpos (XI p) - | Zneg p -> Zneg (Pos.pred_double p) +(** val qminus : q -> q -> q **) - (** val pred_double : z -> z **) +let qminus x y = + qplus x (qopp y) - let pred_double = function - | Z0 -> Zneg XH - | Zpos p -> Zpos (Pos.pred_double p) - | Zneg p -> Zneg (XI p) +(** val q0 : q **) - (** val pos_sub : positive -> positive -> z **) +let q0 = + { qnum = Z0; qden = XH } - 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 q1 : q **) - (** val add : z -> z -> z **) +let q1 = + { qnum = (Zpos XH); qden = XH } - 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')) +type 'c pol = +| Pc of 'c +| Pinj of positive * 'c pol +| PX of 'c pol * positive * 'c pol - (** val opp : z -> z **) +type 'c psatz = +| PsatzLet of 'c psatz * 'c psatz +| PsatzIn of nat +| PsatzSquare of 'c pol +| PsatzMulC of 'c pol * 'c psatz +| PsatzMulE of 'c psatz * 'c psatz +| PsatzAdd of 'c psatz * 'c psatz +| PsatzC of 'c +| PsatzZ - let opp = function - | Z0 -> Z0 - | Zpos x0 -> Zneg x0 - | Zneg x0 -> Zpos x0 +type zWitness = z psatz - (** val sub : z -> z -> z **) +type zArithProof = +| DoneProof +| RatProof of zWitness * zArithProof +| CutProof of zWitness * zArithProof +| SplitProof of z pol * zArithProof * zArithProof +| EnumProof of zWitness * zWitness * zArithProof list +| ExProof of positive * zArithProof - let sub m n0 = - add m (opp n0) +(** val pEmap : ('a1 -> 'a2) -> 'a1 pExpr -> 'a2 pExpr **) - (** val mul : z -> z -> z **) +let rec pEmap f = function +| PEc c -> PEc (f c) +| PEX p -> PEX p +| PEadd (e1, e2) -> PEadd ((pEmap f e1), (pEmap f e2)) +| PEsub (e1, e2) -> PEsub ((pEmap f e1), (pEmap f e2)) +| PEmul (e1, e2) -> PEmul ((pEmap f e1), (pEmap f e2)) +| PEopp e0 -> PEopp (pEmap f e0) +| PEpow (e0, n0) -> PEpow ((pEmap f e0), n0) - 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 fmap : ('a1 -> 'a2) -> 'a1 formula -> 'a2 formula **) - (** val pow_pos : z -> positive -> z **) +let fmap f f0 = + let { flhs = l; fop = o; frhs = r } = f0 in + { flhs = (pEmap f l); fop = o; frhs = (pEmap f r) } - let pow_pos z0 = - Pos.iter (mul z0) (Zpos XH) +(** val gFmap : + kind -> ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, + 'a5) gFormula **) - (** val pow : z -> z -> z **) +let rec gFmap _ 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, (gFmap k0 fct f1), (gFmap k0 fct f2)) +| OR (k0, f1, f2) -> OR (k0, (gFmap k0 fct f1), (gFmap k0 fct f2)) +| NOT (k0, f0) -> NOT (k0, (gFmap k0 fct f0)) +| IMPL (k0, f1, a, f2) -> IMPL (k0, (gFmap k0 fct f1), a, (gFmap k0 fct f2)) +| IFF (k0, f1, f2) -> IFF (k0, (gFmap k0 fct f1), (gFmap k0 fct f2)) +| EQ (f1, f2) -> EQ ((gFmap IsBool fct f1), (gFmap IsBool fct f2)) - let pow x = function - | Z0 -> Zpos XH - | Zpos p -> pow_pos x p - | Zneg _ -> Z0 +(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) - (** val compare : z -> z -> comparison **) +let rec map f = function +| [] -> [] +| a::l0 -> (f a)::(map f l0) - 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 nth : nat -> 'a1 list -> 'a1 -> 'a1 **) - (** val leb : z -> z -> bool **) +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) - let leb x y = - match compare x y with - | Gt -> false - | _ -> true +(** val rev_append : 'a1 list -> 'a1 list -> 'a1 list **) - (** val ltb : z -> z -> bool **) +let rec rev_append l l' = + match l with + | [] -> l' + | a::l0 -> rev_append l0 (a::l') - let ltb x y = - match compare x y with - | Lt -> true - | _ -> false +(** val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 **) - (** val eqb : z -> z -> bool **) +let rec fold_left f l a0 = + match l with + | [] -> a0 + | b::l0 -> fold_left f l0 (f a0 b) - 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 fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) - (** val max : z -> z -> z **) +let rec fold_right f a0 = function +| [] -> a0 +| b::l0 -> f b (fold_right f a0 l0) - let max n0 m = - match compare n0 m with - | Lt -> m - | _ -> n0 +(** val apply_option : ('a1 -> 'a2) -> 'a2 -> 'a1 option -> 'a2 **) - (** val of_nat : nat -> z **) +let apply_option f x = function +| Some y -> f y +| None -> x - let of_nat = function - | O -> Z0 - | S n1 -> Zpos (Pos.of_succ_nat n1) +(** val bind_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **) - (** val of_N : n -> z **) +let bind_option f = + apply_option f None - let of_N = function - | N0 -> Z0 - | Npos p -> Zpos p +(** val map_option : ('a1 -> 'a2) -> 'a1 option -> 'a2 option **) - (** val pos_div_eucl : positive -> z -> z * z **) +let map_option f = + bind_option (fun x -> Some (f x)) - 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 bind_option2 : + ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **) - (** val div_eucl : z -> z -> z * z **) +let bind_option2 f o o' = + bind_option (fun o0 -> bind_option (f o0) o') o - 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 map_option2 : + ('a1 -> 'a2 -> 'a3) -> 'a1 option -> 'a2 option -> 'a3 option **) - (** val div : z -> z -> z **) +let map_option2 f = + bind_option2 (fun x y -> Some (f x y)) - 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 - -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 **) +(** 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) -> + | Pinj (j, q2) -> (match p' with | Pinj (j', q') -> - (match Coq_Pos.compare j j' with - | Eq -> peq ceqb q0 q' + (match Pos.compare j j' with + | Eq -> peq ceqb q2 q' | _ -> false) | _ -> false) - | PX (p2, i, q0) -> + | PX (p2, i, q2) -> (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 + (match Pos.compare i i' with + | Eq -> if peq ceqb p2 p'0 then peq ceqb q2 q' else false | _ -> false) | _ -> false) +(** val p0 : 'a1 -> 'a1 pol **) + +let p0 cO = + Pc cO + +(** val p1 : 'a1 -> 'a1 pol **) + +let p1 cI = + Pc cI + (** 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) +| Pinj (j', q2) -> Pinj ((Pos.add j j'), q2) | PX (_, _, _) -> Pinj (j, p) (** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) @@ -748,87 +560,80 @@ let mkPinj j p = match p with let mkPinj_pred j p = match j with | XI j0 -> Pinj ((XO j0), p) - | XO j0 -> Pinj ((Coq_Pos.pred_double j0), p) + | XO j0 -> Pinj ((Pos.pred_double j0), p) | XH -> p +(** val mkX : 'a1 -> 'a1 -> positive -> 'a1 pol **) + +let mkX cO cI j = + mkPinj_pred j (PX ((p1 cI), XH, (p0 cO))) + (** val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) -let mkPX cO ceqb p i q0 = +let mkPX cO ceqb p i q2 = match p with - | Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0) - | Pinj (_, _) -> PX (p, i, q0) + | Pc c -> if ceqb c cO then mkPinj XH q2 else PX (p, i, q2) + | Pinj (_, _) -> PX (p, i, q2) | 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 + if peq ceqb q' (p0 cO) then PX (p', (Pos.add i' i), q2) else PX (p, i, q2) (** 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)) +| Pinj (j, q2) -> Pinj (j, (popp copp q2)) +| PX (p2, i, q2) -> PX ((popp copp p2), i, (popp copp q2)) (** 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)) + | Pinj (j, q2) -> Pinj (j, (paddC cadd q2 c)) + | PX (p2, i, q2) -> PX (p2, i, (paddC cadd q2 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)) + | Pinj (j, q2) -> Pinj (j, (psubC csub q2 c)) + | PX (p2, i, q2) -> PX (p2, i, (psubC csub q2 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) +let rec paddI cadd pop q2 j = function +| Pc c -> mkPinj j (paddC cadd q2 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')) + | Z0 -> mkPinj j (pop q' q2) + | Zpos k -> mkPinj j (pop (Pinj (k, q')) q2) + | Zneg k -> mkPinj j' (paddI cadd pop q2 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))) + | XI j0 -> PX (p2, i, (paddI cadd pop q2 (XO j0) q')) + | XO j0 -> PX (p2, i, (paddI cadd pop q2 (Pos.pred_double j0) q')) + | XH -> PX (p2, i, (pop q' q2))) (** 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) +let rec psubI cadd copp pop q2 j = function +| Pc c -> mkPinj j (paddC cadd (popp copp q2) 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')) + | Z0 -> mkPinj j (pop q' q2) + | Zpos k -> mkPinj j (pop (Pinj (k, q')) q2) + | Zneg k -> mkPinj j' (psubI cadd copp pop q2 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))) + | XI j0 -> PX (p2, i, (psubI cadd copp pop q2 (XO j0) q')) + | XO j0 -> PX (p2, i, (psubI cadd copp pop q2 (Pos.pred_double j0) q')) + | XH -> PX (p2, i, (pop q' q2))) (** val paddX : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol @@ -839,7 +644,7 @@ let rec paddX cO ceqb pop p' i' p = match p with | 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'))) + | XO j0 -> PX (p', i', (Pinj ((Pos.pred_double j0), q'))) | XH -> PX (p', i', q')) | PX (p2, i, q') -> (match Z.pos_sub i i' with @@ -856,7 +661,7 @@ let rec psubX cO copp ceqb pop p' i' p = match p with | 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'))) + | XO j0 -> PX ((popp copp p'), i', (Pinj ((Pos.pred_double j0), q'))) | XH -> PX ((popp copp p'), i', q')) | PX (p2, i, q') -> (match Z.pos_sub i i' with @@ -874,23 +679,22 @@ let rec padd cO cadd ceqb p = function | PX (p'0, i', q') -> (match p with | Pc c -> PX (p'0, i', (paddC cadd q' c)) - | Pinj (j, q0) -> + | Pinj (j, q2) -> (match j with - | XI j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((XO j0), q0)) q')) + | XI j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((XO j0), q2)) 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) -> + PX (p'0, i', (padd cO cadd ceqb (Pinj ((Pos.pred_double j0), q2)) q')) + | XH -> PX (p'0, i', (padd cO cadd ceqb q2 q'))) + | PX (p2, i, q2) -> (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') + mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q2 q') | Zpos k -> mkPX cO ceqb (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' - (padd cO cadd ceqb q0 q') + (padd cO cadd ceqb q2 q') | Zneg k -> mkPX cO ceqb (paddX cO ceqb (padd cO cadd ceqb) p'0 k p2) i - (padd cO cadd ceqb q0 q'))) + (padd cO cadd ceqb q2 q'))) (** val psub : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 @@ -902,28 +706,27 @@ let rec psub cO cadd csub copp ceqb p = function | 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) -> + | Pinj (j, q2) -> (match j with | XI j0 -> PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) + (psub cO cadd csub copp ceqb (Pinj ((XO j0), q2)) 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) -> + (psub cO cadd csub copp ceqb (Pinj ((Pos.pred_double j0), q2)) q')) + | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q2 q'))) + | PX (p2, i, q2) -> (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') + (psub cO cadd csub copp ceqb q2 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') + i' (psub cO cadd csub copp ceqb q2 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'))) + (psub cO cadd csub copp ceqb q2 q'))) (** val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> @@ -932,9 +735,9 @@ let rec psub cO cadd csub copp ceqb p = function 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) + | Pinj (j, q2) -> mkPinj j (pmulC_aux cO cmul ceqb q2 c) + | PX (p2, i, q2) -> + mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i (pmulC_aux cO cmul ceqb q2 c) (** val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> @@ -949,23 +752,23 @@ let pmulC cO cI cmul ceqb p c = '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) +let rec pmulI cO cI cmul ceqb pmul0 q2 j = function +| Pc c -> mkPinj j (pmulC cO cI cmul ceqb q2 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')) + | Z0 -> mkPinj j (pmul0 q' q2) + | Zpos k -> mkPinj j (pmul0 (Pinj (k, q')) q2) + | Zneg k -> mkPinj j' (pmulI cO cI cmul ceqb pmul0 q2 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') + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q2 j p') i' + (pmulI cO cI cmul ceqb pmul0 q2 (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') + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q2 j p') i' + (pmulI cO cI cmul ceqb pmul0 q2 (Pos.pred_double j') q') | XH -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' (pmul0 q' q0)) + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q2 XH p') i' (pmul0 q' q2)) (** val pmul : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 @@ -977,19 +780,19 @@ let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with | PX (p', i', q') -> (match p with | Pc c -> pmulC cO cI cmul ceqb p'' c - | Pinj (j, q0) -> + | Pinj (j, q2) -> let qQ' = match j with - | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' + | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q2)) 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' + pmul cO cI cadd cmul ceqb (Pinj ((Pos.pred_double j0), q2)) q' + | XH -> pmul cO cI cadd cmul ceqb q2 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 + | PX (p2, i, q2) -> + let qQ' = pmul cO cI cadd cmul ceqb q2 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 qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q2) 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' @@ -1002,184 +805,41 @@ let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with 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) -> +| Pinj (j, q2) -> Pinj (j, (psquare cO cI cadd cmul ceqb q2)) +| PX (p2, i, q2) -> let twoPQ = pmul cO cI cadd cmul ceqb p2 - (mkPinj XH (pmulC cO cI cmul ceqb q0 (cadd cI cI))) + (mkPinj XH (pmulC cO cI cmul ceqb q2 (cadd cI cI))) in - let q2 = psquare cO cI cadd cmul ceqb q0 in + let q3 = psquare cO cI cadd cmul ceqb q2 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) + mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb p3 i (p0 cO)) twoPQ) i q3 (** 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 **) + -> bool) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol **) -let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function +let rec ppow_pos cO cI cadd cmul ceqb 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) + pmul cO cI cadd cmul ceqb + (ppow_pos cO cI cadd cmul ceqb (ppow_pos cO cI cadd cmul ceqb 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) + ppow_pos cO cI cadd cmul ceqb (ppow_pos cO cI cadd cmul ceqb res p p3) p p3 +| XH -> 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 **) + -> bool) -> 'a1 pol -> n -> 'a1 pol **) -let ppow_N cO cI cadd cmul ceqb subst_l p = function +let ppow_N cO cI cadd cmul ceqb p = function | N0 -> p1 cI -| Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 - -(** val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) - -let rec norm_aux cO cI cadd cmul csub copp ceqb = function -| PEc c -> Pc c -| PEX j -> mk_X cO cI j -| PEadd (pe1, pe2) -> - (match pe1 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe2) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - (match pe2 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - padd cO cadd ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2))) -| PEsub (pe1, pe2) -> - psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) -| PEmul (pe1, pe2) -> - pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) -| PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) -| PEpow (pe1, n0) -> - ppow_N cO cI cadd cmul ceqb (fun p -> p) - (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 - -type 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 **) +| Npos p2 -> ppow_pos cO cI cadd cmul ceqb (p1 cI) p p2 -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 ('term, 'annot) clause = ('term * 'annot) list -type ('x, 'annot) clause = ('x * 'annot) list - -type ('x, 'annot) cnf = ('x, 'annot) clause list +type ('term, 'annot) cnf = ('term, 'annot) clause list (** val cnf_tt : ('a1, 'a2) cnf **) @@ -1191,899 +851,1416 @@ let cnf_tt = let cnf_ff = []::[] +(** 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 +| c::l -> + (match c with + | [] -> (match l with + | [] -> true + | _::_ -> false) + | _::_ -> false) + (** val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) - clause -> ('a1, 'a2) clause option **) + ('a1 -> 'a1 -> bool) -> ('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::[])) +let rec add_term is_tauto0 t0 = function +| [] -> if is_tauto0 (fst t0) (fst t0) then None else 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)) + if is_tauto0 (fst t0) (fst t') + then None + else (match add_term is_tauto0 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 **) + ('a1 -> 'a1 -> bool) -> ('a1, 'a2) clause -> ('a1, 'a2) clause -> ('a1, + 'a2) clause option **) -let rec or_clause unsat deduce cl1 cl2 = +let rec or_clause is_tauto0 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' + (match add_term is_tauto0 t0 cl2 with + | Some cl' -> or_clause is_tauto0 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 **) + ('a1 -> 'a1 -> bool) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf **) -let or_clause_cnf unsat deduce t0 f = - match t0 with +let or_clause_cnf is_tauto0 cl f = + match cl with | [] -> f - | _::_ -> xor_clause_cnf unsat deduce t0 f + | _::_ -> + fold_left (fun acc cl' -> + match or_clause is_tauto0 cl cl' with + | Some cl'' -> cl''::acc + | None -> acc) f [] -(** val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf **) +(** val or_cnf_aux : + ('a1 -> 'a1 -> bool) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) -let rec or_cnf unsat deduce f f' = - match f with +let rec or_cnf_aux is_tauto0 f1 f2 = + match f1 with | [] -> cnf_tt - | e::rst -> - rev_append (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') + | cl::rst -> + rev_append (or_cnf_aux is_tauto0 rst f2) (or_clause_cnf is_tauto0 cl f2) -(** val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) +(** val or_cnf : + ('a1 -> 'a1 -> bool) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) -let and_cnf = - rev_append +let or_cnf is_tauto0 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_aux is_tauto0 f1 f2 -type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula +(** val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) -(** val is_cnf_tt : ('a1, 'a2) cnf -> bool **) +let and_cnf 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 rev_append f1 f2 -let is_cnf_tt = function -| [] -> true -| _::_ -> false +(** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) -(** val is_cnf_ff : ('a1, 'a2) cnf -> bool **) +let cneqb ceqb x y = + negb (ceqb x y) -let is_cnf_ff = function -| [] -> false -| c0::l -> - (match c0 with - | [] -> (match l with - | [] -> true - | _::_ -> false) - | _::_ -> false) +(** val cltb : + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) -(** val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) +let cltb ceqb cleb x y = + (&&) (cleb x y) (cneqb ceqb x y) -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 +type op1 = +| Equal +| NonEqual +| Strict +| NonStrict -(** val or_cnf_opt : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf **) +type 'c nFormula = 'c pol * op1 -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 pExpr_to_Pol : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) -(** 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 rec pExpr_to_Pol cO cI cadd cmul csub copp ceqb = function +| PEc c -> Pc c +| PEX j -> mkX cO cI j +| PEadd (pe1, pe2) -> + (match pe1 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe2) + (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe3) + | _ -> + (match pe2 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) + (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe3) + | _ -> + padd cO cadd ceqb (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) + (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe2))) +| PEsub (pe1, pe2) -> + psub cO cadd csub copp ceqb + (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) + (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe2) +| PEmul (pe1, pe2) -> + pmul cO cI cadd cmul ceqb (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) + (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe2) +| PEopp pe1 -> popp copp (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) +| PEpow (pe1, n0) -> + ppow_N cO cI cadd cmul ceqb + (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) n0 + +(** 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 cadd cmul csub copp ceqb f = + let { flhs = lhs; fop = op; frhs = rhs } = f in + let lhs0 = pExpr_to_Pol cO cI cadd cmul csub copp ceqb lhs in + let rhs0 = pExpr_to_Pol cO cI cadd cmul csub copp ceqb rhs in + (match op with + | OpEq -> (psub cO cadd csub copp ceqb lhs0 rhs0),Equal + | OpNEq -> (psub cO cadd csub copp ceqb lhs0 rhs0),NonEqual + | OpLe -> (psub cO cadd csub copp ceqb rhs0 lhs0),NonStrict + | OpGe -> (psub cO cadd csub copp ceqb lhs0 rhs0),NonStrict + | OpLt -> (psub cO cadd csub copp ceqb rhs0 lhs0),Strict + | OpGt -> (psub cO cadd csub copp ceqb lhs0 rhs0),Strict) + +(** 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 normalise_aux : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) + +let normalise_aux copp = function +| e,o -> + (match o with + | Equal -> (e,Strict)::(((popp copp e),Strict)::[]) + | NonEqual -> (e,Equal)::[] + | Strict -> ((popp copp e),NonStrict)::[] + | NonStrict -> ((popp copp e),Strict)::[]) + +(** val negate_aux : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) + +let negate_aux copp = function +| e,o -> + (match o with + | NonEqual -> (e,Strict)::(((popp 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 cadd cmul csub copp ceqb cleb t0 tg = + let f = normalise cO cI cadd cmul csub copp ceqb t0 in + if check_inconsistent cO ceqb cleb f + then cnf_ff + else cnf_of_list cO ceqb cleb (normalise_aux 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 cadd cmul csub copp ceqb cleb t0 tg = + let f = normalise cO cI cadd cmul csub copp ceqb t0 in + if check_inconsistent cO ceqb cleb f + then cnf_tt + else cnf_of_list cO ceqb cleb (negate_aux copp f) tg + +(** val mk_and : + ('a3 -> 'a3 -> 'a3) -> ('a3 -> 'a3 -> 'a3) -> (bool -> kind -> ('a1, 'a4, + 'a2, 'a5) gFormula -> 'a3) -> kind -> bool -> ('a1, 'a4, 'a2, 'a5) + gFormula -> ('a1, 'a4, 'a2, 'a5) gFormula -> 'a3 **) -let mk_and unsat deduce rEC k pol0 f1 f2 = +let mk_and or_cnf0 and_cnf0 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) + then and_cnf0 (rEC pol0 k f1) (rEC pol0 k f2) + else or_cnf0 (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 **) + ('a3 -> 'a3 -> 'a3) -> ('a3 -> 'a3 -> 'a3) -> (bool -> kind -> ('a1, 'a4, + 'a2, 'a5) gFormula -> 'a3) -> kind -> bool -> ('a1, 'a4, 'a2, 'a5) + gFormula -> ('a1, 'a4, 'a2, 'a5) gFormula -> 'a3 **) -let mk_or unsat deduce rEC k pol0 f1 f2 = +let mk_or or_cnf0 and_cnf0 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) + then or_cnf0 (rEC pol0 k f1) (rEC pol0 k f2) + else and_cnf0 (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 **) + ('a3 -> 'a3 -> 'a3) -> ('a3 -> 'a3 -> 'a3) -> (bool -> kind -> ('a1, 'a4, + 'a2, 'a5) gFormula -> 'a3) -> kind -> bool -> ('a1, 'a4, 'a2, 'a5) + gFormula -> ('a1, 'a4, 'a2, 'a5) gFormula -> 'a3 **) -let mk_impl unsat deduce rEC k pol0 f1 f2 = +let mk_impl or_cnf0 and_cnf0 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) + then or_cnf0 (rEC (negb pol0) k f1) (rEC pol0 k f2) + else and_cnf0 (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 **) + ('a3 -> 'a3 -> 'a3) -> ('a3 -> 'a3 -> 'a3) -> (bool -> kind -> ('a1, 'a4, + 'a2, 'a5) gFormula -> 'a3) -> kind -> bool -> ('a1, 'a4, 'a2, 'a5) + gFormula -> ('a1, 'a4, 'a2, 'a5) gFormula -> 'a3 **) -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)) +let mk_iff or_cnf0 and_cnf0 rEC k pol0 f1 f2 = + or_cnf0 (and_cnf0 (rEC (negb pol0) k f1) (rEC false k f2)) + (and_cnf0 (rEC pol0 k f1) (rEC true k f2)) -(** val is_bool : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool option **) +(** val is_bool : kind -> ('a1, 'a3, 'a2, 'a4) gFormula -> 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 **) +(** val gFormula_to_cnf : + 'a3 -> 'a3 -> ('a3 -> 'a3 -> 'a3) -> ('a3 -> 'a3 -> 'a3) -> ('a1 -> 'a2 + -> 'a3) -> ('a1 -> 'a2 -> 'a3) -> bool -> kind -> ('a1, 'a4, 'a2, 'a5) + gFormula -> 'a3 **) -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 +let rec gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 pol0 _ = function +| TT _ -> if pol0 then cnf_tt0 else cnf_ff0 +| FF _ -> if pol0 then cnf_ff0 else cnf_tt0 +| X (_, _) -> cnf_ff0 | 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 + mk_and or_cnf0 and_cnf0 (fun x x0 x1 -> + gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 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 + mk_or or_cnf0 and_cnf0 (fun x x0 x1 -> + gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 x x0 + x1) + k0 pol0 e1 e2 +| NOT (k0, e) -> + gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 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 + mk_impl or_cnf0 and_cnf0 (fun x x0 x1 -> + gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 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 + gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 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) + mk_iff or_cnf0 and_cnf0 (fun x x0 x1 -> + gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 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 + gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 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) + mk_iff or_cnf0 and_cnf0 (fun x x0 x1 -> + gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 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 **) +(** val opMult : op1 -> op1 -> op1 option **) -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)) +let opMult o o' = + match o with + | Equal -> Some Equal + | NonEqual -> (match o' with + | Equal -> Some Equal + | _ -> None) + | Strict -> + (match o' with + | Equal -> Some Equal + | NonEqual -> None + | _ -> Some o') + | NonStrict -> + (match o' with + | NonEqual -> None + | Strict -> Some o + | x -> Some x) -(** val ror_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, - 'a2) clause -> (('a1, 'a2) clause, 'a2 trace) sum **) +(** val opAdd : op1 -> op1 -> op1 option **) -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) +let opAdd o o' = + match o with + | Equal -> Some o' + | NonEqual -> (match o' with + | Equal -> Some o + | _ -> None) + | Strict -> + (match o' with + | Equal -> Some o + | NonEqual -> None + | _ -> Some Strict) + | NonStrict -> + (match o' with + | Equal -> Some o + | NonEqual -> None + | x -> Some x) -(** val xror_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, - 'a2) clause list -> ('a1, 'a2) clause list * 'a2 trace **) +(** val pexpr_times_nformula : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 pol -> 'a1 nFormula -> 'a1 nFormula option **) -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) +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 ror_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, - 'a2) clause list -> ('a1, 'a2) clause list * 'a2 trace **) +(** val nformula_times_nformula : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) -let ror_clause_cnf unsat deduce t0 f = - match t0 with - | [] -> f,Null - | _::_ -> xror_clause_cnf unsat deduce t0 f +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 -> (pmul cO cI cplus ctimes ceqb e1 e2),x) (opMult o1 o2) -(** val ror_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> - ('a1, 'a2) clause list -> ('a1, 'a2) cnf * 'a2 trace **) +(** val nformula_plus_nformula : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 + nFormula -> 'a1 nFormula option **) -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')) +let nformula_plus_nformula cO cplus ceqb f1 f2 = + let e1,o1 = f1 in + let e2,o2 = f2 in + map_option (fun x -> (padd cO cplus ceqb e1 e2),x) (opAdd o1 o2) -(** val ror_cnf_opt : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf -> ('a1, 'a2) cnf * 'a2 trace **) +(** val is_tauto : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> + bool) -> 'a1 nFormula -> 'a1 nFormula -> bool **) -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 +let is_tauto cO cplus ceqb cleb f1 f2 = + match nformula_plus_nformula cO cplus ceqb f1 f2 with + | Some u -> check_inconsistent cO ceqb cleb u + | None -> false -(** val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 trace **) +(** 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 ratom c a = - if if is_cnf_ff c then true else is_cnf_tt c - then c,(Push (a, Null)) - else c,Null +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) -> + bind_option (pexpr_times_nformula cO cI cplus ctimes ceqb re) + (eval_Psatz cO cI cplus ctimes ceqb cleb l e0) +| PsatzMulE (f1, f2) -> + bind_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) -> + bind_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 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 **) +(** 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 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')))) +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 -(** 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 **) +(** val cnf_checker : ('a1 -> 'a2 -> bool) -> 'a1 list -> 'a2 list -> bool **) -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)) +let rec cnf_checker checker f wl = + match f with + | [] -> true + | cl::f0 -> + (match wl with + | [] -> false + | w::wl0 -> (&&) (checker cl w) (cnf_checker checker f0 wl0)) -(** 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 **) +(** val tauto_checker : + ('a1 -> 'a2 -> bool) -> 'a1 list -> 'a2 list -> bool **) -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)) +let tauto_checker = + cnf_checker -(** 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 **) +(** val cWeakChecker : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool **) -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')))))))) +let cWeakChecker = + check_normalised_formulas -(** 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 **) +(** val cnormalise : + '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 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 +let cnormalise = + cnf_normalise -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 cnegate : + '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 **) -(** val aformula : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 **) +let cnegate = + cnf_negate -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 cis_tauto : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> + bool) -> 'a1 nFormula -> 'a1 nFormula -> bool **) -(** val is_X : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option **) +let cis_tauto = + is_tauto -let is_X _ = function -| X (_, p) -> Some p -| _ -> None +(** val cGFormula_to_cnf : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) + -> ('a1 formula, eKind, unit0, unit0) gFormula -> ('a1 nFormula, unit0) + cnf **) -(** 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 cGFormula_to_cnf cO cI cadd cmul csub copp ceqb cleb = + gFormula_to_cnf cnf_tt cnf_ff (or_cnf (cis_tauto cO cadd ceqb cleb)) + and_cnf (cnormalise cO cI cadd cmul csub copp ceqb cleb) + (cnegate cO cI cadd cmul csub copp ceqb cleb) true IsProp -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 cTautoChecker : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) + -> 'a1 formula bFormula -> 'a1 psatz list -> bool **) -(** 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 cTautoChecker cO cI cadd cmul csub copp ceqb cleb f = + tauto_checker (fun cl -> + cWeakChecker cO cI cadd cmul ceqb cleb (map fst cl)) + (cGFormula_to_cnf cO cI cadd cmul csub copp ceqb cleb f) -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 qTautoChecker : q formula bFormula -> q psatz list -> bool **) -(** 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 qTautoChecker = + cTautoChecker q0 q1 qplus qmult qminus qopp qeq_bool qle_bool -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 +module Coq_Pos = + struct + (** val succ : positive -> positive **) -(** val mk_arrow : - 'a4 option -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, - 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula **) + let rec succ = function + | XI p -> XO (succ p) + | XO p -> XI p + | XH -> XO XH -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 add : positive -> positive -> positive **) -(** val abst_simpl : - ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> kind -> ('a1, 'a2, 'a3, - 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula **) + let rec add x y = + match x with + | XI p -> + (match y with + | XI q2 -> XO (add_carry p q2) + | XO q2 -> XI (add p q2) + | XH -> XO (succ p)) + | XO p -> + (match y with + | XI q2 -> XI (add p q2) + | XO q2 -> XO (add p q2) + | XH -> XI p) + | XH -> (match y with + | XI q2 -> XO (succ q2) + | XO q2 -> XI q2 + | XH -> XO XH) -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 add_carry : positive -> positive -> positive **) -(** 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 **) + and add_carry x y = + match x with + | XI p -> + (match y with + | XI q2 -> XI (add_carry p q2) + | XO q2 -> XO (add_carry p q2) + | XH -> XI (succ p)) + | XO p -> + (match y with + | XI q2 -> XO (add_carry p q2) + | XO q2 -> XI (add p q2) + | XH -> XO (succ p)) + | XH -> + (match y with + | XI q2 -> XI (succ q2) + | XO q2 -> XO (succ q2) + | XH -> XI XH) -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 pred_double : positive -> positive **) -(** 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 rec pred_double = function + | XI p -> XI (XO p) + | XO p -> XI (pred_double p) + | XH -> XH -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)) + type mask = Pos.mask = + | IsNul + | IsPos of positive + | IsNeg -(** 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 **) + (** val succ_double_mask : mask -> mask **) -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) + let succ_double_mask = function + | IsNul -> IsPos XH + | IsPos p -> IsPos (XI p) + | IsNeg -> IsNeg -(** val or_is_X : - kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> - bool **) + (** val double_mask : mask -> mask **) -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) + let double_mask = function + | IsPos p -> IsPos (XO p) + | x0 -> x0 -(** 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 **) + (** val double_pred_mask : positive -> mask **) -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 + let double_pred_mask = function + | XI p -> IsPos (XO (XO p)) + | XO p -> IsPos (XO (pred_double p)) + | XH -> IsNul -(** 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 **) + (** val sub_mask : positive -> positive -> mask **) -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))) + let rec sub_mask x y = + match x with + | XI p -> + (match y with + | XI q2 -> double_mask (sub_mask p q2) + | XO q2 -> succ_double_mask (sub_mask p q2) + | XH -> IsPos (XO p)) + | XO p -> + (match y with + | XI q2 -> succ_double_mask (sub_mask_carry p q2) + | XO q2 -> double_mask (sub_mask p q2) + | XH -> IsPos (pred_double p)) + | XH -> (match y with + | XH -> IsNul + | _ -> IsNeg) -(** 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 **) + (** val sub_mask_carry : positive -> positive -> mask **) -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))) + and sub_mask_carry x y = + match x with + | XI p -> + (match y with + | XI q2 -> succ_double_mask (sub_mask_carry p q2) + | XO q2 -> double_mask (sub_mask p q2) + | XH -> IsPos (pred_double p)) + | XO p -> + (match y with + | XI q2 -> double_mask (sub_mask_carry p q2) + | XO q2 -> succ_double_mask (sub_mask_carry p q2) + | XH -> double_pred_mask p) + | XH -> IsNeg -(** val abst_form : - ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> kind -> ('a1, 'a2, - 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula **) + (** val sub : positive -> positive -> positive **) -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 + let sub x y = + match sub_mask x y with + | IsPos z0 -> z0 + | _ -> XH -(** val cnf_checker : - (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool **) + (** val compare_cont : comparison -> positive -> positive -> comparison **) -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) + let rec compare_cont r x y = + match x with + | XI p -> + (match y with + | XI q2 -> compare_cont r p q2 + | XO q2 -> compare_cont Gt p q2 + | XH -> Gt) + | XO p -> + (match y with + | XI q2 -> compare_cont Lt p q2 + | XO q2 -> compare_cont r p q2 + | XH -> Gt) + | XH -> (match y with + | XH -> r + | _ -> Lt) -(** 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 **) + (** val compare : positive -> positive -> comparison **) -let tauto_checker unsat deduce normalise1 negate0 checker f w = - cnf_checker checker (xcnf unsat deduce normalise1 negate0 true IsProp f) w + let compare = + compare_cont Eq -(** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) + (** val leb : positive -> positive -> bool **) -let cneqb ceqb x y = - negb (ceqb x y) + let leb x y = + match compare x y with + | Gt -> false + | _ -> true -(** val cltb : - ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) + (** val size_nat : positive -> nat **) -let cltb ceqb cleb x y = - (&&) (cleb x y) (cneqb ceqb x y) + let rec size_nat = function + | XI p2 -> S (size_nat p2) + | XO p2 -> S (size_nat p2) + | XH -> S O -type 'c polC = 'c pol + (** val max : positive -> positive -> positive **) -type op1 = -| Equal -| NonEqual -| Strict -| NonStrict + let max p p' = + match compare p p' with + | Gt -> p + | _ -> p' -type 'c nFormula = 'c polC * op1 + (** val gcdn : nat -> positive -> positive -> positive **) -(** val opMult : op1 -> op1 -> op1 option **) + 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) -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 gcd : positive -> positive -> positive **) -(** val opAdd : op1 -> op1 -> op1 option **) + let gcd a b = + gcdn (Coq__1.add (size_nat a) (size_nat b)) a b + end -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) +module N = + struct + (** val of_nat : nat -> n **) -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 + let of_nat = function + | O -> N0 + | S n' -> Npos (Pos.of_succ_nat n') + end + +(** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) + +let rec pow_pos rmul x = function +| XI i0 -> let p = pow_pos rmul x i0 in rmul x (rmul p p) +| XO i0 -> let p = pow_pos rmul x i0 in rmul p p +| XH -> x -(** val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **) +module Coq_Z = + struct + (** val double : z -> z **) -let map_option f = function -| Some x -> f x -| None -> None + let double = function + | Z0 -> Z0 + | Zpos p -> Zpos (XO p) + | Zneg p -> Zneg (XO p) -(** val map_option2 : - ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **) + (** val succ_double : z -> z **) -let map_option2 f o o' = - match o with - | Some x -> (match o' with - | Some x' -> f x x' - | None -> None) - | None -> None + let succ_double = function + | Z0 -> Zpos XH + | Zpos p -> Zpos (XI p) + | Zneg p -> Zneg (Pos.pred_double p) -(** val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **) + (** val pred_double : z -> z **) -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) + let pred_double = function + | Z0 -> Zneg XH + | Zpos p -> Zpos (Pos.pred_double p) + | Zneg p -> Zneg (XI p) -(** val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) + (** val pos_sub : positive -> positive -> z **) -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) + let rec pos_sub x y = + match x with + | XI p -> + (match y with + | XI q2 -> double (pos_sub p q2) + | XO q2 -> succ_double (pos_sub p q2) + | XH -> Zpos (XO p)) + | XO p -> + (match y with + | XI q2 -> pred_double (pos_sub p q2) + | XO q2 -> double (pos_sub p q2) + | XH -> Zpos (Pos.pred_double p)) + | XH -> + (match y with + | XI q2 -> Zneg (XO q2) + | XO q2 -> Zneg (Pos.pred_double q2) + | XH -> Z0) -(** val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 - nFormula -> 'a1 nFormula option **) + (** val add : z -> z -> z **) -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) + 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 eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 - nFormula option **) + (** val opp : z -> z **) -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) + let opp = function + | Z0 -> Z0 + | Zpos x0 -> Zneg x0 + | Zneg x0 -> Zpos x0 -(** val check_inconsistent : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> - bool **) + (** val sub : z -> z -> z **) -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) + 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 q2 -> Pos.eqb p q2 + | _ -> false) + | Zneg p -> (match y with + | Zneg q2 -> Pos.eqb p q2 + | _ -> 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 q2,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)) q2),r' + else (add (mul (Zpos (XO XH)) q2) (Zpos XH)),(sub r' b) + | XO a' -> + let q2,r = pos_div_eucl a' b in + let r' = mul (Zpos (XO XH)) r in + if ltb r' b + then (mul (Zpos (XO XH)) q2),r' + else (add (mul (Zpos (XO XH)) q2) (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 q2,r = pos_div_eucl a' (Zpos b') in + (match r with + | Z0 -> (opp q2),Z0 + | _ -> (opp (add q2 (Zpos XH))),(add b r))) + | Zneg a' -> + (match b with + | Z0 -> Z0,a + | Zpos _ -> + let q2,r = pos_div_eucl a' b in + (match r with + | Z0 -> (opp q2),Z0 + | _ -> (opp (add q2 (Zpos XH))),(sub b r)) + | Zneg b' -> let q2,r = pos_div_eucl a' (Zpos b') in q2,(opp r)) + + (** val div : z -> z -> z **) + + let div a b = + let q2,_ = div_eucl a b in q2 + + (** 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 + +type 'a trace = +| Null +| Push of 'a * 'a trace +| Merge of 'a trace * 'a trace + +(** val mapX : + (kind -> 'a2 -> 'a2) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, + 'a2, 'a3, 'a4) gFormula **) + +let rec mapX f _ = function +| X (k, x) -> X (k, (f k 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) +| _ -> [] + +(** 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, + 'a4, 'a3, 'a5) gFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> + ('a1, 'a4, 'a3, 'a5) gFormula -> ('a1, 'a4, 'a3, 'a5) gFormula -> ('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 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, + 'a4, 'a3, 'a5) gFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> + ('a1, 'a4, 'a3, 'a5) gFormula -> ('a1, 'a4, 'a3, 'a5) gFormula -> ('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 e3 e4),(Merge (t1, t2)) + +(** val rxcnf_impl : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, + 'a4, 'a3, 'a5) gFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> + ('a1, 'a4, 'a3, 'a5) gFormula -> ('a1, 'a4, 'a3, 'a5) gFormula -> ('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 e3 e4),(Merge (t1, t2)) + +(** val rxcnf_iff : + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, + 'a4, 'a3, 'a5) gFormula -> ('a2, 'a3) cnf * 'a3 trace) -> bool -> kind -> + ('a1, 'a4, 'a3, 'a5) gFormula -> ('a1, 'a4, 'a3, 'a5) gFormula -> ('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 c1 c2) (and_cnf 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, 'a4, 'a3, + 'a5) gFormula -> ('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, 'a3, 'a2, 'a4) gFormula -> '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, 'a3, 'a2, 'a4) gFormula -> 'a3 option **) + +let is_X _ = function +| X (_, p) -> Some p +| _ -> None + +(** val abs_and : + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a3, 'a2, 'a4) gFormula -> + ('a1, 'a3, 'a2, 'a4) gFormula -> (kind -> ('a1, 'a3, 'a2, 'a4) gFormula + -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula) -> + ('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 check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool **) +(** val abs_or : + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a3, 'a2, 'a4) gFormula -> + ('a1, 'a3, 'a2, 'a4) gFormula -> (kind -> ('a1, 'a3, 'a2, 'a4) gFormula + -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula) -> + ('a1, 'a3, 'a2, 'a4) gFormula **) -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 +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 -type op2 = -| OpEq -| OpNEq -| OpLe -| OpGe -| OpLt -| OpGt +(** val abs_not : + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a3, 'a2, 'a4) gFormula -> + (kind -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula) + -> ('a1, 'a3, 'a2, 'a4) gFormula **) -type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } +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 norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) +(** val mk_arrow : + 'a4 option -> kind -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, + 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula **) -let norm = - norm_aux +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 psub0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 - -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) +(** val abst_simpl : + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> kind -> ('a1, 'a3, 'a2, + 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula **) -let psub0 = - psub +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 padd0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol - -> 'a1 pol **) +(** val abst_and : + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a3, 'a2, 'a4) + gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula) -> bool -> kind -> ('a1, 'a3, + 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, + 'a4) gFormula **) -let padd0 = - padd +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 popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) +(** val abst_or : + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a3, 'a2, 'a4) + gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula) -> bool -> kind -> ('a1, 'a3, + 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, + 'a4) gFormula **) -let popp0 = - popp +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 normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula **) +(** val abst_impl : + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a3, 'a2, 'a4) + gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula) -> bool -> 'a4 option -> kind + -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula -> + ('a1, 'a3, 'a2, 'a4) gFormula **) -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) +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 xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) +(** val or_is_X : + kind -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula -> + bool **) -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)::[]) +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 xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) +(** val abs_iff : + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a3, 'a2, 'a4) gFormula -> + ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, + 'a3, 'a2, 'a4) gFormula -> kind -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, + 'a3, 'a2, 'a4) gFormula **) -let xnegate copp = function -| e,o -> - (match o with - | NonEqual -> (e,Strict)::(((popp0 copp e),Strict)::[]) - | x -> (e,x)::[]) +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 cnf_of_list : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list - -> 'a2 -> ('a1 nFormula, 'a2) cnf **) +(** val abst_iff : + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, + 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula) -> bool -> kind + -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula -> + ('a1, 'a3, 'a2, 'a4) gFormula **) -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 +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 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 **) +(** val abst_eq : + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, + 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula) -> bool -> + ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula -> ('a1, + 'a3, 'a2, 'a4) gFormula **) -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 +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 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 **) +(** val abst_form : + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> kind -> ('a1, 'a3, + 'a2, 'a4) gFormula -> ('a1, 'a3, 'a2, 'a4) gFormula **) -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 +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 + +type 'c polC = 'c pol (** 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) -> +| PX (p2, j, q2) -> PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp), (Npos j))))), - (xdenorm (Coq_Pos.succ jmp) q0)) + (xdenorm (Coq_Pos.succ jmp) q2)) (** 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 **) @@ -2187,52 +2364,48 @@ let rec vm_add default x v = function 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) +| PEadd (e1, e2) -> map_option2 Coq_Z.add (zeval_const e1) (zeval_const e2) +| PEsub (e1, e2) -> map_option2 Coq_Z.sub (zeval_const e1) (zeval_const e2) +| PEmul (e1, e2) -> map_option2 Coq_Z.mul (zeval_const e1) (zeval_const e2) +| PEopp e0 -> map_option Coq_Z.opp (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 + map_option (fun x -> Coq_Z.pow x (Coq_Z.of_N n0)) (zeval_const e1) (** val zWeakChecker : z nFormula list -> z psatz -> bool **) let zWeakChecker = - check_normalised_formulas Z0 (Zpos XH) Z.add Z.mul Z.eqb Z.leb + check_normalised_formulas Z0 (Zpos XH) Coq_Z.add Coq_Z.mul Coq_Z.eqb + Coq_Z.leb -(** val psub1 : z pol -> z pol -> z pol **) +(** val psub0 : z pol -> z pol -> z pol **) -let psub1 = - psub0 Z0 Z.add Z.sub Z.opp Z.eqb +let psub0 = + psub Z0 Coq_Z.add Coq_Z.sub Coq_Z.opp Coq_Z.eqb -(** val popp1 : z pol -> z pol **) +(** val popp0 : z pol -> z pol **) -let popp1 = - popp0 Z.opp +let popp0 = + popp Coq_Z.opp -(** val padd1 : z pol -> z pol -> z pol **) +(** val padd0 : z pol -> z pol -> z pol **) -let padd1 = - padd0 Z0 Z.add Z.eqb +let padd0 = + padd Z0 Coq_Z.add Coq_Z.eqb (** val normZ : z pExpr -> z pol **) let normZ = - norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp Z.eqb + pExpr_to_Pol Z0 (Zpos XH) Coq_Z.add Coq_Z.mul Coq_Z.sub Coq_Z.opp Coq_Z.eqb (** val zunsat : z nFormula -> bool **) let zunsat = - check_inconsistent Z0 Z.eqb Z.leb + check_inconsistent Z0 Coq_Z.eqb Coq_Z.leb (** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) let zdeduce = - nformula_plus_nformula Z0 Z.add Z.eqb + nformula_plus_nformula Z0 Coq_Z.add Coq_Z.eqb (** val xnnormalise : z formula -> z nFormula **) @@ -2241,23 +2414,23 @@ let xnnormalise t0 = 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) + | OpEq -> (psub0 rhs0 lhs0),Equal + | OpNEq -> (psub0 rhs0 lhs0),NonEqual + | OpLe -> (psub0 rhs0 lhs0),NonStrict + | OpGe -> (psub0 lhs0 rhs0),NonStrict + | OpLt -> (psub0 rhs0 lhs0),Strict + | OpGt -> (psub0 lhs0 rhs0),Strict) -(** val xnormalise0 : z nFormula -> z nFormula list **) +(** val xnormalise : z nFormula -> z nFormula list **) -let xnormalise0 = function +let xnormalise = function | e,o -> (match o with | Equal -> - ((psub1 e (Pc (Zpos XH))),NonStrict)::(((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) + ((psub0 e (Pc (Zpos XH))),NonStrict)::(((psub0 (Pc (Zneg XH)) e),NonStrict)::[]) | NonEqual -> (e,Equal)::[] - | Strict -> ((psub1 (Pc Z0) e),NonStrict)::[] - | NonStrict -> ((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) + | Strict -> ((psub0 (Pc Z0) e),NonStrict)::[] + | NonStrict -> ((psub0 (Pc (Zneg XH)) e),NonStrict)::[]) (** val cnf_of_list0 : 'a1 -> z nFormula list -> (z nFormula * 'a1) list list **) @@ -2270,75 +2443,106 @@ let cnf_of_list0 tg l = let normalise0 t0 tg = let f = xnnormalise t0 in - if zunsat f then cnf_ff else cnf_of_list0 tg (xnormalise0 f) + if zunsat f then cnf_ff else cnf_of_list0 tg (xnormalise f) -(** val xnegate0 : z nFormula -> z nFormula list **) +(** val xnegate : z nFormula -> z nFormula list **) -let xnegate0 = function +let xnegate = 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)::[] + ((psub0 e (Pc (Zpos XH))),NonStrict)::(((psub0 (Pc (Zneg XH)) e),NonStrict)::[]) + | Strict -> ((psub0 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) + if zunsat f then cnf_tt else cnf_of_list0 tg (xnegate f) (** val cnfZ : - kind -> (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) + kind -> (z formula, 'a2, 'a1, 'a3) gFormula -> (z nFormula, 'a1) cnf * 'a1 trace **) let cnfZ k f = rxcnf zunsat zdeduce normalise0 negate true k f +(** val zis_tauto : z nFormula -> z nFormula -> bool **) + +let zis_tauto x y = + match zdeduce x y with + | Some u -> zunsat u + | None -> false + +(** val zcnf_tt : (z nFormula, unit0) cnf **) + +let zcnf_tt = + cnf_tt + +(** val zcnf_ff : (z nFormula, unit0) cnf **) + +let zcnf_ff = + cnf_ff + +(** val zor_cnf : + (z nFormula, unit0) cnf -> (z nFormula, unit0) cnf -> (z nFormula, unit0) + cnf **) + +let zor_cnf = + or_cnf zis_tauto + +(** val zand_cnf : + (z nFormula, unit0) cnf -> (z nFormula, unit0) cnf -> (z nFormula, unit0) + cnf **) + +let zand_cnf = + and_cnf + +(** val zGFormula_to_cnf : + (z formula, eKind, unit0, unit0) gFormula -> (z nFormula, unit0) cnf **) + +let zGFormula_to_cnf = + gFormula_to_cnf zcnf_tt zcnf_ff zor_cnf zand_cnf normalise0 negate true + IsProp + (** val ceiling : z -> z -> z **) let ceiling a b = - let q0,r = Z.div_eucl a b in + let q2,r = Coq_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 -| EnumProof of zWitness * zWitness * zArithProof list -| ExProof of positive * zArithProof + | Z0 -> q2 + | _ -> Coq_Z.add q2 (Zpos XH)) (** val zgcdM : z -> z -> z **) let zgcdM x y = - Z.max (Z.gcd x y) (Zpos XH) + Coq_Z.max (Coq_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) -> +| PX (p2, _, q2) -> let g1,c1 = zgcd_pol p2 in - let g2,c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2),c2 + let g2,c2 = zgcd_pol q2 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) + | Pc c -> Pc (Coq_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)) + | PX (p2, j, q2) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q2 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)) + if Coq_Z.gtb g Z0 + then (zdiv_pol (psubC Coq_Z.sub p c) g),(Coq_Z.opp + (ceiling (Coq_Z.opp c) g)) else p,Z0 (** val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option **) @@ -2348,18 +2552,19 @@ let genCuttingPlane = function (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))) + if (&&) (Coq_Z.gtb g Z0) + ((&&) (negb (Coq_Z.eqb c Z0)) (negb (Coq_Z.eqb (Coq_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) + | Strict -> + Some ((makeCuttingPlane (psubC Coq_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 +| e_z,o -> let e,z0 = e_z in (padd0 e (Pc z0)),o (** val is_pol_Z0 : z polC -> bool **) @@ -2372,7 +2577,7 @@ let is_pol_Z0 = function (** 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 + eval_Psatz Z0 (Zpos XH) Coq_Z.add Coq_Z.mul Coq_Z.eqb Coq_Z.leb (** val valid_cut_sign : op1 -> bool **) @@ -2396,8 +2601,8 @@ let mk_eq_pos x y t0 = 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) +| PX (p2, _, q2) -> + Coq_Pos.max (max_var jmp p2) (max_var (Coq_Pos.succ jmp) q2) (** val max_var_nformulae : z nFormula list -> positive **) @@ -2422,7 +2627,7 @@ let rec zChecker l = function | SplitProof (p, pf1, pf2) -> (match genCuttingPlane (p,NonStrict) with | Some cp1 -> - (match genCuttingPlane ((popp1 p),NonStrict) with + (match genCuttingPlane ((popp0 p),NonStrict) with | Some cp2 -> (&&) (zChecker ((nformula_of_cutting_plane cp1)::l) pf1) (zChecker ((nformula_of_cutting_plane cp2)::l) pf2) @@ -2442,14 +2647,14 @@ let rec zChecker l = function let p4,op4 = p3 in let e2,z2 = p4 in if (&&) ((&&) (valid_cut_sign op3) (valid_cut_sign op4)) - (is_pol_Z0 (padd1 e1 e2)) + (is_pol_Z0 (padd0 e1 e2)) then let rec label pfs lb ub = match pfs with - | [] -> Z.gtb lb ub + | [] -> Coq_Z.gtb lb ub | pf1::rsr -> - (&&) (zChecker (((psub1 e1 (Pc lb)),Equal)::l) pf1) - (label rsr (Z.add lb (Zpos XH)) ub) - in label pf0 (Z.opp z1) z2 + (&&) (zChecker (((psub0 e1 (Pc lb)),Equal)::l) pf1) + (label rsr (Coq_Z.add lb (Zpos XH)) ub) + in label pf0 (Coq_Z.opp z1) z2 else false | None -> true) | None -> true) @@ -2469,41 +2674,7 @@ let rec zChecker l = function (** 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) + tauto_checker (fun cl -> zChecker (map fst cl)) (zGFormula_to_cnf f) w (** val qinv : q -> q **) @@ -2520,59 +2691,26 @@ let qpower_positive = (** val qpower : q -> z -> q **) -let qpower q0 = function +let qpower q2 = 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 +| Zpos p -> qpower_positive q2 p +| Zneg p -> qinv (qpower_positive q2 p) (** val normQ : q pExpr -> q pol **) let normQ = - norm { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult - qminus qopp qeq_bool + pExpr_to_Pol { 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) + kind -> (q formula, 'a2, 'a1, 'a3) gFormula -> (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 + rxcnf (check_inconsistent q0 qeq_bool qle_bool) + (nformula_plus_nformula q0 qplus qeq_bool) + (cnormalise q0 q1 qplus qmult qminus qopp qeq_bool qle_bool) + (cnegate q0 q1 qplus qmult qminus qopp qeq_bool qle_bool) true k f type rcst = | C0 @@ -2590,14 +2728,14 @@ type rcst = let z_of_exp = function | Inl z1 -> z1 -| Inr n0 -> Z.of_nat n0 +| Inr n0 -> Coq_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 +| CQ q2 -> q2 | 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) @@ -2608,38 +2746,12 @@ let rec q_of_Rcst = function 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 + tauto_checker (fun cl -> + cWeakChecker q0 q1 qplus qmult qeq_bool qle_bool (map fst cl)) + (cGFormula_to_cnf q0 q1 qplus qmult qminus qopp qeq_bool qle_bool + (gFmap IsProp (fmap q_of_Rcst) f)) + w diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v index 55bc55604b..581839c28d 100644 --- a/test-suite/output/MExtraction.v +++ b/test-suite/output/MExtraction.v @@ -18,7 +18,7 @@ Don't forget to update it in Rocq core when editing this MExtraction.v file or MExtraction.out *) -From Stdlib Require Import micromega_checker. +From Stdlib Require Import micromega_eval micromega_checker. From Stdlib Require Extraction. From Stdlib Require Import ZMicromega. From Stdlib Require Import QMicromega. @@ -57,7 +57,7 @@ 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.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula GFmap Tauto.abst_form ZMicromega.cnfZ ZMicromega.Zeval_const QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) diff --git a/theories/micromega/EnvRing.v b/theories/micromega/EnvRing.v index 91d45f5ea9..b958b884db 100644 --- a/theories/micromega/EnvRing.v +++ b/theories/micromega/EnvRing.v @@ -11,7 +11,7 @@ For big polynomials, this is inefficient -- linear access. I have modified the code to use binary trees -- logarithmic access. *) -From Stdlib Require Export micromega_formula micromega_witness. +From Stdlib Require Export micromega_formula micromega_witness micromega_eval. From Stdlib Require Export micromega_checker. From Stdlib Require Import Setoid Morphisms Env BinPos BinNat BinInt. From Stdlib Require Export Ring_theory. @@ -681,16 +681,8 @@ Qed. (** 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 + radd rmul rsub ropp phi Cp_phi rpow (@nth R)). (** Correctness proofs *) @@ -794,3 +786,6 @@ Section POWER. End NORM_SUBST_REC. End MakeRingPol. + +Notation PEeval := (fun add mul sub opp phi pow_phi pow => PEeval + add mul sub opp phi pow_phi pow (@Env.nth _)). diff --git a/theories/micromega/QMicromega.v b/theories/micromega/QMicromega.v index 5febdbe2aa..1a6dd58832 100644 --- a/theories/micromega/QMicromega.v +++ b/theories/micromega/QMicromega.v @@ -64,31 +64,8 @@ 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. - -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. +#[local] Notation Qeval_expr := (PEeval + Qplus Qmult Qminus Qopp id Z.of_N Qpower). Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult). @@ -100,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 := diff --git a/theories/micromega/RMicromega.v b/theories/micromega/RMicromega.v index 27cca3f48f..e542c54611 100644 --- a/theories/micromega/RMicromega.v +++ b/theories/micromega/RMicromega.v @@ -440,7 +440,7 @@ Definition Reval_formula' := 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. @@ -512,7 +512,7 @@ From Stdlib.micromega Require Import Tauto. Q0 Q1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool). Definition RTautoChecker (f : BFormula (Formula Rcst) isProp) (w: list RWitness) : bool := - micromega_checker.tauto_checker (fun cl => RWeakChecker (List.map fst cl)) (Qcnf_of_GFormula (map_bformula (map_Formula Q_of_Rcst) f)) w. + micromega_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. @@ -520,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. diff --git a/theories/micromega/RingMicromega.v b/theories/micromega/RingMicromega.v index 28f6d5ac70..a88301b611 100644 --- a/theories/micromega/RingMicromega.v +++ b/theories/micromega/RingMicromega.v @@ -490,22 +490,15 @@ Qed. (** Normalisation of formulae **) -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. + PEeval rplus rtimes rminus ropp phi pow_phi rpow (@Env.nth R). -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). +#[local] Notation eval_formula := (Feval + rplus rtimes rminus ropp isProp req (fun x y => ~ req x y) rle rlt + phi pow_phi rpow (@Env.nth R)). (* We normalize Formulas by moving terms to one side *) @@ -812,30 +805,14 @@ 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 rplus rtimes rminus ropp phiS pow_phi rpow (@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; @@ -847,7 +824,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. @@ -901,6 +878,11 @@ Notation padd := Padd (only parsing). Notation pmul := Pmul (only parsing). Notation popp := Popp (only parsing). +Notation eval_formula := + (fun add mul sub opp eqProp le lt phi pow_phi pow => Feval + add mul sub opp isProp eqProp (fun x y => ~ eqProp x y) le lt + phi pow_phi pow (@Env.nth _)). + (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index 7fba469a20..7f2785ea07 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -14,7 +14,7 @@ (* *) (************************************************************************) -From Stdlib Require Export micromega_formula micromega_witness. +From Stdlib Require Export micromega_formula micromega_witness micromega_eval. From Stdlib Require Export micromega_checker. From Stdlib Require Import List. From Stdlib Require Import Refl. @@ -29,6 +29,9 @@ Inductive Trace (A : Type) := | 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) *) @@ -105,45 +108,7 @@ 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 micromega_formula.GFormula k' return eKind k' with - | TT tk => eTT tk - | FF tk => eFF tk - | A k a _ => ea k a - | 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. + #[local] Notation eval_f := (eval_f ex ea). Lemma eval_f_rew : forall k (f:GFormula k), eval_f f = @@ -164,7 +129,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. @@ -259,37 +224,6 @@ Section S. End S. -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. *) @@ -1871,7 +1805,7 @@ Section S. tauto. Qed. - Lemma tauto_checker_sound : forall t w, tauto_checker (@xcnf true isProp t) w = true -> forall env, @eval_f _ _ _ unit 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. @@ -1880,10 +1814,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 @@ -1894,6 +1828,7 @@ Section S. End S. +Notation eval_bf := (BFeval eqb). Notation tauto_checker := (fun term term' annot unsat deduce normalise negate witness check f => diff --git a/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v index 7c8370348c..b2b1a3a3fd 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -218,11 +218,11 @@ Proof. 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 (micromega_eval.PEeval Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) (@Env.nth Z) env Flhs). + generalize (micromega_eval.PEeval Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) (@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. @@ -340,11 +340,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 (micromega_eval.PEeval Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) (@Env.nth Z) env lhs); + generalize (micromega_eval.PEeval Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) (@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. @@ -1781,7 +1781,7 @@ Definition leaf := @VarMap.Elt Z. Definition coneMember := ZWitness. -Definition eval := eval_formula. +Definition eval := Feval. #[deprecated(note="Use [prod positive nat]", since="9.0")] Definition prod_pos_nat := prod positive nat. diff --git a/theories/micromega/micromega_eval.v b/theories/micromega/micromega_eval.v new file mode 100644 index 0000000000..3a553b9428 --- /dev/null +++ b/theories/micromega/micromega_eval.v @@ -0,0 +1,181 @@ +(************************************************************************) +(* * The Rocq Prover / The Rocq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* = 9.2 + and use the identical file in Corelib instead *) + +From Corelib Require Import PosDef. +From Stdlib Require Import micromega_formula micromega_witness. + +Set Implicit Arguments. + +Section Feval. +Variable R : Type. +Variable (rO rI : R) (radd rmul rsub: R -> R -> R) (ropp : R -> R). +Variable (k : kind) (req rneq rle rlt : R -> R -> eKind k). + +Variable C : Type. +Variable C2R : C -> R. + +Variable Cpow : Type. +Variable N2Cpow : N -> Cpow. +Variable rpow : R -> Cpow -> R. + +Variable Env : Type. +Variable env_nth : positive -> Env -> R. + +Fixpoint PEeval l pe : R := + match pe with + | PEc c => C2R c + | PEX j => env_nth j l + | PEadd pe1 pe2 => radd (PEeval l pe1) (PEeval l pe2) + | PEsub pe1 pe2 => rsub (PEeval l pe1) (PEeval l pe2) + | PEmul pe1 pe2 => rmul (PEeval l pe1) (PEeval l pe2) + | PEopp pe1 => ropp (PEeval l pe1) + | PEpow pe1 n => rpow (PEeval l pe1) (N2Cpow n) + end. + +Definition eval_op2 (o : Op2) (x y : R) : eKind k := + match o with + | OpEq => req x y + | OpNEq => rneq x y + | OpLe => rle x y + | OpGe => rle y x + | OpLt => rlt x y + | OpGt => rlt y x + end. + +Definition Feval (env : Env) (f : Formula C) : eKind k := + let 'Build_Formula lhs op rhs := f in + eval_op2 op (PEeval env lhs) (PEeval env rhs). +End Feval. + +Section GFormulaEval. +Variable eqb : bool -> bool -> bool. + +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 *) + +#[local] Notation GFormula := (@GFormula TA TX AA AF). + +Variable ex : forall k : kind, TX k -> eKind k. (* [ex] will be the identity *) + +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 eNOT (k : kind) : eKind k -> eKind k := + if k as k' return eKind k' -> eKind k' then not else negb. + +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. + +Fixpoint GFeval (k : kind) (f : GFormula k) {struct f} : eKind k := + match f in micromega_formula.GFormula k' return eKind k' with + | TT tk => eTT tk + | FF tk => eFF tk + | X k p => ex p + | A k a _ => ea k a + | @AND _ _ _ _ k e1 e2 => eAND k (GFeval e1) (GFeval e2) + | @OR _ _ _ _ k e1 e2 => eOR k (GFeval e1) (GFeval e2) + | @NOT _ _ _ _ k e => eNOT k (GFeval e) + | @IMPL _ _ _ _ k f1 _ f2 => eIMPL k (GFeval f1) (GFeval f2) + | @IFF _ _ _ _ k f1 f2 => eIFF k (GFeval f1) (GFeval f2) + | EQ f1 f2 => (GFeval f1) = (GFeval f2) + end. +End GFormulaEval. + +Definition BFeval eqb {A : Type} (ea : forall (k : kind), A -> eKind k) + (k : kind) (f : BFormula A k) := GFeval eqb (fun k x => x) ea f. + +Section Fmap. +Variables (T T' : Type) (f : T -> T'). + +Fixpoint PEmap (e : PExpr T) : PExpr T' := + match e with + | PEc c => PEc (f c) + | PEX p => PEX p + | PEadd e1 e2 => PEadd (PEmap e1) (PEmap e2) + | PEsub e1 e2 => PEsub (PEmap e1) (PEmap e2) + | PEmul e1 e2 => PEmul (PEmap e1) (PEmap e2) + | PEopp e => PEopp (PEmap e) + | PEpow e n => PEpow (PEmap e) n + end. + +Definition Fmap (f : Formula T) : Formula T' := + let 'Build_Formula l o r := f in + Build_Formula (PEmap l) o (PEmap r). + +End Fmap. + +Section GFormulaMap. +Context {TA TA' : Type} {TX : kind -> Type} {AA : Type} {AF : Type}. +Fixpoint GFmap (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 (GFmap fct f1) (GFmap fct f2) + | OR f1 f2 => OR (GFmap fct f1) (GFmap fct f2) + | NOT f => NOT (GFmap fct f) + | IMPL f1 a f2 => IMPL (GFmap fct f1) a (GFmap fct f2) + | IFF f1 f2 => IFF (GFmap fct f1) (GFmap fct f2) + | EQ f1 f2 => EQ (GFmap fct f1) (GFmap fct f2) + end. +End GFormulaMap. + +Section Pmap. +Variables (T T' : Type) (f : T -> T'). +Fixpoint Pmap (P : Pol T) : Pol T' := + match P with + | Pc c => Pc (f c) + | Pinj j P => Pinj j (Pmap P) + | PX P i Q => PX (Pmap P) i (Pmap Q) + end. +End Pmap. + +Section PsatzMap. +Variables (T T' : Type) (f : T -> T'). +Fixpoint Psatz_map (e : Psatz T) : Psatz T' := + match e with + | PsatzLet p1 p2 => PsatzLet (Psatz_map p1) (Psatz_map p2) + | PsatzIn _ n => PsatzIn T' n + | PsatzSquare e => PsatzSquare (Pmap f e) + | PsatzMulC re e => PsatzMulC (Pmap f re) (Psatz_map e) + | PsatzMulE f1 f2 => PsatzMulE (Psatz_map f1) (Psatz_map f2) + | PsatzAdd f1 f2 => PsatzAdd (Psatz_map f1) (Psatz_map f2) + | PsatzC c => PsatzC (f c) + | PsatzZ _ => PsatzZ T' + end. +End PsatzMap. From 3bb80d5d9889e25bce18652b1c6845556f9f0286 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Tue, 2 Sep 2025 13:13:09 +0200 Subject: [PATCH 13/14] Factor common definitions between ring and micromega --- test-suite/micromega/witness_tactics.v | 6 +- test-suite/output/MExtraction.out | 661 ++++++++++++++----------- theories/micromega/EnvRing.v | 12 +- theories/micromega/QMicromega.v | 6 +- theories/micromega/RMicromega.v | 8 +- theories/micromega/RingMicromega.v | 19 +- theories/micromega/ZMicromega.v | 32 +- theories/micromega/micromega_checker.v | 311 +----------- theories/micromega/micromega_eval.v | 78 +-- theories/micromega/micromega_formula.v | 13 +- theories/micromega/micromega_witness.v | 27 +- 11 files changed, 445 insertions(+), 728 deletions(-) diff --git a/test-suite/micromega/witness_tactics.v b/test-suite/micromega/witness_tactics.v index c4c12066e5..9a72637404 100644 --- a/test-suite/micromega/witness_tactics.v +++ b/test-suite/micromega/witness_tactics.v @@ -11,7 +11,7 @@ pose (ff := (EQ (A isBool {| - Flhs := PEadd (PEX 1) (PEmul (PEc 2%Q) (PEX 2)); + Flhs := PEadd (PEX _ 1) (PEmul (PEc 2%Q) (PEX _ 2)); Fop := OpLe; Frhs := PEc 3%Q |} tt) (TT isBool)) None @@ -19,13 +19,13 @@ pose (ff := (EQ (A isBool {| - Flhs := PEadd (PEmul (PEc 2%Q) (PEX 1)) (PEX 2); + 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) + {| 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) diff --git a/test-suite/output/MExtraction.out b/test-suite/output/MExtraction.out index 3e126a4ea6..7b3bfe6c12 100644 --- a/test-suite/output/MExtraction.out +++ b/test-suite/output/MExtraction.out @@ -190,45 +190,84 @@ module Pos = | S x -> succ (of_succ_nat x) end -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 +module Coq_Pos = + struct + (** val succ : positive -> positive **) -type op2 = -| OpEq -| OpNEq -| OpLe -| OpGe -| OpLt -| OpGt + let rec succ = function + | XI p -> XO (succ p) + | XO p -> XI p + | XH -> XO XH -type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } + (** val add : positive -> positive -> positive **) -type kind = -| IsProp -| IsBool + let rec add x y = + match x with + | XI p -> + (match y with + | XI q2 -> XO (add_carry p q2) + | XO q2 -> XI (add p q2) + | XH -> XO (succ p)) + | XO p -> + (match y with + | XI q2 -> XI (add p q2) + | XO q2 -> XO (add p q2) + | XH -> XI p) + | XH -> (match y with + | XI q2 -> XO (succ q2) + | XO q2 -> XI q2 + | XH -> XO XH) -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 add_carry : positive -> positive -> positive **) -type eKind = __ + and add_carry x y = + match x with + | XI p -> + (match y with + | XI q2 -> XI (add_carry p q2) + | XO q2 -> XO (add_carry p q2) + | XH -> XI (succ p)) + | XO p -> + (match y with + | XI q2 -> XO (add_carry p q2) + | XO q2 -> XI (add p q2) + | XH -> XO (succ p)) + | XH -> + (match y with + | XI q2 -> XI (succ q2) + | XO q2 -> XO (succ q2) + | XH -> XI XH) -type 'a bFormula = ('a, eKind, unit0, unit0) gFormula + (** val pred_double : positive -> positive **) + + let rec pred_double = function + | XI p -> XI (XO p) + | XO p -> XI (pred_double p) + | XH -> XH + + (** val compare_cont : comparison -> positive -> positive -> comparison **) + + let rec compare_cont r x y = + match x with + | XI p -> + (match y with + | XI q2 -> compare_cont r p q2 + | XO q2 -> compare_cont Gt p q2 + | XH -> Gt) + | XO p -> + (match y with + | XI q2 -> compare_cont Lt p q2 + | XO q2 -> compare_cont r p q2 + | XH -> Gt) + | XH -> (match y with + | XH -> r + | _ -> Lt) + + (** val compare : positive -> positive -> comparison **) + + let compare = + compare_cont Eq + end module Z = struct @@ -350,171 +389,21 @@ module Z = | _ -> false) end -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 = (Pos.mul x.qden y.qden) } - -(** val qmult : q -> q -> q **) - -let qmult x y = - { qnum = (Z.mul x.qnum y.qnum); qden = (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 q0 : q **) - -let q0 = - { qnum = Z0; qden = XH } - -(** val q1 : q **) - -let q1 = - { qnum = (Zpos XH); qden = XH } - -type 'c pol = -| Pc of 'c -| Pinj of positive * 'c pol -| PX of 'c pol * positive * 'c pol - -type 'c psatz = -| PsatzLet of 'c psatz * 'c psatz -| PsatzIn of nat -| PsatzSquare of 'c pol -| PsatzMulC of 'c pol * 'c psatz -| PsatzMulE of 'c psatz * 'c psatz -| PsatzAdd of 'c psatz * 'c psatz -| PsatzC of 'c -| PsatzZ - -type zWitness = z psatz - -type zArithProof = -| DoneProof -| RatProof of zWitness * zArithProof -| CutProof of zWitness * zArithProof -| SplitProof of z pol * zArithProof * zArithProof -| EnumProof of zWitness * zWitness * zArithProof list -| ExProof of positive * zArithProof - -(** val pEmap : ('a1 -> 'a2) -> 'a1 pExpr -> 'a2 pExpr **) - -let rec pEmap f = function -| PEc c -> PEc (f c) -| PEX p -> PEX p -| PEadd (e1, e2) -> PEadd ((pEmap f e1), (pEmap f e2)) -| PEsub (e1, e2) -> PEsub ((pEmap f e1), (pEmap f e2)) -| PEmul (e1, e2) -> PEmul ((pEmap f e1), (pEmap f e2)) -| PEopp e0 -> PEopp (pEmap f e0) -| PEpow (e0, n0) -> PEpow ((pEmap f e0), n0) - -(** val fmap : ('a1 -> 'a2) -> 'a1 formula -> 'a2 formula **) - -let fmap f f0 = - let { flhs = l; fop = o; frhs = r } = f0 in - { flhs = (pEmap f l); fop = o; frhs = (pEmap f r) } - -(** val gFmap : - kind -> ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, - 'a5) gFormula **) - -let rec gFmap _ 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, (gFmap k0 fct f1), (gFmap k0 fct f2)) -| OR (k0, f1, f2) -> OR (k0, (gFmap k0 fct f1), (gFmap k0 fct f2)) -| NOT (k0, f0) -> NOT (k0, (gFmap k0 fct f0)) -| IMPL (k0, f1, a, f2) -> IMPL (k0, (gFmap k0 fct f1), a, (gFmap k0 fct f2)) -| IFF (k0, f1, f2) -> IFF (k0, (gFmap k0 fct f1), (gFmap k0 fct f2)) -| EQ (f1, f2) -> EQ ((gFmap IsBool fct f1), (gFmap IsBool fct f2)) - -(** 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) - -(** val apply_option : ('a1 -> 'a2) -> 'a2 -> 'a1 option -> 'a2 **) - -let apply_option f x = function -| Some y -> f y -| None -> x - -(** val bind_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **) - -let bind_option f = - apply_option f None - -(** val map_option : ('a1 -> 'a2) -> 'a1 option -> 'a2 option **) - -let map_option f = - bind_option (fun x -> Some (f x)) - -(** val bind_option2 : - ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **) - -let bind_option2 f o o' = - bind_option (fun o0 -> bind_option (f o0) o') o - -(** val map_option2 : - ('a1 -> 'a2 -> 'a3) -> 'a1 option -> 'a2 option -> 'a3 option **) +type 'c pExpr = +| PEO +| PEI +| 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 -let map_option2 f = - bind_option2 (fun x y -> Some (f x y)) +type 'c pol = +| Pc of 'c +| Pinj of positive * 'c pol +| PX of 'c pol * positive * 'c pol (** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **) @@ -526,14 +415,14 @@ let rec peq ceqb p p' = | Pinj (j, q2) -> (match p' with | Pinj (j', q') -> - (match Pos.compare j j' with + (match Coq_Pos.compare j j' with | Eq -> peq ceqb q2 q' | _ -> false) | _ -> false) | PX (p2, i, q2) -> (match p' with | PX (p'0, i', q') -> - (match Pos.compare i i' with + (match Coq_Pos.compare i i' with | Eq -> if peq ceqb p2 p'0 then peq ceqb q2 q' else false | _ -> false) | _ -> false) @@ -552,7 +441,7 @@ let p1 cI = let mkPinj j p = match p with | Pc _ -> p -| Pinj (j', q2) -> Pinj ((Pos.add j j'), q2) +| Pinj (j', q2) -> Pinj ((Coq_Pos.add j j'), q2) | PX (_, _, _) -> Pinj (j, p) (** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) @@ -560,7 +449,7 @@ let mkPinj j p = match p with let mkPinj_pred j p = match j with | XI j0 -> Pinj ((XO j0), p) - | XO j0 -> Pinj ((Pos.pred_double j0), p) + | XO j0 -> Pinj ((Coq_Pos.pred_double j0), p) | XH -> p (** val mkX : 'a1 -> 'a1 -> positive -> 'a1 pol **) @@ -576,7 +465,9 @@ let mkPX cO ceqb p i q2 = | Pc c -> if ceqb c cO then mkPinj XH q2 else PX (p, i, q2) | Pinj (_, _) -> PX (p, i, q2) | PX (p', i', q') -> - if peq ceqb q' (p0 cO) then PX (p', (Pos.add i' i), q2) else PX (p, i, q2) + if peq ceqb q' (p0 cO) + then PX (p', (Coq_Pos.add i' i), q2) + else PX (p, i, q2) (** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) @@ -615,7 +506,7 @@ let rec paddI cadd pop q2 j = function | PX (p2, i, q') -> (match j with | XI j0 -> PX (p2, i, (paddI cadd pop q2 (XO j0) q')) - | XO j0 -> PX (p2, i, (paddI cadd pop q2 (Pos.pred_double j0) q')) + | XO j0 -> PX (p2, i, (paddI cadd pop q2 (Coq_Pos.pred_double j0) q')) | XH -> PX (p2, i, (pop q' q2))) (** val psubI : @@ -632,7 +523,7 @@ let rec psubI cadd copp pop q2 j = function | PX (p2, i, q') -> (match j with | XI j0 -> PX (p2, i, (psubI cadd copp pop q2 (XO j0) q')) - | XO j0 -> PX (p2, i, (psubI cadd copp pop q2 (Pos.pred_double j0) q')) + | XO j0 -> PX (p2, i, (psubI cadd copp pop q2 (Coq_Pos.pred_double j0) q')) | XH -> PX (p2, i, (pop q' q2))) (** val paddX : @@ -644,7 +535,7 @@ let rec paddX cO ceqb pop p' i' p = match p with | Pinj (j, q') -> (match j with | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) - | XO j0 -> PX (p', i', (Pinj ((Pos.pred_double 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 @@ -661,7 +552,7 @@ let rec psubX cO copp ceqb pop p' i' p = match p with | 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 ((Pos.pred_double 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 @@ -683,7 +574,8 @@ let rec padd cO cadd ceqb p = function (match j with | XI j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((XO j0), q2)) q')) | XO j0 -> - PX (p'0, i', (padd cO cadd ceqb (Pinj ((Pos.pred_double j0), q2)) q')) + PX (p'0, i', + (padd cO cadd ceqb (Pinj ((Coq_Pos.pred_double j0), q2)) q')) | XH -> PX (p'0, i', (padd cO cadd ceqb q2 q'))) | PX (p2, i, q2) -> (match Z.pos_sub i i' with @@ -713,7 +605,8 @@ let rec psub cO cadd csub copp ceqb p = function (psub cO cadd csub copp ceqb (Pinj ((XO j0), q2)) q')) | XO j0 -> PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj ((Pos.pred_double j0), q2)) q')) + (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), q2)) + q')) | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q2 q'))) | PX (p2, i, q2) -> (match Z.pos_sub i i' with @@ -766,7 +659,7 @@ let rec pmulI cO cI cmul ceqb pmul0 q2 j = function (pmulI cO cI cmul ceqb pmul0 q2 (XO j') q') | XO j' -> mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q2 j p') i' - (pmulI cO cI cmul ceqb pmul0 q2 (Pos.pred_double j') q') + (pmulI cO cI cmul ceqb pmul0 q2 (Coq_Pos.pred_double j') q') | XH -> mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q2 XH p') i' (pmul0 q' q2)) @@ -785,7 +678,7 @@ let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with match j with | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q2)) q' | XO j0 -> - pmul cO cI cadd cmul ceqb (Pinj ((Pos.pred_double j0), q2)) q' + pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q2)) q' | XH -> pmul cO cI cadd cmul ceqb q2 q' in mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ' @@ -837,6 +730,244 @@ let ppow_N cO cI cadd cmul ceqb p = function | N0 -> p1 cI | Npos p2 -> ppow_pos cO cI cadd cmul ceqb (p1 cI) p p2 +(** val pol_of_PExpr : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) + +let rec pol_of_PExpr cO cI cadd cmul csub copp ceqb = function +| PEO -> p0 cO +| PEI -> p1 cI +| PEc c -> Pc c +| PEX j -> mkX cO cI j +| PEadd (pe1, pe2) -> + (match pe1 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe2) + (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe3) + | _ -> + (match pe2 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe1) + (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe3) + | _ -> + padd cO cadd ceqb (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe1) + (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe2))) +| PEsub (pe1, pe2) -> + psub cO cadd csub copp ceqb + (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe1) + (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe2) +| PEmul (pe1, pe2) -> + pmul cO cI cadd cmul ceqb (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe1) + (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe2) +| PEopp pe1 -> popp copp (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe1) +| PEpow (pe1, n0) -> + ppow_N cO cI cadd cmul ceqb + (pol_of_PExpr cO cI cadd cmul csub copp ceqb pe1) n0 + +type op2 = +| OpEq +| OpNEq +| OpLe +| OpGe +| OpLt +| OpGt + +type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } + +type kind = +| IsProp +| IsBool + +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 + +type eKind = __ + +type 'a bFormula = ('a, eKind, unit0, unit0) gFormula + +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 = (Pos.mul x.qden y.qden) } + +(** val qmult : q -> q -> q **) + +let qmult x y = + { qnum = (Z.mul x.qnum y.qnum); qden = (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 q0 : q **) + +let q0 = + { qnum = Z0; qden = XH } + +(** val q1 : q **) + +let q1 = + { qnum = (Zpos XH); qden = XH } + +type 'c psatz = +| PsatzLet of 'c psatz * 'c psatz +| PsatzIn of nat +| PsatzSquare of 'c pol +| PsatzMulC of 'c pol * 'c psatz +| PsatzMulE of 'c psatz * 'c psatz +| PsatzAdd of 'c psatz * 'c psatz +| PsatzC of 'c +| PsatzZ + +type zWitness = z psatz + +type zArithProof = +| DoneProof +| RatProof of zWitness * zArithProof +| CutProof of zWitness * zArithProof +| SplitProof of z pol * zArithProof * zArithProof +| EnumProof of zWitness * zWitness * zArithProof list +| ExProof of positive * zArithProof + +(** val pEmap : ('a1 -> 'a2) -> 'a1 pExpr -> 'a2 pExpr **) + +let rec pEmap f = function +| PEO -> PEO +| PEI -> PEI +| PEc c -> PEc (f c) +| PEX p -> PEX p +| PEadd (e1, e2) -> PEadd ((pEmap f e1), (pEmap f e2)) +| PEsub (e1, e2) -> PEsub ((pEmap f e1), (pEmap f e2)) +| PEmul (e1, e2) -> PEmul ((pEmap f e1), (pEmap f e2)) +| PEopp e0 -> PEopp (pEmap f e0) +| PEpow (e0, n0) -> PEpow ((pEmap f e0), n0) + +(** val fmap : ('a1 -> 'a2) -> 'a1 formula -> 'a2 formula **) + +let fmap f g = + let { flhs = l; fop = o; frhs = r } = g in + { flhs = (pEmap f l); fop = o; frhs = (pEmap f r) } + +(** val gFmap : + kind -> ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, + 'a5) gFormula **) + +let rec gFmap _ 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, (gFmap k0 fct f1), (gFmap k0 fct f2)) +| OR (k0, f1, f2) -> OR (k0, (gFmap k0 fct f1), (gFmap k0 fct f2)) +| NOT (k0, f0) -> NOT (k0, (gFmap k0 fct f0)) +| IMPL (k0, f1, a, f2) -> IMPL (k0, (gFmap k0 fct f1), a, (gFmap k0 fct f2)) +| IFF (k0, f1, f2) -> IFF (k0, (gFmap k0 fct f1), (gFmap k0 fct f2)) +| EQ (f1, f2) -> EQ ((gFmap IsBool fct f1), (gFmap IsBool fct f2)) + +(** 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) + +(** val apply_option : ('a1 -> 'a2) -> 'a2 -> 'a1 option -> 'a2 **) + +let apply_option f x = function +| Some y -> f y +| None -> x + +(** val bind_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **) + +let bind_option f = + apply_option f None + +(** val map_option : ('a1 -> 'a2) -> 'a1 option -> 'a2 option **) + +let map_option f = + bind_option (fun x -> Some (f x)) + +(** val bind_option2 : + ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **) + +let bind_option2 f o o' = + bind_option (fun o0 -> bind_option (f o0) o') o + +(** val map_option2 : + ('a1 -> 'a2 -> 'a3) -> 'a1 option -> 'a2 option -> 'a3 option **) + +let map_option2 f = + bind_option2 (fun x y -> Some (f x y)) + type ('term, 'annot) clause = ('term * 'annot) list type ('term, 'annot) cnf = ('term, 'annot) clause list @@ -949,40 +1080,6 @@ type op1 = type 'c nFormula = 'c pol * op1 -(** val pExpr_to_Pol : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) - -let rec pExpr_to_Pol cO cI cadd cmul csub copp ceqb = function -| PEc c -> Pc c -| PEX j -> mkX cO cI j -| PEadd (pe1, pe2) -> - (match pe1 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe2) - (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe3) - | _ -> - (match pe2 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) - (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe3) - | _ -> - padd cO cadd ceqb (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) - (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe2))) -| PEsub (pe1, pe2) -> - psub cO cadd csub copp ceqb - (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) - (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe2) -| PEmul (pe1, pe2) -> - pmul cO cI cadd cmul ceqb (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) - (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe2) -| PEopp pe1 -> popp copp (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) -| PEpow (pe1, n0) -> - ppow_N cO cI cadd cmul ceqb - (pExpr_to_Pol cO cI cadd cmul csub copp ceqb pe1) n0 - (** val normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 @@ -990,8 +1087,8 @@ let rec pExpr_to_Pol cO cI cadd cmul csub copp ceqb = function let normalise cO cI cadd cmul csub copp ceqb f = let { flhs = lhs; fop = op; frhs = rhs } = f in - let lhs0 = pExpr_to_Pol cO cI cadd cmul csub copp ceqb lhs in - let rhs0 = pExpr_to_Pol cO cI cadd cmul csub copp ceqb rhs in + let lhs0 = pol_of_PExpr cO cI cadd cmul csub copp ceqb lhs in + let rhs0 = pol_of_PExpr cO cI cadd cmul csub copp ceqb rhs in (match op with | OpEq -> (psub cO cadd csub copp ceqb lhs0 rhs0),Equal | OpNEq -> (psub cO cadd csub copp ceqb lhs0 rhs0),NonEqual @@ -1110,52 +1207,52 @@ let is_bool _ = function | FF _ -> Some false | _ -> None -(** val gFormula_to_cnf : +(** val cnf_of_GFormula : 'a3 -> 'a3 -> ('a3 -> 'a3 -> 'a3) -> ('a3 -> 'a3 -> 'a3) -> ('a1 -> 'a2 -> 'a3) -> ('a1 -> 'a2 -> 'a3) -> bool -> kind -> ('a1, 'a4, 'a2, 'a5) gFormula -> 'a3 **) -let rec gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 pol0 _ = function +let rec cnf_of_GFormula cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 pol0 _ = function | TT _ -> if pol0 then cnf_tt0 else cnf_ff0 | FF _ -> if pol0 then cnf_ff0 else cnf_tt0 | X (_, _) -> cnf_ff0 | A (_, x, t0) -> if pol0 then normalise1 x t0 else negate0 x t0 | AND (k0, e1, e2) -> mk_and or_cnf0 and_cnf0 (fun x x0 x1 -> - gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 x x0 + cnf_of_GFormula cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 x x0 x1) k0 pol0 e1 e2 | OR (k0, e1, e2) -> mk_or or_cnf0 and_cnf0 (fun x x0 x1 -> - gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 x x0 + cnf_of_GFormula cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 x x0 x1) k0 pol0 e1 e2 | NOT (k0, e) -> - gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 + cnf_of_GFormula cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 (negb pol0) k0 e | IMPL (k0, e1, _, e2) -> mk_impl or_cnf0 and_cnf0 (fun x x0 x1 -> - gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 x x0 + cnf_of_GFormula cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 x x0 x1) k0 pol0 e1 e2 | IFF (k0, e1, e2) -> (match is_bool k0 e2 with | Some isb -> - gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 + cnf_of_GFormula cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 (if isb then pol0 else negb pol0) k0 e1 | None -> mk_iff or_cnf0 and_cnf0 (fun x x0 x1 -> - gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 x + cnf_of_GFormula cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 x x0 x1) k0 pol0 e1 e2) | EQ (e1, e2) -> (match is_bool IsBool e2 with | Some isb -> - gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 + cnf_of_GFormula cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 (if isb then pol0 else negb pol0) IsBool e1 | None -> mk_iff or_cnf0 and_cnf0 (fun x x0 x1 -> - gFormula_to_cnf cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 x + cnf_of_GFormula cnf_tt0 cnf_ff0 or_cnf0 and_cnf0 normalise1 negate0 x x0 x1) IsBool pol0 e1 e2) @@ -1315,14 +1412,14 @@ let cnegate = let cis_tauto = is_tauto -(** val cGFormula_to_cnf : +(** val ccnf_of_GFormula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> ('a1 formula, eKind, unit0, unit0) gFormula -> ('a1 nFormula, unit0) cnf **) -let cGFormula_to_cnf cO cI cadd cmul csub copp ceqb cleb = - gFormula_to_cnf cnf_tt cnf_ff (or_cnf (cis_tauto cO cadd ceqb cleb)) +let ccnf_of_GFormula cO cI cadd cmul csub copp ceqb cleb = + cnf_of_GFormula cnf_tt cnf_ff (or_cnf (cis_tauto cO cadd ceqb cleb)) and_cnf (cnormalise cO cI cadd cmul csub copp ceqb cleb) (cnegate cO cI cadd cmul csub copp ceqb cleb) true IsProp @@ -1334,14 +1431,14 @@ let cGFormula_to_cnf cO cI cadd cmul csub copp ceqb cleb = let cTautoChecker cO cI cadd cmul csub copp ceqb cleb f = tauto_checker (fun cl -> cWeakChecker cO cI cadd cmul ceqb cleb (map fst cl)) - (cGFormula_to_cnf cO cI cadd cmul csub copp ceqb cleb f) + (ccnf_of_GFormula cO cI cadd cmul csub copp ceqb cleb f) (** val qTautoChecker : q formula bFormula -> q psatz list -> bool **) let qTautoChecker = cTautoChecker q0 q1 qplus qmult qminus qopp qeq_bool qle_bool -module Coq_Pos = +module Coq0_Pos = struct (** val succ : positive -> positive **) @@ -1787,13 +1884,13 @@ module Coq_Z = | Zpos a0 -> (match b with | Z0 -> abs a - | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) - | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) + | Zpos b0 -> Zpos (Coq0_Pos.gcd a0 b0) + | Zneg b0 -> Zpos (Coq0_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)) + | Zpos b0 -> Zpos (Coq0_Pos.gcd a0 b0) + | Zneg b0 -> Zpos (Coq0_Pos.gcd a0 b0)) end type 'a trace = @@ -2251,10 +2348,10 @@ type 'c polC = 'c pol let rec xdenorm jmp = function | Pc c -> PEc c -| Pinj (j, p2) -> xdenorm (Coq_Pos.add j jmp) p2 +| Pinj (j, p2) -> xdenorm (Coq0_Pos.add j jmp) p2 | PX (p2, j, q2) -> PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp), (Npos j))))), - (xdenorm (Coq_Pos.succ jmp) q2)) + (xdenorm (Coq0_Pos.succ jmp) q2)) (** val denorm : 'a1 pol -> 'a1 pExpr **) @@ -2362,6 +2459,8 @@ let rec vm_add default x v = function (** val zeval_const : z pExpr -> z option **) let rec zeval_const = function +| PEO -> Some Z0 +| PEI -> Some (Zpos XH) | PEc c -> Some c | PEX _ -> None | PEadd (e1, e2) -> map_option2 Coq_Z.add (zeval_const e1) (zeval_const e2) @@ -2395,7 +2494,7 @@ let padd0 = (** val normZ : z pExpr -> z pol **) let normZ = - pExpr_to_Pol Z0 (Zpos XH) Coq_Z.add Coq_Z.mul Coq_Z.sub Coq_Z.opp Coq_Z.eqb + pol_of_PExpr Z0 (Zpos XH) Coq_Z.add Coq_Z.mul Coq_Z.sub Coq_Z.opp Coq_Z.eqb (** val zunsat : z nFormula -> bool **) @@ -2503,7 +2602,7 @@ let zand_cnf = (z formula, eKind, unit0, unit0) gFormula -> (z nFormula, unit0) cnf **) let zGFormula_to_cnf = - gFormula_to_cnf zcnf_tt zcnf_ff zor_cnf zand_cnf normalise0 negate true + cnf_of_GFormula zcnf_tt zcnf_ff zor_cnf zand_cnf normalise0 negate true IsProp (** val ceiling : z -> z -> z **) @@ -2600,14 +2699,14 @@ let mk_eq_pos x y t0 = let rec max_var jmp = function | Pc _ -> jmp -| Pinj (j, p2) -> max_var (Coq_Pos.add j jmp) p2 +| Pinj (j, p2) -> max_var (Coq0_Pos.add j jmp) p2 | PX (p2, _, q2) -> - Coq_Pos.max (max_var jmp p2) (max_var (Coq_Pos.succ jmp) q2) + Coq0_Pos.max (max_var jmp p2) (max_var (Coq0_Pos.succ jmp) q2) (** 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 + fold_left (fun acc f -> Coq0_Pos.max acc (max_var XH (fst f))) l XH (** val zChecker : z nFormula list -> zArithProof -> bool **) @@ -2662,9 +2761,9 @@ let rec zChecker l = function | 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 + if Coq0_Pos.leb x fr + then let z0 = Coq0_Pos.succ fr in + let t0 = Coq0_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 @@ -2676,14 +2775,6 @@ let rec zChecker l = function let zTautoChecker f w = tauto_checker (fun cl -> zChecker (map fst cl)) (zGFormula_to_cnf f) w -(** 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 = @@ -2699,7 +2790,7 @@ let qpower q2 = function (** val normQ : q pExpr -> q pol **) let normQ = - pExpr_to_Pol { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus + pol_of_PExpr { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult qminus qopp qeq_bool (** val cnfQ : @@ -2751,7 +2842,7 @@ type rWitness = q psatz let rTautoChecker f w = tauto_checker (fun cl -> cWeakChecker q0 q1 qplus qmult qeq_bool qle_bool (map fst cl)) - (cGFormula_to_cnf q0 q1 qplus qmult qminus qopp qeq_bool qle_bool + (ccnf_of_GFormula q0 q1 qplus qmult qminus qopp qeq_bool qle_bool (gFmap IsProp (fmap q_of_Rcst) f)) w diff --git a/theories/micromega/EnvRing.v b/theories/micromega/EnvRing.v index b958b884db..ac71dc8a20 100644 --- a/theories/micromega/EnvRing.v +++ b/theories/micromega/EnvRing.v @@ -682,7 +682,7 @@ Qed. (** evaluation of polynomial expressions towards R *) #[local] Notation PEeval := (PEeval - radd rmul rsub ropp phi Cp_phi rpow (@nth R)). + rO rI radd rmul rsub ropp Cp_phi rpow phi (@nth R)). (** Correctness proofs *) @@ -750,7 +750,7 @@ Section POWER. end. Proof. simpl (norm_aux (PEadd _ _)). - destruct pe1; [ | | | | | reflexivity | ]; + destruct pe1; [ | | | | | | | reflexivity | ]; destruct pe2; simpl get_PEopp; reflexivity. Qed. @@ -767,7 +767,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. @@ -787,5 +789,5 @@ Section POWER. End MakeRingPol. -Notation PEeval := (fun add mul sub opp phi pow_phi pow => PEeval - add mul sub opp phi pow_phi pow (@Env.nth _)). +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/QMicromega.v b/theories/micromega/QMicromega.v index 1a6dd58832..a82d4873c4 100644 --- a/theories/micromega/QMicromega.v +++ b/theories/micromega/QMicromega.v @@ -65,9 +65,9 @@ Qed. From Stdlib Require Import EnvRing. #[local] Notation Qeval_expr := (PEeval - Qplus Qmult Qminus Qopp id Z.of_N Qpower). + Q0 Q1 Qplus Qmult Qminus Qopp id Z.of_N Qpower). -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. @@ -146,7 +146,7 @@ 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. diff --git a/theories/micromega/RMicromega.v b/theories/micromega/RMicromega.v index e542c54611..f10eefbcdb 100644 --- a/theories/micromega/RMicromega.v +++ b/theories/micromega/RMicromega.v @@ -378,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 := @@ -436,7 +436,7 @@ Definition Reval_formula (e: PolEnv R) (k: kind) (ff : Formula Rcst) := 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 <-> @@ -459,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: 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. diff --git a/theories/micromega/RingMicromega.v b/theories/micromega/RingMicromega.v index a88301b611..18d05b35ab 100644 --- a/theories/micromega/RingMicromega.v +++ b/theories/micromega/RingMicromega.v @@ -494,11 +494,10 @@ Qed. 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 (@Env.nth R). + PEeval rO rI rplus rtimes rminus ropp pow_phi rpow phi (@Env.nth R). -#[local] Notation eval_formula := (Feval - rplus rtimes rminus ropp isProp req (fun x y => ~ req x y) rle rlt - phi pow_phi rpow (@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 *) @@ -739,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. @@ -806,7 +805,7 @@ Variable phiS : S -> R. Variable phi_C_of_S : forall c, phiS c = phi (C_of_S c). Definition eval_sexpr : PolEnv -> PExpr S -> R := - PEeval rplus rtimes rminus ropp phiS pow_phi rpow (@Env.nth R). + 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 @@ -816,7 +815,7 @@ Lemma eval_pexprSC : forall env s, eval_sexpr env s = eval_pexpr env (PEmap C_of 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. @@ -879,9 +878,9 @@ Notation pmul := Pmul (only parsing). Notation popp := Popp (only parsing). Notation eval_formula := - (fun add mul sub opp eqProp le lt phi pow_phi pow => Feval - add mul sub opp isProp eqProp (fun x y => ~ eqProp x y) le lt - phi pow_phi pow (@Env.nth _)). + (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/ZMicromega.v b/theories/micromega/ZMicromega.v index b2b1a3a3fd..f1c5a41ae5 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -102,8 +102,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) @@ -113,12 +115,14 @@ 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 + | 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) @@ -200,7 +204,7 @@ Definition Zeval_formula (env : PolEnv Z) (k: kind) (f : Formula Z):= (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 isProp f. Proof. @@ -219,10 +223,10 @@ Proof. repeat rewrite Zeval_expr_compat. unfold Zeval_formula' ; simpl. unfold eval_expr, eval_pexpr. - generalize (micromega_eval.PEeval Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) (@Env.nth Z) env Flhs). - generalize (micromega_eval.PEeval Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) (@Env.nth Z) env Frhs). + 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. @@ -341,10 +345,10 @@ Proof. destruct o eqn:O ; cbn ; rewrite ?eval_pol_sub; rewrite <- !eval_pol_norm ; simpl in *; unfold eval_expr, eval_pexpr; - generalize (micromega_eval.PEeval Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) (@Env.nth Z) env lhs); - generalize (micromega_eval.PEeval Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) (@Env.nth Z) env rhs); intros z z0. + 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. @@ -833,10 +837,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 vars (jmp : positive) (p : Pol Z) : list positive := diff --git a/theories/micromega/micromega_checker.v b/theories/micromega/micromega_checker.v index 91a465d716..9e1f39eb07 100644 --- a/theories/micromega/micromega_checker.v +++ b/theories/micromega/micromega_checker.v @@ -41,291 +41,6 @@ Definition bind_option2 aT a'T rT (f : aT -> a'T -> option rT) o o' := Definition map_option2 aT a'T rT (f : aT -> a'T -> rT) := bind_option2 (fun x y => Some (f x y)). -(** * Basic arithmetic operations on Horner polynomials [Pol] - -One can prove that an eval function [Peval] commutes with -each operation, e.g., [Peval l (Padd P P') = Peval l P + Peval l P'] *) -Section PolOps. - -(** Coefficients *) -Variable (C : Type) (cO cI : C) (cadd cmul csub : C -> C -> C) (copp : C -> C). -Variable ceqb : C -> C -> bool. - -Implicit Type P : Pol C. - -(** Equality *) -Fixpoint Peq P P' {struct P'} : bool := - match P, P' with - | Pc c, Pc c' => ceqb c c' - | Pinj j Q, Pinj j' Q' => - match Pos.compare j j' with - | Eq => Peq Q Q' - | _ => false - end - | PX P i Q, PX P' i' Q' => - match Pos.compare i i' with - | Eq => if Peq P P' then Peq Q Q' else false - | _ => false - end - | _, _ => false - end. - -(** Constructors *) - -Definition P0 := Pc cO. -Definition P1 := Pc cI. - -Definition mkPinj j P := - match P with - | Pc _ => P - | Pinj j' Q => Pinj (Pos.add 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 mkX j := mkPinj_pred j (PX P1 1 P0). - -Definition mkPX P i Q := - match P with - | Pc c => if ceqb c cO then mkPinj xH Q else PX P i Q - | Pinj _ _ => PX P i Q - | PX P' i' Q' => if Peq Q' P0 then PX P' (Pos.add i' i) Q else PX P i Q - end. - -(** Opposite *) -Fixpoint Popp P : Pol C := - match P with - | Pc c => Pc (copp c) - | Pinj j Q => Pinj j (Popp Q) - | PX P i Q => PX (Popp P) i (Popp Q) - end. - -(** Addition and subtraction *) - -Fixpoint PaddC P c : Pol C := - match P with - | Pc c1 => Pc (cadd c1 c) - | Pinj j Q => Pinj j (PaddC Q c) - | PX P i Q => PX P i (PaddC Q c) - end. - -Fixpoint PsubC P c : Pol C := - match P with - | Pc c1 => Pc (csub 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 C -> Pol C -> Pol C. -Variable Q : Pol C. - -(** [P + Pinj j Q], assuming [Pop . Q] is [. + Q] *) -Fixpoint PaddI (j : positive) P : Pol C := - 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. - -(** [P - Pinj j Q], assuming [Pop . Q] is [. - Q] *) -Fixpoint PsubI (j : positive) P : Pol C := - match P with - | Pc c => mkPinj j (PaddC (Popp 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 C. - -(** [P + PX P' i' P0], assumin [Pop . P'] is [. + P'] *) -Fixpoint PaddX (i' : positive) P : Pol C := - 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. - -(** [P - PX P' i' P0], assumin [Pop . P'] is [. - P'] *) -Fixpoint PsubX (i' : positive) P : Pol C := - match P with - | Pc c => PX (Popp P') i' P - | Pinj j Q' => - match j with - | xH => PX (Popp P') i' Q' - | xO j => PX (Popp P') i' (Pinj (Pos.pred_double j) Q') - | xI j => PX (Popp 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' {struct P'} : Pol C := - 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. - -Fixpoint Psub P P' {struct P'} : Pol C := - 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 (Popp P') i' (PaddC (Popp Q') c) - | Pinj j Q => - match j with - | xH => PX (Popp P') i' (Psub Q Q') - | xO j => PX (Popp P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') - | xI j => PX (Popp 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. - -(** Multiplication *) - -Fixpoint PmulC_aux P c : Pol C := - match P with - | Pc c' => Pc (cmul 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 ceqb c cO then P0 else - if ceqb c cI then P else PmulC_aux P c. - -(** [P * Pinj j Q], assuming [Pmul . Q] is [. * Q] *) -Section PmulI. -Variable Pmul : Pol C -> Pol C -> Pol C. -Variable Q : Pol C. -Fixpoint PmulI (j : positive) P : Pol C := - 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'' {struct P''} : Pol C := - 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 - Padd (mkPX (Padd (mkPX PP' i P0) QP') i' P0) (mkPX PQ' i QQ') - end - end. - -Fixpoint Psquare P : Pol C := - match P with - | Pc c => Pc (cmul c c) - | Pinj j Q => Pinj j (Psquare Q) - | PX P i Q => - let twoPQ := Pmul P (mkPinj xH (PmulC Q (cadd cI cI))) in - let Q2 := Psquare Q in - let P2 := Psquare P in - mkPX (Padd (mkPX P2 i P0) twoPQ) i Q2 - end. - -Fixpoint Ppow_pos (res P : Pol C) (p : positive) : Pol C := - match p with - | xH => Pmul res P - | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => Pmul (Ppow_pos (Ppow_pos res P p) P p) P - end. - -Definition Ppow_N P n := match n with N0 => P1 | Npos p => Ppow_pos P1 P p end. - -End PolOps. - (** * Boolean formulas in Conjunctive Normal Form (CNF) *) Section CNF. @@ -415,6 +130,12 @@ Variables cadd cmul csub : C -> C -> C. Variable copp : C -> C. Variables ceqb cleb : C -> C -> bool. +#[local] Notation Pol_of_PExpr := (Pol_of_PExpr cO cI cadd cmul csub copp ceqb). +#[local] Notation Popp := (Popp copp). +#[local] Notation Padd := (Padd cO cadd ceqb). +#[local] Notation Psub := (Psub cO cadd csub copp ceqb). +#[local] Notation Pmul := (Pmul cO cI cadd cmul ceqb). + Definition cneqb (x y : C) := negb (ceqb x y). Definition cltb (x y : C) := andb (cleb x y) (cneqb x y). @@ -426,26 +147,6 @@ Variant Op1 : Set := (** relations with 0 *) Definition NFormula : Type := Pol C * Op1. (** normalized formula *) -#[local] Notation mkX := (mkX cO cI). -#[local] Notation Popp := (Popp copp). -#[local] Notation Padd := (Padd cO cadd ceqb). -#[local] Notation Psub := (Psub cO cadd csub copp ceqb). -#[local] Notation Pmul := (Pmul cO cI cadd cmul ceqb). -#[local] Notation Ppow_N := (Ppow_N cO cI cadd cmul ceqb). - -Fixpoint Pol_of_PExpr (pe : PExpr C) : Pol C := - match pe with - | PEc c => Pc c - | PEX j => mkX j - | PEadd (PEopp pe1) pe2 => Psub (Pol_of_PExpr pe2) (Pol_of_PExpr pe1) - | PEadd pe1 (PEopp pe2) => Psub (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) - | PEadd pe1 pe2 => Padd (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) - | PEsub pe1 pe2 => Psub (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) - | PEmul pe1 pe2 => Pmul (Pol_of_PExpr pe1) (Pol_of_PExpr pe2) - | PEopp pe1 => Popp (Pol_of_PExpr pe1) - | PEpow pe1 n => Ppow_N (Pol_of_PExpr pe1) n - end. - (** We normalize Formulas by moving terms to one side *) Definition normalise (f : Formula C) : NFormula := let (lhs, op, rhs) := f in diff --git a/theories/micromega/micromega_eval.v b/theories/micromega/micromega_eval.v index 3a553b9428..0c53ee838b 100644 --- a/theories/micromega/micromega_eval.v +++ b/theories/micromega/micromega_eval.v @@ -19,34 +19,19 @@ From Corelib Require Import PosDef. From Stdlib Require Import micromega_formula micromega_witness. +From Stdlib Require Export ring_eval. Set Implicit Arguments. Section Feval. -Variable R : Type. -Variable (rO rI : R) (radd rmul rsub: R -> R -> R) (ropp : R -> R). -Variable (k : kind) (req rneq rle rlt : R -> R -> eKind k). - -Variable C : Type. -Variable C2R : C -> R. - -Variable Cpow : Type. -Variable N2Cpow : N -> Cpow. -Variable rpow : R -> Cpow -> R. - -Variable Env : Type. -Variable env_nth : positive -> Env -> R. - -Fixpoint PEeval l pe : R := - match pe with - | PEc c => C2R c - | PEX j => env_nth j l - | PEadd pe1 pe2 => radd (PEeval l pe1) (PEeval l pe2) - | PEsub pe1 pe2 => rsub (PEeval l pe1) (PEeval l pe2) - | PEmul pe1 pe2 => rmul (PEeval l pe1) (PEeval l pe2) - | PEopp pe1 => ropp (PEeval l pe1) - | PEpow pe1 n => rpow (PEeval l pe1) (N2Cpow n) - end. +Variables (R : Type) (rO rI : R) (radd rmul rsub: R -> R -> R) (ropp : R -> R). +Variables (Cpow : Type) (Cpow_of_N : N -> Cpow) (rpow : R -> Cpow -> R). +Variables (k : kind) (req rneq rle rlt : R -> R -> eKind k). +Variables (C : Type) (R_of_C : C -> R). +Variables (Env : Type) (env_nth : positive -> Env -> R). + +#[local] Notation PEeval := (PEeval + rO rI radd rmul rsub ropp Cpow_of_N rpow R_of_C env_nth). Definition eval_op2 (o : Op2) (x y : R) : eKind k := match o with @@ -117,25 +102,9 @@ End GFormulaEval. Definition BFeval eqb {A : Type} (ea : forall (k : kind), A -> eKind k) (k : kind) (f : BFormula A k) := GFeval eqb (fun k x => x) ea f. -Section Fmap. -Variables (T T' : Type) (f : T -> T'). - -Fixpoint PEmap (e : PExpr T) : PExpr T' := - match e with - | PEc c => PEc (f c) - | PEX p => PEX p - | PEadd e1 e2 => PEadd (PEmap e1) (PEmap e2) - | PEsub e1 e2 => PEsub (PEmap e1) (PEmap e2) - | PEmul e1 e2 => PEmul (PEmap e1) (PEmap e2) - | PEopp e => PEopp (PEmap e) - | PEpow e n => PEpow (PEmap e) n - end. - -Definition Fmap (f : Formula T) : Formula T' := - let 'Build_Formula l o r := f in - Build_Formula (PEmap l) o (PEmap r). - -End Fmap. +Definition Fmap T T' (f : T -> T') (g : Formula T) : Formula T' := + let 'Build_Formula l o r := g in + Build_Formula (PEmap f l) o (PEmap f r). Section GFormulaMap. Context {TA TA' : Type} {TX : kind -> Type} {AA : Type} {AF : Type}. @@ -155,27 +124,14 @@ Fixpoint GFmap (k : kind) (fct : TA -> TA') (f : @GFormula TA TX AA AF k) : end. End GFormulaMap. -Section Pmap. -Variables (T T' : Type) (f : T -> T'). -Fixpoint Pmap (P : Pol T) : Pol T' := - match P with - | Pc c => Pc (f c) - | Pinj j P => Pinj j (Pmap P) - | PX P i Q => PX (Pmap P) i (Pmap Q) - end. -End Pmap. - -Section PsatzMap. -Variables (T T' : Type) (f : T -> T'). -Fixpoint Psatz_map (e : Psatz T) : Psatz T' := +Fixpoint Psatz_map T T' (f : T -> T') (e : Psatz T) : Psatz T' := match e with - | PsatzLet p1 p2 => PsatzLet (Psatz_map p1) (Psatz_map p2) + | PsatzLet p1 p2 => PsatzLet (Psatz_map f p1) (Psatz_map f p2) | PsatzIn _ n => PsatzIn T' n | PsatzSquare e => PsatzSquare (Pmap f e) - | PsatzMulC re e => PsatzMulC (Pmap f re) (Psatz_map e) - | PsatzMulE f1 f2 => PsatzMulE (Psatz_map f1) (Psatz_map f2) - | PsatzAdd f1 f2 => PsatzAdd (Psatz_map f1) (Psatz_map f2) + | PsatzMulC re e => PsatzMulC (Pmap f re) (Psatz_map f e) + | PsatzMulE f1 f2 => PsatzMulE (Psatz_map f f1) (Psatz_map f f2) + | PsatzAdd f1 f2 => PsatzAdd (Psatz_map f f1) (Psatz_map f f2) | PsatzC c => PsatzC (f c) | PsatzZ _ => PsatzZ T' end. -End PsatzMap. diff --git a/theories/micromega/micromega_formula.v b/theories/micromega/micromega_formula.v index 3f7a59b030..75cbc08ce3 100644 --- a/theories/micromega/micromega_formula.v +++ b/theories/micromega/micromega_formula.v @@ -18,21 +18,10 @@ and use the identical file in Corelib instead *) From Stdlib Require Import PosDef. +From Stdlib Require Export ring_checker. Set Implicit Arguments. -(** 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. diff --git a/theories/micromega/micromega_witness.v b/theories/micromega/micromega_witness.v index 5939f5524c..2581ba76ff 100644 --- a/theories/micromega/micromega_witness.v +++ b/theories/micromega/micromega_witness.v @@ -12,35 +12,10 @@ and use the identical file in Corelib instead *) From Stdlib Require Import BinNums RatDef. +From Stdlib Require Export ring_checker. Set Implicit Arguments. -(** 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] whose coefficients - are polynomials with [n-1] variables (C[X2..Xn]). - There are several optimisations to make the repr more compact: - - [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. From aeb2334ad0253af7e9241b6021748dae0a138cad Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Tue, 9 Sep 2025 11:19:48 +0200 Subject: [PATCH 14/14] Add overlay --- .nix/config.nix | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/.nix/config.nix b/.nix/config.nix index d58daefbc9..f24a50c664 100644 --- a/.nix/config.nix +++ b/.nix/config.nix @@ -224,6 +224,7 @@ with builtins; with (import {}).lib; "metacoq-translations" "metacoq-utils" "metarocq" + "metarocq-common" "metarocq-erasure" "metarocq-erasure-plugin" "metarocq-pcuic" @@ -231,7 +232,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" @@ -265,6 +269,10 @@ 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:stdlib207"; + metarocq.override.version = "proux01:stdlib207"; + metarocq-test.override.version = "proux01:stdlib207"; + mathcomp-algebra-tactics.override.version = "proux01:stdlib207"; 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 @@ -303,15 +311,13 @@ 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"; perennial.job = false; # broken 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"; @@ -341,13 +347,12 @@ with builtins; with (import {}).lib; equations.override.version = "1.3.1+9.0"; equations-test.job = false; fiat-parsers.job = false; # broken - metarocq.override.version = "1.4-9.0"; mtac2.override.version = "1cdb2cb628444ffe9abc6535f6d2e11004de7fc1"; paramcoq-test.override.version = "32609ca4a9bf4a0e456a855ea5118d8c00cda6be"; perennial.job = false; # broken relation-algebra.override.version = "7966d1a7bb524444120c56c3474717bcc91a5215"; rocq-lean-import.override.version = "c513cee4f5edf8e8a06ba553ca58de5142cffde6"; - smtcoq.override.version = "5c6033c906249fcf98a48b4112f6996053124514"; + # smtcoq.override.version = "5c6033c906249fcf98a48b4112f6996053124514"; # smtcoq-trakt.override.version = "9392f7446a174b770110445c155a07b183cdca3d"; stalmarck-tactic.override.version = "d32acd3c477c57b48dd92bdd96d53fb8fa628512"; unicoq.override.version = "a9b72f755539c0b3280e38e778a09e2b7519a51a";