diff --git a/.github/workflows/docker-action.yml b/.github/workflows/docker-action.yml index f83ceda..43d2629 100644 --- a/.github/workflows/docker-action.yml +++ b/.github/workflows/docker-action.yml @@ -17,11 +17,13 @@ jobs: strategy: matrix: image: - - 'mathcomp/mathcomp:1.15.0-coq-8.16' - - 'mathcomp/mathcomp:1.16.0-coq-8.16' - - 'mathcomp/mathcomp:1.16.0-coq-8.17' - - 'mathcomp/mathcomp:1.17.0-coq-8.16' - - 'mathcomp/mathcomp:1.17.0-coq-8.17' + - 'mathcomp/mathcomp:2.0.0-coq-8.16' + - 'mathcomp/mathcomp:2.0.0-coq-8.17' + - 'mathcomp/mathcomp:2.0.0-coq-8.18' + - 'mathcomp/mathcomp-dev:coq-8.16' + - 'mathcomp/mathcomp-dev:coq-8.17' + - 'mathcomp/mathcomp-dev:coq-8.18' + - 'mathcomp/mathcomp-dev:coq-dev' fail-fast: false steps: - uses: actions/checkout@v3 diff --git a/.gitignore b/.gitignore index 4c1bf7a..40da6a3 100644 --- a/.gitignore +++ b/.gitignore @@ -15,6 +15,7 @@ Make*.coq.conf *# .lia.cache .nia.cache +.nra.cache examples/.csdp.cache examples/.nra.cache examples/trace diff --git a/Make.test-suite b/Make.test-suite index 9df21a5..8c63429 100644 --- a/Make.test-suite +++ b/Make.test-suite @@ -3,7 +3,6 @@ examples/field_examples_no_check.v examples/ring_examples_check.v examples/ring_examples_no_check.v examples/from_sander.v -examples/zmodule.v examples/lra_examples.v -R examples mathcomp.algebra_tactics.examples diff --git a/README.md b/README.md index fe899ca..33f9c4d 100644 --- a/README.md +++ b/README.md @@ -30,9 +30,9 @@ ring/field expressions before applying the proof procedures. - License: [CeCILL-B Free Software License Agreement](CeCILL-B) - Compatible Coq versions: 8.16 or later - Additional dependencies: - - [MathComp](https://math-comp.github.io) ssreflect 1.15 or later + - [MathComp](https://math-comp.github.io) ssreflect 2.0 or later - [MathComp](https://math-comp.github.io) algebra - - [Mczify](https://github.com/math-comp/mczify) 1.1.0 or later + - [Mczify](https://github.com/math-comp/mczify) 1.4.0 or later - [Coq-Elpi](https://github.com/LPCIC/coq-elpi) 1.15.0 or later (known not to work with 1.17.0) - Coq namespace: `mathcomp.algebra_tactics` - Related publication(s): diff --git a/coq-mathcomp-algebra-tactics.opam b/coq-mathcomp-algebra-tactics.opam index 157699a..1130fe8 100644 --- a/coq-mathcomp-algebra-tactics.opam +++ b/coq-mathcomp-algebra-tactics.opam @@ -26,9 +26,9 @@ build: [make "-j%{jobs}%"] install: [make "install"] depends: [ "coq" {>= "8.16"} - "coq-mathcomp-ssreflect" {>= "1.15"} + "coq-mathcomp-ssreflect" {>= "2.0"} "coq-mathcomp-algebra" - "coq-mathcomp-zify" {>= "1.1.0"} + "coq-mathcomp-zify" {>= "1.4.0"} "coq-elpi" {>= "1.15.0" & != "1.17.0"} ] diff --git a/examples/lra_examples.v b/examples/lra_examples.v index 1249fe8..a89d2e5 100644 --- a/examples/lra_examples.v +++ b/examples/lra_examples.v @@ -46,6 +46,26 @@ Proof. lra. Qed. +Example test_div_mul x : 1 / (2 * x) <= 1 / 2 / x + 1. +Proof. +lra. +Qed. + +Example test_div_inv x : 1 / x^-1 <= x + 1. +Proof. +lra. +Qed. + +Example test_div_opp x : (- x)^-1 <= - x^-1 + 1. +Proof. +lra. +Qed. + +Example test_div_exp x : (x ^+ 2) ^-1 <= x ^-1 ^+ 2 + 1. +Proof. +lra. +Qed. + Lemma test_lt x y : x + 2%:R * y < 3%:R -> 2%:R * x + y <= 3%:R -> x + y < 2%:R. Proof. diff --git a/examples/zmodule.v b/examples/zmodule.v deleted file mode 100644 index 86459e0..0000000 --- a/examples/zmodule.v +++ /dev/null @@ -1,530 +0,0 @@ -(* This file demonstrates the implementation techniques behind Algebra *) -(* Tactics by applying them to `zmodType`s (additive Abelian groups). *) -(* This example is also described in the following paper: *) -(* Kazuhiko Sakaguchi. Reflexive tactics for algebra, revisited. *) - -From elpi Require Export elpi. -From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat choice seq. -From mathcomp Require Import fintype finfun bigop order ssralg ssrnum ssrint. -From mathcomp Require Import rat zify. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Import GRing.Theory. - -Local Open Scope ring_scope. - -Notation zeroz := (Posz 0). -Notation addz := intZmod.addz. -Notation oppz := intZmod.oppz. - -(******************************************************************************) -(* Section 2.1 *) -(******************************************************************************) - -Module Section_2_1. - -Structure eqType := { eq_sort : Type; eq_op : eq_sort -> eq_sort -> bool }. - -Definition nat_eqType : eqType := {| eq_sort := nat; eq_op := eqn |}. - -Fail Check eq_op 0%N 1%N. - -Canonical nat_eqType. - -Check eq_op 0%N 1%N. - -Definition prod_eqType (T1 T2 : eqType) := - {| eq_sort := eq_sort T1 * eq_sort T2; - eq_op := fun x y => eq_op x.1 y.1 && eq_op x.2 y.2 |}. - -Fail Check eq_op (0, 0)%N (0, 1)%N. - -Canonical prod_eqType. - -Check eq_op (0, 0)%N (0, 1)%N. - -Coercion eq_sort : eqType >-> Sortclass. - -End Section_2_1. - -(******************************************************************************) -(* Normalizing Z-module expressions to formal sums by reflection *) -(******************************************************************************) - -Inductive AGExpr : Type := - | AGX : nat -> AGExpr - | AGO : AGExpr - | AGOpp : AGExpr -> AGExpr - | AGAdd : AGExpr -> AGExpr -> AGExpr. - -Section AGeval. - -Variables (V : Type) (zero : V) (opp : V -> V) (add : V -> V -> V). - -Definition mulz (x : V) (n : int) := - match n with - | Posz n => iterop n add x zero - | Negz n => opp (iterop n.+1 add x zero) - end. - -Fixpoint AGeval (varmap : seq V) (e : AGExpr) : V := - match e with - | AGX j => nth zero varmap j - | AGO => zero - | AGOpp e1 => opp (AGeval varmap e1) - | AGAdd e1 e2 => add (AGeval varmap e1) (AGeval varmap e2) - end. - -Fixpoint AGnorm (e : AGExpr) : seq int := - match e with - | AGX j => ncons j 0 [:: 1] - | AGO => [::] - | AGOpp e1 => map -%R (AGnorm e1) - | AGAdd e1 e2 => - (fix add_rec (xs ys : seq int) : seq int := - match xs, ys with - | [::], s | s, [::] => s - | x :: xs, y :: ys => (x + y) :: add_rec xs ys - end) (AGnorm e1) (AGnorm e2) - end. - -Definition AGsubst (varmap : seq V) (e : seq int) : V := - foldr (fun p n => add (mulz p.1 p.2) n) zero (zip varmap e). - -End AGeval. - -Lemma AG_norm_subst (V : zmodType) (varmap : seq V) (e : AGExpr) : - AGsubst 0 -%R +%R varmap (AGnorm e) = AGeval 0 -%R +%R varmap e. -Proof. -rewrite /AGsubst -[mulz _ _ _]/*~%R. -elim: e => /= [j||e1 <-|e1 <- e2 <-]. -- elim: j varmap => [|j IHj] [|x varmap] //=. - by case: varmap => [|? ?]; rewrite /AGsubst /= mulr1z addr0. - by rewrite /AGsubst /= mulr0z add0r; exact: IHj. -- by case: varmap. -- by elim: (AGnorm e1) varmap => [|x xs IHxs] [|v varmap]; - rewrite /AGsubst /= ?oppr0 // opprD -IHxs raddfN. -- move: (AGnorm e1) (AGnorm e2) varmap. - elim=> [|x xs IHxs] [|y ys] [|v varmap]; - rewrite /AGsubst /= ?(add0r, addr0) //. - by rewrite addrACA -IHxs raddfD. -Qed. - -Lemma AG_correct (V : zmodType) (varmap : seq V) (e1 e2 : AGExpr) : - all (fun i => i == 0) (AGnorm (AGAdd e1 (AGOpp e2))) = true -> - AGeval 0 -%R +%R varmap e1 = AGeval 0 -%R +%R varmap e2. -Proof. -rewrite -!AG_norm_subst /AGsubst -[mulz _ _ _]/*~%R /=. -move: (AGnorm e1) (AGnorm e2) varmap. -elim=> [|x xs IH] [|y ys] [|v varmap] //=. -- rewrite oppr_eq0 => /andP[/eqP ->] /=; rewrite mulr0z add0r. - elim: ys varmap => [|{}y ys IH] [|{}v varmap] //=. - by rewrite oppr_eq0 => /andP[/eqP -> /IH <-]; rewrite mulr0z add0r. -- move=> /andP[/eqP ->] /=; rewrite mulr0z add0r. - elim: xs varmap {IH} => [|{}x xs IH] [|{}v varmap] //=. - by move=> /andP[/eqP -> /IH ->]; rewrite mulr0z add0r. -- by rewrite subr_eq0 => /andP[/eqP -> /IH] ->. -Qed. - -Lemma int_norm_subst (varmap : seq int) (e : AGExpr) : - AGsubst zeroz oppz addz varmap (AGnorm e) = - AGeval zeroz oppz addz varmap e. -Proof. exact: AG_norm_subst. Qed. - -Lemma int_correct (varmap : seq int) (e1 e2 : AGExpr) : - all (fun i => i == zeroz) (AGnorm (AGAdd e1 (AGOpp e2))) = true -> - AGeval zeroz oppz addz varmap e1 = AGeval zeroz oppz addz varmap e2. -Proof. exact: AG_correct. Qed. - -(******************************************************************************) -(* Section 2.3 and 2.4 *) -(******************************************************************************) - -Ltac int_zmodule_reflection VarMap ZE1 ZE2 := - apply: (@int_correct VarMap ZE1 ZE2); [vm_compute; reflexivity]. - -Elpi Tactic int_zmodule. -Elpi Accumulate lp:{{ - -pred list-constant o:term, o:list term, o:term. -list-constant T [] {{ @nil lp:T }} :- !. -list-constant T [X|XS] {{ @cons lp:T lp:X lp:XS' }} :- list-constant T XS XS'. - -% [quote In Out VarMap] -pred quote i:term, o:term, o:list term. -quote {{ zeroz }} {{ AGO }} _ :- !. -quote {{ oppz lp:In1 }} {{ AGOpp lp:Out1 }} VarMap :- !, - quote In1 Out1 VarMap. -quote {{ addz lp:In1 lp:In2 }} {{ AGAdd lp:Out1 lp:Out2 }} VarMap :- !, - quote In1 Out1 VarMap, quote In2 Out2 VarMap. -quote In {{ AGX lp:N }} VarMap :- !, mem VarMap In N. - -pred mem o:list term, o:term, o:term. -mem [X|_] X {{ O }} :- !. -mem [_|XS] X {{ S lp:N }} :- !, mem XS X N. - -pred close o:list term. -close [] :- !. -close [_|XS] :- close XS. - -pred zmod-reflection i:term, i:term, i:term, i:goal, o:list sealed-goal. -zmod-reflection VarMap ZE1 ZE2 G GS :- - coq.ltac.call "int_zmodule_reflection" [trm VarMap, trm ZE1, trm ZE2] G GS. -zmod-reflection VarMap ZE1 ZE2 _ _ :- - coq.ltac.fail 0 "Not a valid Z-module equation" VarMap ZE1 ZE2. - -pred solve i:goal, o:list sealed-goal. -solve (goal _ _ {{ @eq int lp:T1 lp:T2 }} _ _ as G) GS :- - quote T1 ZE1 VarMap, !, - quote T2 ZE2 VarMap, !, - close VarMap, !, - list-constant {{ int }} VarMap VarMap', !, - zmod-reflection VarMap' ZE1 ZE2 G GS. -solve G _ :- coq.ltac.fail 0 "The goal is not an integer equation" G. - -}}. -Elpi Typecheck. - -Section Examples. - -Local Open Scope int_scope. - -Local Notation "0" := (Posz O) : int_scope. -Local Notation "- x" := (oppz x%Z) : int_scope. -Local Notation "x + y" := (addz x%Z y%Z) : int_scope. - -Goal forall (x y : int), (x + (- y)) + x = (- y) + (x + x). -Proof. -move=> x y. -exact: -(let e1 := AGAdd (AGAdd (AGX 0) (AGOpp (AGX 1))) (AGX 0) in - let e2 := AGAdd (AGOpp (AGX 1)) (AGAdd (AGX 0) (AGX 0)) in - @int_correct [:: x; y] e1 e2 erefl). -Restart. -move=> x y. -elpi int_zmodule. -Qed. - -End Examples. - -(******************************************************************************) -(* Section 3.1 *) -(******************************************************************************) - -Ltac poly_zmodule_reflection V VarMap ZE1 ZE2 := - apply: (@AG_correct V VarMap ZE1 ZE2); [vm_compute; reflexivity]. - -Elpi Tactic fail_zmodule. -Elpi Accumulate lp:{{ - -pred list-constant o:term, o:list term, o:term. -list-constant T [] {{ @nil lp:T }} :- !. -list-constant T [X|XS] {{ @cons lp:T lp:X lp:XS' }} :- list-constant T XS XS'. - -% [quote V In Out VarMap] -pred quote i:term, i:term, o:term, o:list term. -quote V {{ @GRing.zero lp:V }} {{ AGO }} _ :- !. -quote V {{ @GRing.opp lp:V lp:In1 }} {{ AGOpp lp:Out1 }} VarMap :- !, - quote V In1 Out1 VarMap. -quote V {{ @GRing.add lp:V lp:In1 lp:In2 }} {{ AGAdd lp:Out1 lp:Out2 }} VarMap :- !, - quote V In1 Out1 VarMap, quote V In2 Out2 VarMap. -quote _ In {{ AGX lp:N }} VarMap :- !, mem VarMap In N. - -pred mem o:list term, o:term, o:term. -mem [X|_] X {{ O }} :- !. -mem [_|XS] X {{ S lp:N }} :- !, mem XS X N. - -pred close o:list term. -close [] :- !. -close [_|XS] :- close XS. - -pred zmod-reflection i:term, i:term, i:term, i:term, i:goal, o:list sealed-goal. -zmod-reflection V VarMap ZE1 ZE2 G GS :- - coq.ltac.call "poly_zmodule_reflection" - [trm V, trm VarMap, trm ZE1, trm ZE2] G GS. -zmod-reflection _ _ _ _ _ _ :- - coq.ltac.fail 0 "Not a valid Z-module equation". - -pred solve i:goal, o:list sealed-goal. -solve (goal _ _ {{ @eq lp:Ty lp:T1 lp:T2 }} _ [trm V] as G) GS :- - @ltacfail! 0 => std.assert-ok! - (coq.unify-eq {{ GRing.Zmodule.sort lp:V }} Ty) - "The goal is not an equation of the given Z-module", !, - quote V T1 ZE1 VarMap, !, - quote V T2 ZE2 VarMap, !, - close VarMap, !, - list-constant Ty VarMap VarMap', !, - zmod-reflection V VarMap' ZE1 ZE2 G GS. -solve G _ :- coq.ltac.fail 0 "The goal is not an equation" G. - -}}. -Elpi Typecheck. - -Goal forall x y : [zmodType of int * int], x + y + x = y + x + x. -Proof. -move=> x y. -elpi fail_zmodule ([zmodType of int * int]). -Qed. - -Goal forall x : int, x + 1 = 1 + x. -Proof. -Fail elpi fail_zmodule (int_ZmodType). -Abort. - -(******************************************************************************) -(* Section 3.2 *) -(******************************************************************************) - -Elpi Tactic poly_zmodule. -Elpi Accumulate lp:{{ - -pred list-constant o:term, o:list term, o:term. -list-constant T [] {{ @nil lp:T }} :- !. -list-constant T [X|XS] {{ @cons lp:T lp:X lp:XS' }} :- list-constant T XS XS'. - -% [quote V In Out VarMap] -pred quote i:term, i:term, o:term, o:list term. -quote V {{ @GRing.zero lp:V' }} {{ AGO }} _ :- coq.unify-eq V V' ok, !. -quote V {{ @GRing.opp lp:V' lp:In1 }} {{ AGOpp lp:Out1 }} VarMap :- - coq.unify-eq V V' ok, !, quote V In1 Out1 VarMap. -quote V {{ @GRing.add lp:V' lp:In1 lp:In2 }} {{ AGAdd lp:Out1 lp:Out2 }} VarMap :- - coq.unify-eq V V' ok, !, quote V In1 Out1 VarMap, quote V In2 Out2 VarMap. -quote _ In {{ AGX lp:N }} VarMap :- !, mem VarMap In N. - -pred mem o:list term, o:term, o:term. -mem [X|_] X {{ O }} :- !. -mem [_|XS] X {{ S lp:N }} :- !, mem XS X N. - -pred close o:list term. -close [] :- !. -close [_|XS] :- close XS. - -pred zmod-reflection i:term, i:term, i:term, i:term, i:goal, o:list sealed-goal. -zmod-reflection V VarMap ZE1 ZE2 G GS :- - coq.ltac.call "poly_zmodule_reflection" - [trm V, trm VarMap, trm ZE1, trm ZE2] G GS. -zmod-reflection _ _ _ _ _ _ :- - coq.ltac.fail 0 "Not a valid Z-module equation". - -pred solve i:goal, o:list sealed-goal. -solve (goal _ _ {{ @eq lp:Ty lp:T1 lp:T2 }} _ _ as G) GS :- - @ltacfail! 0 => std.assert-ok! - (coq.unify-eq {{ GRing.Zmodule.sort lp:V }} Ty) - "Cannot find a declared Z-module", !, - quote V T1 ZE1 VarMap, !, - quote V T2 ZE2 VarMap, !, - close VarMap, !, - list-constant Ty VarMap VarMap', !, - zmod-reflection V VarMap' ZE1 ZE2 G GS. -solve G _ :- coq.ltac.fail 0 "The goal is not a Z-module equation" G. - -}}. -Elpi Typecheck. - -Goal forall (x y : int * int), x + y + x = y + x + x. -Proof. -move=> x y. -elpi poly_zmodule. -Qed. - -Goal forall x : int, x + 1 = 1 + x. -Proof. -move=> x. -elpi poly_zmodule. -Qed. - -(******************************************************************************) -(* Section 4 *) -(******************************************************************************) - -Module Type ZmodSubSig. -Parameter subr : forall U : zmodType, U -> U -> U. -Axiom subrE : subr = (fun _ x y => x + - y). -End ZmodSubSig. - -Module Import ZmodSub : ZmodSubSig. -Definition subr (U : zmodType) (x y : U) := x - y. -Definition subrE := erefl subr. -End ZmodSub. - -Implicit Types (U V : zmodType). - -Inductive MExpr : zmodType -> Type := - | MX V : V -> MExpr V - | MO V : MExpr V - | MOpp V : MExpr V -> MExpr V - | MAdd V : MExpr V -> MExpr V -> MExpr V - | MSub V : MExpr V -> MExpr V -> MExpr V - | MMorph U V : {additive U -> V} -> MExpr U -> MExpr V. - -Fixpoint Meval V (e : MExpr V) : V := - match e with - | MX _ x => x - | MO _ => 0 - | MOpp _ e1 => - Meval e1 - | MAdd _ e1 e2 => Meval e1 + Meval e2 - | MSub _ e1 e2 => subr (Meval e1) (Meval e2) - | MMorph _ _ f e1 => f (Meval e1) - end. - -Fixpoint Mnorm U V (f : {additive U -> V}) (e : MExpr U) : V := - match e in MExpr U return {additive U -> V} -> V with - | MX _ x => fun f => f x - | MO _ => fun _ => 0 - | MOpp _ e1 => fun f => - Mnorm f e1 - | MAdd _ e1 e2 => fun f => Mnorm f e1 + Mnorm f e2 - | MSub _ e1 e2 => fun f => Mnorm f e1 + (- Mnorm f e2) - | MMorph _ _ g e1 => fun f => Mnorm [additive of f \o g] e1 - end f. - -Lemma M_correct_rec U V (f : {additive U -> V}) (e : MExpr U) : - f (Meval e) = Mnorm f e. -Proof. -elim: e V f => //= {U}. -- by move=> U V f; rewrite raddf0. -- by move=> U e1 IHe1 V f; rewrite raddfN IHe1. -- by move=> U e1 IHe1 e2 IHe2 V f; rewrite raddfD IHe1 IHe2. -- by move=> U e1 IHe1 e2 IHe2 V f; rewrite subrE raddfB IHe1 IHe2. -- by move=> U U' g e1 IHe1 V f; rewrite -IHe1. -Qed. - -Lemma M_correct V (e : MExpr V) : Meval e = Mnorm [additive of idfun] e. -Proof. exact: M_correct_rec [additive of idfun] _. Qed. - -Ltac morph_zmodule_reflection V VarMap ME1 ME2 ZE1 ZE2 := - rewrite [LHS](@M_correct V ME1) [RHS](@M_correct V ME2); - apply: (@AG_correct V VarMap ZE1 ZE2); - [vm_compute; reflexivity]. - -Elpi Tactic morph_zmodule. -Elpi Accumulate lp:{{ - -pred list-constant o:term, o:list term, o:term. -list-constant T [] {{ @nil lp:T }} :- !. -list-constant T [X|XS] {{ @cons lp:T lp:X lp:XS' }} :- list-constant T XS XS'. - -% [quote V F In OutM Out VarMap] -pred quote i:term, i:(term -> term), i:term, o:term, o:term, o:list term. -quote V _ {{ @GRing.zero lp:V' }} {{ MO lp:V }} {{ AGO }} _ :- - coq.unify-eq V V' ok, !. -quote V F {{ @GRing.opp lp:V' lp:In1 }} - {{ @MOpp lp:V lp:OutM1 }} {{ AGOpp lp:Out1 }} VarMap :- - coq.unify-eq V V' ok, !, quote V F In1 OutM1 Out1 VarMap. -quote V F {{ @GRing.add lp:V' lp:In1 lp:In2 }} - {{ @MAdd lp:V lp:OutM1 lp:OutM2 }} {{ AGAdd lp:Out1 lp:Out2 }} VarMap :- - coq.unify-eq V V' ok, !, - quote V F In1 OutM1 Out1 VarMap, quote V F In2 OutM2 Out2 VarMap. -quote V F {{ @subr lp:V' lp:In1 lp:In2 }} - {{ @MSub lp:V lp:OutM1 lp:OutM2 }} {{ AGAdd lp:Out1 (AGOpp lp:Out2) }} - VarMap :- - coq.unify-eq V V' ok, !, - quote V F In1 OutM1 Out1 VarMap, quote V F In2 OutM2 Out2 VarMap. -quote V F In {{ @MMorph lp:U lp:V lp:G lp:OutM }} Out VarMap :- - coq.unify-eq {{ @GRing.Additive.apply lp:U lp:V lp:Ph lp:G lp:In1 }} In ok, !, - quote U (x\ F {{ @GRing.Additive.apply lp:U lp:V lp:Ph lp:G lp:x }}) - In1 OutM Out VarMap. -quote V F In {{ @MX lp:V lp:In }} {{ AGX lp:N }} VarMap :- !, - mem VarMap (F In) N. - -pred mem o:list term, o:term, o:term. -mem [X|_] X {{ O }} :- !. -mem [_|XS] X {{ S lp:N }} :- !, mem XS X N. - -pred close o:list term. -close [] :- !. -close [_|XS] :- close XS. - -pred zmod-reflection i:term, i:term, i:term, i:term, i:term, i:term, - i:goal, o:list sealed-goal. -zmod-reflection V VarMap ZM1 ZM2 ZE1 ZE2 G GS :- - coq.ltac.call "morph_zmodule_reflection" - [trm V, trm VarMap, trm ZM1, trm ZM2, trm ZE1, trm ZE2] G GS. -zmod-reflection _ _ _ _ _ _ _ _ :- - coq.ltac.fail 0 "Not a valid Z-module equation". - -pred solve i:goal, o:list sealed-goal. -solve (goal _ _ {{ @eq lp:Ty lp:T1 lp:T2 }} _ _ as G) GS :- - @ltacfail! 0 => std.assert-ok! - (coq.unify-eq {{ GRing.Zmodule.sort lp:V }} Ty) - "Cannot find a declared zmodType", !, - quote V (x\ x) T1 ZM1 ZE1 VarMap, !, - quote V (x\ x) T2 ZM2 ZE2 VarMap, !, - close VarMap, !, - list-constant Ty VarMap VarMap', !, - zmod-reflection V VarMap' ZM1 ZM2 ZE1 ZE2 G GS. -solve G _ :- coq.ltac.fail 0 "The goal is not a Z-module equation" G. - -}}. -Elpi Typecheck. - -Goal forall (x y : int), (x + y)%:~R + x%:~R = (y + x + x)%:~R :> rat. -Proof. -move=> x y. -elpi morph_zmodule. -Qed. - -Goal forall (x y : int), (- subr x y)%:~R = y%:~R - x%:~R :> rat. -Proof. -move=> x y. -elpi morph_zmodule. -Qed. - -(******************************************************************************) -(* Section 5.2 *) -(******************************************************************************) - -Section ZifyRing. - -Variable R : ringType. - -Structure zifyRing := - ZifyRing { rval : R; zval : int; zifyRingE : rval = zval%:~R }. - -Canonical zify_zero := @ZifyRing 0 0 (erefl : 0 = 0%:~R). -Canonical zify_one := @ZifyRing 1 1 (erefl : 1 = 1%:~R). - -Lemma zify_opp_subproof e1 : - rval e1 = (- zval e1)%:~R. -Proof. by rewrite zifyRingE mulrNz. Qed. - -Canonical zify_opp e1 := - @ZifyRing (- rval e1) (- zval e1) (zify_opp_subproof e1). - -Lemma zify_add_subproof e1 e2 : rval e1 + rval e2 = (zval e1 + zval e2)%:~R. -Proof. by rewrite 2!zifyRingE intrD. Qed. - -Canonical zify_add e1 e2 := - @ZifyRing (rval e1 + rval e2) (zval e1 + zval e2) (zify_add_subproof e1 e2). - -Lemma zify_mulrz_subproof e1 n : rval e1 *~ n = (zval e1 *~ n)%:~R. -Proof. by rewrite zifyRingE -mulrzA -mulrzz. Qed. - -Canonical zify_mulrn e1 n := - @ZifyRing (rval e1 *+ n) (zval e1 *+ n) (zify_mulrz_subproof e1 n). - -Canonical zify_mulrz e1 n := - @ZifyRing (rval e1 *~ n) (zval e1 *~ n) (zify_mulrz_subproof e1 n). - -Lemma zify_mul_subproof e1 e2 : rval e1 * rval e2 = (zval e1 * zval e2)%:~R. -Proof. by rewrite 2!zifyRingE intrM. Qed. - -Canonical zify_mul e1 e2 := - @ZifyRing (rval e1 * rval e2) (zval e1 * zval e2) (zify_mul_subproof e1 e2). - -Goal False. -Proof. -move: (0%N) => n. -evar (e : zifyRing). -unify (rval ?e) (1 + n%:~R *+ 2 : R). -Abort. - -End ZifyRing. - -Lemma zify_eqb (R : numDomainType) (e1 e2 : zifyRing R) : - (rval e1 == rval e2) = (zval e1 == zval e2). -Proof. by rewrite 2!zifyRingE eqr_int. Qed. - -Goal forall n : int, n%:~R *+ 2 + 1 != 0 :> rat. -Proof. move=> n; rewrite zify_eqb /=; lia. Qed. diff --git a/meta.yml b/meta.yml index 7576146..82c74c1 100644 --- a/meta.yml +++ b/meta.yml @@ -44,32 +44,36 @@ supported_coq_versions: tested_coq_nix_versions: tested_coq_opam_versions: -- version: '1.15.0-coq-8.16' +- version: '2.0.0-coq-8.16' repo: 'mathcomp/mathcomp' -- version: '1.16.0-coq-8.16' +- version: '2.0.0-coq-8.17' repo: 'mathcomp/mathcomp' -- version: '1.16.0-coq-8.17' - repo: 'mathcomp/mathcomp' -- version: '1.17.0-coq-8.16' - repo: 'mathcomp/mathcomp' -- version: '1.17.0-coq-8.17' +- version: '2.0.0-coq-8.18' repo: 'mathcomp/mathcomp' +- version: 'coq-8.16' + repo: 'mathcomp/mathcomp-dev' +- version: 'coq-8.17' + repo: 'mathcomp/mathcomp-dev' +- version: 'coq-8.18' + repo: 'mathcomp/mathcomp-dev' +- version: 'coq-dev' + repo: 'mathcomp/mathcomp-dev' dependencies: - opam: name: coq-mathcomp-ssreflect - version: '{>= "1.15"}' + version: '{>= "2.0"}' description: |- - [MathComp](https://math-comp.github.io) ssreflect 1.15 or later + [MathComp](https://math-comp.github.io) ssreflect 2.0 or later - opam: name: coq-mathcomp-algebra description: |- [MathComp](https://math-comp.github.io) algebra - opam: name: coq-mathcomp-zify - version: '{>= "1.1.0"}' + version: '{>= "1.4.0"}' description: |- - [Mczify](https://github.com/math-comp/mczify) 1.1.0 or later + [Mczify](https://github.com/math-comp/mczify) 1.4.0 or later - opam: name: coq-elpi version: '{>= "1.15.0" & != "1.17.0"}' diff --git a/theories/common.elpi b/theories/common.elpi index 5b4b4d0..b0a1a11 100644 --- a/theories/common.elpi +++ b/theories/common.elpi @@ -9,10 +9,6 @@ pred mem o:list term, o:term, o:int. mem [X|_] X 0 :- !. mem [_|XS] X M :- !, mem XS X N, M is N + 1. -pred close o:list term. -close [] :- !. -close [_|XS] :- close XS. - % [eucldiv N D M R] N = D * M + R pred eucldiv o:int, i:int, o:int, i:int. eucldiv N D M R :- var N, var M, !, declare_constraint (eucldiv N D M R) [N, M]. @@ -76,9 +72,6 @@ pred ground-uint i:term. ground-uint {{ Number.UIntDecimal lp:D }} :- !, ground-decimal D. ground-uint {{ Number.UIntHexadecimal lp:D }} :- !, ground-hexadecimal D. -pred reduction-pos i:term, o:term. -reduction-pos I O :- coq.reduction.vm.norm I {{ positive }} O, ground-pos O. - pred reduction-N i:term, o:term. reduction-N I O :- coq.reduction.vm.norm I {{ N }} O, ground-N O. @@ -88,3 +81,598 @@ reduction-Z I O :- coq.reduction.vm.norm I {{ Z }} O, ground-Z O. pred negb i:bool, o:bool. negb tt ff :- !. negb ff tt :- !. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +pred register-instance i:scope, i:id, i:gref, i:gref, i:constant -> prop. +register-instance Scope DbName Proj Pat Pred :- std.do! [ + coq.CS.db-for Proj (cs-gref Pat) [cs-instance _ _ (const Inst)], + coq.elpi.accumulate Scope DbName (clause _ _ (Pred Inst :- !)) ]. + +pred canonical-init i:scope, i:id. +canonical-init Scope DbName :- std.do! [ + register-instance Scope DbName + {{:gref GRing.Nmodule.sort }} {{:gref nat }} canonical-nat-nmodule, + register-instance Scope DbName + {{:gref GRing.SemiRing.sort }} {{:gref nat }} canonical-nat-semiring, + register-instance Scope DbName + {{:gref GRing.ComSemiRing.sort }} {{:gref nat }} canonical-nat-comsemiring, + register-instance Scope DbName + {{:gref GRing.Nmodule.sort }} {{:gref N }} canonical-N-nmodule, + register-instance Scope DbName + {{:gref GRing.SemiRing.sort }} {{:gref N }} canonical-N-semiring, + register-instance Scope DbName + {{:gref GRing.ComSemiRing.sort }} {{:gref N }} canonical-N-comsemiring, + register-instance Scope DbName + {{:gref GRing.Nmodule.sort }} {{:gref int }} canonical-int-nmodule, + register-instance Scope DbName + {{:gref GRing.Zmodule.sort }} {{:gref int }} canonical-int-zmodule, + register-instance Scope DbName + {{:gref GRing.SemiRing.sort }} {{:gref int }} canonical-int-semiring, + register-instance Scope DbName + {{:gref GRing.Ring.sort }} {{:gref int }} canonical-int-ring, + register-instance Scope DbName + {{:gref GRing.ComRing.sort }} {{:gref int }} canonical-int-comring, + register-instance Scope DbName + {{:gref GRing.UnitRing.sort }} {{:gref int }} canonical-int-unitring, + register-instance Scope DbName + {{:gref GRing.Nmodule.sort }} {{:gref Z }} canonical-Z-nmodule, + register-instance Scope DbName + {{:gref GRing.Zmodule.sort }} {{:gref Z }} canonical-Z-zmodule, + register-instance Scope DbName + {{:gref GRing.SemiRing.sort }} {{:gref Z }} canonical-Z-semiring, + register-instance Scope DbName + {{:gref GRing.Ring.sort }} {{:gref Z }} canonical-Z-ring, + register-instance Scope DbName + {{:gref GRing.ComRing.sort }} {{:gref Z }} canonical-Z-comring, + register-instance Scope DbName + {{:gref GRing.UnitRing.sort }} {{:gref Z }} canonical-Z-unitring ]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Expression refifier + +% We use the following four predicates as global variables to store some +% information about the target (semi)ring, so that we do not have to pass them +% around in reification. + +% [target-nmodule U] and [target-semiring SR] respectively assert that the +% target carrier type has the N-module and semiring instance [U] and [SR]. +% These predicates should always succeed in reification. +pred target-nmodule o:term. +pred target-semiring o:term. + +% [target-zmodule U] asserts that the target carrier type has the Z-module +% instance [U]. This predicate fails when the target is not a ring but semiring. +pred target-zmodule o:term. + +% [field-mode] succeeds if the target is a field equation (field tactic) +% or real field linear problem (lra). +pred field-mode. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% Types to collect structure instances on the current carrier type and the +% homomorphism from the carrier type to the target type + +kind additive type. +type additive + term -> % nmodType + option term -> % zmodType + (term -> term) -> % additive morphism + additive. + +kind rmorphism type. +type rmorphism + term -> % nmodType + option term -> % zmodType + term -> % semiRingType + option term -> % ringType + option term -> % unitRingType + option term -> % fieldType + (term -> term) -> % ring morphism + rmorphism. +type rmorphism-nat rmorphism. % _%:R +type rmorphism-N rmorphism. % (N.to_nat _)%:R +type rmorphism-int rmorphism. % _%:~R +type rmorphism-Z rmorphism. % (int_of_Z _)%:~R + +% destructors + +pred rmorphism->nmod i:rmorphism, o:term. +rmorphism->nmod (rmorphism U _ _ _ _ _ _) U :- !. +rmorphism->nmod rmorphism-nat (global (const U)) :- !, canonical-nat-nmodule U. +rmorphism->nmod rmorphism-N (global (const U)) :- !, canonical-N-nmodule U. +rmorphism->nmod rmorphism-int (global (const U)) :- !, canonical-int-nmodule U. +rmorphism->nmod rmorphism-Z (global (const U)) :- !, canonical-Z-nmodule U. + +pred rmorphism->zmod i:rmorphism, o:term. +rmorphism->zmod (rmorphism _ (some U) _ _ _ _ _) U :- !. +rmorphism->zmod rmorphism-int (global (const U)) :- !, canonical-int-zmodule U. +rmorphism->zmod rmorphism-Z (global (const U)) :- !, canonical-Z-zmodule U. + +pred rmorphism->sring i:rmorphism, o:term. +rmorphism->sring (rmorphism _ _ R _ _ _ _) R :- !. +rmorphism->sring rmorphism-nat (global (const R)) :- !, + canonical-nat-semiring R. +rmorphism->sring rmorphism-N (global (const R)) :- !, canonical-N-semiring R. +rmorphism->sring rmorphism-int (global (const R)) :- !, + canonical-int-semiring R. +rmorphism->sring rmorphism-Z (global (const R)) :- !, canonical-Z-semiring R. + +pred rmorphism->ring i:rmorphism, o:term. +rmorphism->ring (rmorphism _ _ _ (some R) _ _ _) R :- !. +rmorphism->ring rmorphism-int (global (const R)) :- !, canonical-int-ring R. +rmorphism->ring rmorphism-Z (global (const R)) :- !, canonical-Z-ring R. + +pred rmorphism->uring i:rmorphism, o:term. +rmorphism->uring (rmorphism _ _ _ _ (some UR) _ _) UR :- !. +rmorphism->uring rmorphism-int (global (const R)) :- !, + canonical-int-unitring R. +rmorphism->uring rmorphism-Z (global (const R)) :- !, canonical-Z-unitring R. + +pred rmorphism->field i:rmorphism, o:term. +rmorphism->field (rmorphism _ _ _ _ _ (some F) _) F :- !. + +pred rmorphism->morph i:rmorphism, o:term -> term. +rmorphism->morph (rmorphism _ _ _ _ _ _ Morph) Morph :- !. +rmorphism->morph rmorphism-nat Morph :- !, + target-nmodule TU, !, target-semiring TR, !, + Morph = n\ {{ @GRing.natmul lp:TU (@GRing.one lp:TR) lp:n }}. +rmorphism->morph rmorphism-N Morph :- !, + target-nmodule TU, !, target-semiring TR, !, + Morph = n\ {{ @GRing.natmul lp:TU (@GRing.one lp:TR) (N.to_nat lp:n) }}. +rmorphism->morph rmorphism-int Morph :- !, + target-zmodule TU, !, target-semiring TR, !, + Morph = n\ {{ @intmul lp:TU (@GRing.one lp:TR) lp:n }}. +rmorphism->morph rmorphism-Z Morph :- !, + target-zmodule TU, !, target-semiring TR, !, + Morph = n\ {{ @intmul lp:TU (@GRing.one lp:TR) (int_of_Z lp:n) }}. + +pred rmorphism-rm-field i:rmorphism, o:rmorphism. +rmorphism-rm-field (rmorphism U V SR R UR _ M) (rmorphism U V SR R UR none M). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +namespace quote { + +% Constructors for reified terms (should be instantiated by each tactic) +pred build.variable i:term, o:term. +pred build.zero o:term. +pred build.opp i:term, o:term. +pred build.add i:term, i:term, o:term. +pred build.sub i:term, i:term, o:term. +pred build.one o:term. +pred build.mul i:term, i:term, o:term. +pred build.exp i:term, i:term, o:term. +pred build.inv i:term, o:term. +pred build.Z-constant i:term, o:term. +pred build.N-constant i:term, o:term. + +% [count-succ In N Out] returns the largest [N] such that [In] is +% [S (S (... Out))] with [N] occurences of [S] +pred count-succ i:term, o:int, o:term. +count-succ {{ lib:num.nat.S lp:In }} N' Out :- !, + count-succ In N Out, N' is N + 1. +count-succ In 0 In :- !. + +% [quote.n-const In OutM Out] reifies natural number constant [In] of type [nat] +% to a term [OutM] of type [large_nat] and a term [Out] of type [N]. +pred n-const i:term, o:term, o:term. +n-const {{ lp:In : _ }} OutM Out :- !, n-const In OutM Out. +n-const {{ Nat.of_num_uint lp:In }} {{ large_nat_uint lp:In }} Out :- + ground-uint In, !, + coq.reduction.vm.norm {{ N.of_num_uint lp:In }} {{ N }} Out. +n-const In {{ large_nat_N lp:Out }} Out :- + reduction-N {{ N.of_nat lp:In }} Out. + +% [quote.z-const In Sign OutM Out] reifies integer constant [In] of type +% [int] to a boolean [Sign], a term [OutM] of type [large_nat] +% and a term [Out] of type [N] +% [Sign] is [tt] iff [In] is non negative, +% in which case [In] is [Out], otherwise [In] is [- Out.+1] +pred z-const i:term, o:bool, o:term, o:term. +z-const {{ lp:In : _ }} Sign OutM Out :- !, z-const In Sign OutM Out. +z-const {{ Posz (Nat.of_num_uint lp:In) }} tt {{ large_nat_uint lp:In }} Out :- + ground-uint In, !, + coq.reduction.vm.norm {{ N.of_num_uint lp:In }} {{ N }} Out. +z-const {{ Negz (Nat.of_num_uint lp:In) }} ff {{ large_nat_uint lp:In }} Out :- + ground-uint In, !, + coq.reduction.vm.norm {{ N.of_num_uint lp:In }} {{ N }} Out. +z-const In Sign {{ large_nat_N lp:Out }} Out :- !, + coq.reduction.vm.norm {{ quote_icstr_helper lp:In }} {{ (bool * N)%type }} + {{ (lp:Sign', lp:Out) }}, !, + (Sign' = {{ true }}, !, Sign = tt; + Sign' = {{ false }}, !, Sign = ff), !, + ground-N Out. + +% [quote.nmod C Input OutM Out VM] reifies an expression [Input] +% under the additive morphism [C] +% - [C] stores instances on the carrier type and the additive function from it, +% - [Input] is a term of the carrier type, +% - [OutM] is a reified terms of [Input] of type [MExpr C], +% it is such that [Meval OutM] is exactly [Input], +% - [Out] is a reified term of [Input] built by build.*, +% it has morphisms pushed inward such that the eval of [Out] +% is [{SemiRing,Ring,Field,Lra}.Mnorm OutM] +% - [VM] is a variable map. +pred nmod i:additive, i:term, o:term, o:term, o:list term. +% _ : _ +nmod C {{ lp:In : _ }} OutM Out VM :- !, + nmod C In OutM Out VM. +% 0%R +nmod (additive U _ _) {{ @GRing.zero lp:U' }} {{ @M0 lp:U }} Out _ :- + coq.unify-eq U U' ok, !, + build.zero Out. +% +%R +nmod (additive U _ _ as C) {{ @GRing.add lp:U' lp:In1 lp:In2 }} + {{ @MAdd lp:U lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq U U' ok, !, + nmod C In1 OutM1 Out1 VM, !, + nmod C In2 OutM2 Out2 VM, !, + build.add Out1 Out2 Out. +% (_ *+ _)%R +nmod (additive U _ _ as C) {{ @GRing.natmul lp:U' lp:In1 lp:In2 }} + {{ @MMuln lp:U lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq U U' ok, !, + nmod C In1 OutM1 Out1 VM, !, + ring rmorphism-nat In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% -%R +nmod (additive _ (some U) _ as C) {{ @GRing.opp lp:U' lp:In1 }} + {{ @MOpp lp:U lp:OutM1 }} Out VM :- + coq.unify-eq U U' ok, !, + nmod C In1 OutM1 Out1 VM, !, + build.opp Out1 Out. +% (_ *~ _)%R +nmod (additive _ (some U) _ as C) {{ @intmul lp:U' lp:In1 lp:In2 }} + {{ @MMulz lp:U lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq U U' ok, !, + nmod C In1 OutM1 Out1 VM, !, + ring rmorphism-int In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% additive functions +nmod (additive U _ _ as C) In OutM Out VM :- + % TODO: for concrete additive functions, should we unpack [NewMorphInst]? + NewMorph = (x\ {{ @GRing.Additive.sort lp:V lp:U lp:NewMorphInst lp:x }}), + coq.unify-eq In (NewMorph In1) ok, !, + nmod.additive V C NewMorph NewMorphInst In1 OutM Out VM. +% variables +nmod (additive U _ Morph) In {{ @MX lp:U lp:In }} Out VM :- + mem VM (Morph In) N, !, + build.variable { positive-constant {calc (N + 1)} } Out. +nmod _ In _ _ _ :- coq.error "Unknown" { coq.term->string In }. + +pred nmod.additive i:term, i:additive, i:term -> term, i:term, i:term, + o:term, o:term, o:list term. +nmod.additive V (additive U _ Morph) NewMorph NewMorphInst In1 + {{ @MnatAdditive lp:U lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-nat-nmodule })) ok, + mem VM (Morph (NewMorph {{ 1%N }})) N, !, + ring rmorphism-nat In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +nmod.additive V (additive U _ Morph) NewMorph NewMorphInst In1 + {{ @MNAdditive lp:U lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-N-nmodule })) ok, + mem VM (Morph (NewMorph {{ 1%num }})) N, !, + ring rmorphism-N In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +nmod.additive V (additive U _ Morph) NewMorph NewMorphInst In1 + {{ @MintAdditive lp:U lp:NewMorphInst lp:OutM1 }} Out VM :- + target-zmodule _, + coq.unify-eq V (global (const { canonical-int-nmodule })) ok, + mem VM (Morph (NewMorph {{ 1%Z }})) N, !, + ring rmorphism-int In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +nmod.additive V (additive U _ Morph) NewMorph NewMorphInst In1 + {{ @MZAdditive lp:U lp:NewMorphInst lp:OutM1 }} Out VM :- + target-zmodule _, + coq.unify-eq V (global (const { canonical-Z-nmodule })) ok, + mem VM (Morph (NewMorph {{ Zpos 1 }})) N, !, + ring rmorphism-Z In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +nmod.additive V (additive U _ Morph) NewMorph NewMorphInst In1 + {{ @MAdditive lp:V lp:U lp:NewMorphInst lp:OutM1 }} Out1 VM :- !, + if (coq.unify-eq {{ GRing.Nmodule.sort lp:V }} + {{ GRing.Zmodule.sort lp:V' }} ok) + (V'' = some V') (V'' = none), !, + nmod (additive V V'' (x\ Morph (NewMorph x))) In1 OutM1 Out1 VM, !. + +% [quote.ring C Input OutM Out VM] reifies an expression [Input] +% under the ring morphism [C] +% - [C] stores instances on the carrier type and the (semi)ring homomorphism +% from it, +% - [Input] is a term of the carrier type, +% - [OutM] is a reified terms of [Input] of type [RExpr C], +% it is such that [Reval OutM] is exactly [Input], +% - [Out] is a reified term of [Input] built by build.*, +% it has morphisms pushed inward such that the eval of [Out] +% is [{SemiRing,Ring,Field,Lra}.Rnorm OutM] +% - [VM] is a variable map. +pred ring i:rmorphism, i:term, o:term, o:term, o:list term. +% _ : _ +ring C {{ lp:In : _ }} OutM Out VM :- !, + ring C In OutM Out VM. +% 0%R +ring C {{ @GRing.zero lp:U }} {{ @R0 lp:R }} Out _ :- + coq.unify-eq { rmorphism->nmod C } U ok, + rmorphism->sring C R, !, + build.zero Out. +% +%R +ring C {{ @GRing.add lp:U lp:In1 lp:In2 }} + {{ @RAdd lp:R lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq { rmorphism->nmod C } U ok, + rmorphism->sring C R, !, + ring C In1 OutM1 Out1 VM, !, + ring C In2 OutM2 Out2 VM, !, + build.add Out1 Out2 Out. +% addn +ring rmorphism-nat {{ addn lp:In1 lp:In2 }} + {{ @RnatAdd lp:OutM1 lp:OutM2 }} Out VM :- !, + ring rmorphism-nat In1 OutM1 Out1 VM, !, + ring rmorphism-nat In2 OutM2 Out2 VM, !, + build.add Out1 Out2 Out. +% N.add +ring rmorphism-N {{ N.add lp:In1 lp:In2 }} + {{ @RNAdd lp:OutM1 lp:OutM2 }} Out VM :- !, + ring rmorphism-N In1 OutM1 Out1 VM, !, + ring rmorphism-N In2 OutM2 Out2 VM, !, + build.add Out1 Out2 Out. +% Z.add +ring rmorphism-Z {{ Z.add lp:In1 lp:In2 }} + {{ @RZAdd lp:OutM1 lp:OutM2 }} Out VM :- !, + ring rmorphism-Z In1 OutM1 Out1 VM, !, + ring rmorphism-Z In2 OutM2 Out2 VM, !, + build.add Out1 Out2 Out. +% (_ *+ _)%R +ring C {{ @GRing.natmul lp:U lp:In1 lp:In2 }} + {{ @RMuln lp:R lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq { rmorphism->nmod C } U ok, + rmorphism->sring C R, !, + ring C In1 OutM1 Out1 VM, !, + ring rmorphism-nat In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% -%R +ring C {{ @GRing.opp lp:U lp:In1 }} {{ @ROpp lp:R lp:OutM1 }} Out VM :- + coq.unify-eq { rmorphism->zmod C } U ok, + rmorphism->ring C R, !, + ring C In1 OutM1 Out1 VM, !, + build.opp Out1 Out. +% Z.opp +ring rmorphism-Z {{ Z.opp lp:In1 }} {{ @RZOpp lp:OutM1 }} Out VM :- !, + ring rmorphism-Z In1 OutM1 Out1 VM, !, + build.opp Out1 Out. +% Z.sub +ring rmorphism-Z {{ Z.sub lp:In1 lp:In2 }} + {{ @RZSub lp:OutM1 lp:OutM2 }} Out VM :- !, + ring rmorphism-Z In1 OutM1 Out1 VM, !, + ring rmorphism-Z In2 OutM2 Out2 VM, !, + build.sub Out1 Out2 Out. +% (_ *~ _)%R +ring C {{ @intmul lp:U lp:In1 lp:In2 }} + {{ @RMulz lp:R lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq { rmorphism->zmod C } U ok, + rmorphism->ring C R, !, + ring C In1 OutM1 Out1 VM, !, + ring rmorphism-int In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% 1%R +ring C {{ @GRing.one lp:R' }} {{ @R1 lp:R }} Out _ :- + rmorphism->sring C R, + coq.unify-eq R R' ok, !, + build.one Out. +% *%R +ring C {{ @GRing.mul lp:R' lp:In1 lp:In2 }} + {{ @RMul lp:R lp:OutM1 lp:OutM2 }} Out VM :- + rmorphism->sring C R, + coq.unify-eq R R' ok, !, + ring C In1 OutM1 Out1 VM, !, + ring C In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% muln +ring rmorphism-nat {{ muln lp:In1 lp:In2 }} + {{ @RnatMul lp:OutM1 lp:OutM2 }} Out VM :- !, + ring rmorphism-nat In1 OutM1 Out1 VM, !, + ring rmorphism-nat In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% N.mul +ring rmorphism-N {{ N.mul lp:In1 lp:In2 }} + {{ @RNMul lp:OutM1 lp:OutM2 }} Out VM :- !, + ring rmorphism-N In1 OutM1 Out1 VM, !, + ring rmorphism-N In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% Z.mul +ring rmorphism-Z {{ Z.mul lp:In1 lp:In2 }} + {{ @RZMul lp:OutM1 lp:OutM2 }} Out VM :- !, + ring rmorphism-Z In1 OutM1 Out1 VM, !, + ring rmorphism-Z In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% (_ ^+ _)%R +ring C {{ @GRing.exp lp:R' lp:In1 lp:In2 }} + {{ @RExpn lp:R lp:OutM1 lp:OutM2 }} Out VM :- + rmorphism->sring C R, + coq.unify-eq R R' ok, + n-const In2 OutM2 Out2, !, + ring C In1 OutM1 Out1 VM, !, + build.exp Out1 Out2 Out. +% (_ ^ _)%R +ring C {{ @exprz lp:R' lp:In1 lp:In2 }} OutM Out VM :- + z-const In2 Pos OutM2 Out2, + rmorphism->uring C R, + coq.unify-eq R R' ok, + if (Pos = tt) + (CONT = + (!, ring C In1 OutM1 Out1 VM, !, + OutM = {{ @RExpPosz lp:R lp:OutM1 lp:OutM2 }}, !, + build.exp Out1 Out2 Out)) + (CONT = + (rmorphism->field C F, !, + ring C In1 OutM1 Out1 VM, !, + OutM = {{ @RExpNegz lp:F lp:OutM1 lp:OutM2 }}, !, + build.inv { build.exp Out1 Out2 } Out)), + CONT. +% expn +ring rmorphism-nat {{ expn lp:In1 lp:In2 }} + {{ @RnatExpn lp:OutM1 lp:OutM2 }} Out VM :- + n-const In2 OutM2 Out2, !, + ring rmorphism-nat In1 OutM1 Out1 VM, !, + build.exp Out1 Out2 Out. +% N.pow +ring rmorphism-N {{ N.pow lp:In1 lp:In2 }} + {{ @RNExp lp:OutM1 lp:Out2 }} Out VM :- + reduction-N In2 Out2, !, + ring rmorphism-N In1 OutM1 Out1 VM, !, + build.exp Out1 Out2 Out. +% Z.pow +ring rmorphism-Z {{ Z.pow lp:In1 lp:In2 }} + {{ @RZExp lp:OutM1 lp:OutM2 }} Out VM :- + reduction-Z In2 OutM2, !, + ((OutM2 = {{ Z0 }}, !, Out2 = {{ N0 }}; % If [In2] is non-negative + OutM2 = {{ Zpos lp:P }}, !, Out2 = {{ Npos lp:P }}), !, + ring rmorphism-Z In1 OutM1 Out1 VM, !, + build.exp Out1 Out2 Out; + build.zero Out). % If [In2] is negative +% _^-1 +ring C {{ @GRing.inv lp:R lp:In1 }} {{ @RInv lp:F lp:OutM1 }} Out VM :- + rmorphism->field C F, + coq.unify-eq { rmorphism->uring C } R ok, !, + ring C In1 OutM1 Out1 VM, + build.inv Out1 Out. +% S (..(S ..)..) and nat constants +ring rmorphism-nat {{ lib:num.nat.S lp:In }} OutM Out VM :- !, + count-succ In N In2, !, + positive-constant {calc (N + 1)} Pos, !, + Out1 = {{ N.pos lp:Pos }}, !, + if (In2 = {{ lib:num.nat.O }}) + (OutM = {{ RnatC (large_nat_N lp:Out1) }}, !, + build.N-constant Out1 Out) + (ring rmorphism-nat In2 OutM2 Out2 VM, !, + OutM = {{ RnatS lp:Pos lp:OutM2 }}, !, + build.add { build.N-constant Out1 } Out2 Out). +ring rmorphism-nat {{ lib:num.nat.O }} {{ RnatC (large_nat_N N0) }} Out _ :- + !, build.N-constant {{ N0 }} Out. +ring rmorphism-nat {{ Nat.of_num_uint lp:In }} + {{ RnatC (large_nat_uint lp:In) }} Out _ :- !, + ground-uint In, !, + coq.reduction.vm.norm {{ N.of_num_uint lp:In }} {{ N }} InN, !, + build.N-constant InN Out. +% Posz +ring rmorphism-int {{ Posz lp:In }} {{ @RPosz lp:OutM }} Out VM :- !, + ring rmorphism-nat In OutM Out VM. +% Negz +ring rmorphism-int {{ Negz lp:In }} {{ RNegz lp:OutM1 }} Out VM :- !, + ring rmorphism-nat In OutM1 Out1 VM, !, + build.opp { build.add { build.one } Out1 } Out. +% N constants +ring rmorphism-N In {{ @RNC lp:In }} Out _ :- + ground-N In, !, build.N-constant In Out. +% Z constants +ring rmorphism-Z In {{ @RZC lp:In }} Out _ :- + ground-Z In, !, build.Z-constant In Out. +% morphisms +ring C In OutM Out VM :- + rmorphism->sring C R, + % TODO: for concrete additive functions, should we unpack [NewMorphInst]? + NewMorph = (x\ {{ @GRing.RMorphism.sort lp:S lp:R lp:NewMorphInst lp:x }}), + coq.unify-eq In (NewMorph In1) ok, !, + ring.rmorphism S C NewMorph NewMorphInst In1 OutM Out VM. +% additive functions +ring C In OutM Out VM :- + rmorphism->nmod C U, + % TODO: for concrete additive functions, should we unpack [NewMorphInst]? + NewMorph = (x\ {{ @GRing.Additive.sort lp:V lp:U lp:NewMorphInst lp:x }}), + coq.unify-eq In (NewMorph In1) ok, !, + ring.additive V C NewMorph NewMorphInst In1 OutM Out VM. +% variables +ring C In {{ @RX lp:R lp:In }} Out VM :- !, + rmorphism->sring C R, rmorphism->morph C Morph, + mem VM (Morph In) N, !, + build.variable { positive-constant {calc (N + 1)} } Out. +ring _ In _ _ _ :- coq.error "Unknown" { coq.term->string In }. +% TODO: converse ring + +pred ring.rmorphism.aux i:term, i:term -> term, o:rmorphism. +ring.rmorphism.aux SR Morph (rmorphism U V' SR R' UR' F' Morph) :- !, + Sort = {{ GRing.SemiRing.sort lp:SR }}, + coq.unify-eq Sort {{ GRing.Nmodule.sort lp:U }} ok, + if (target-zmodule _, coq.unify-eq Sort {{ GRing.Ring.sort lp:R }} ok, + coq.unify-eq Sort {{ GRing.Zmodule.sort lp:V }} ok) + (V' = some V, R' = some R, + if (coq.unify-eq Sort {{ GRing.UnitRing.sort lp:UR }} ok) + (UR' = some UR, + if (field-mode, coq.unify-eq Sort {{ GRing.Field.sort lp:F }} ok) + (F' = some F) (F' = none)) + (UR' = none, F' = none)) + (V' = none, R' = none, UR' = none, F' = none). + +pred ring.rmorphism i:term, i:rmorphism, i:term -> term, i:term, i:term, + o:term, o:term, o:list term. +ring.rmorphism S C _ NewMorphInst In1 + {{ @RnatMorph lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- + coq.unify-eq S (global (const { canonical-nat-semiring })) ok, !, + rmorphism->sring C R, !, + ring rmorphism-nat In1 OutM1 Out1 VM. +ring.rmorphism S C _ NewMorphInst In1 + {{ @RNMorph lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- + coq.unify-eq S (global (const { canonical-N-semiring })) ok, !, + rmorphism->sring C R, !, + ring rmorphism-N In1 OutM1 Out1 VM. +ring.rmorphism S C _ NewMorphInst In1 + {{ @RintMorph lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- + target-zmodule _, + coq.unify-eq S (global (const { canonical-int-semiring })) ok, !, + rmorphism->sring C R, !, + ring rmorphism-int In1 OutM1 Out1 VM. +ring.rmorphism S C _ NewMorphInst In1 + {{ @RZMorph lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- + target-zmodule _, + coq.unify-eq S (global (const { canonical-Z-semiring })) ok, !, + rmorphism->sring C R, !, + ring rmorphism-Z In1 OutM1 Out1 VM. +ring.rmorphism S C NewMorph NewMorphInst In1 + {{ @RMorph lp:S lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- !, + rmorphism->sring C R, !, + rmorphism->morph C Morph, !, + ring.rmorphism.aux S (x\ Morph (NewMorph x)) C', !, + ring C' In1 OutM1 Out1 VM. + +pred ring.additive i:term, i:rmorphism, i:term -> term, i:term, i:term, + o:term, o:term, o:list term. +ring.additive V C NewMorph NewMorphInst In1 + {{ @RnatAdditive lp:R lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-nat-nmodule })) ok, + rmorphism->sring C R, rmorphism->morph C Morph, + mem VM (Morph (NewMorph {{ 1%N }})) N, !, + ring rmorphism-nat In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +ring.additive V C NewMorph NewMorphInst In1 + {{ @RNAdditive lp:R lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-N-nmodule })) ok, + rmorphism->sring C R, rmorphism->morph C Morph, + mem VM (Morph (NewMorph {{ 1%num }})) N, !, + ring rmorphism-N In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +ring.additive V C NewMorph NewMorphInst In1 + {{ @RintAdditive lp:R lp:NewMorphInst lp:OutM1 }} Out VM :- + target-zmodule _, + coq.unify-eq V (global (const { canonical-int-nmodule })) ok, + rmorphism->sring C R, rmorphism->morph C Morph, + mem VM (Morph (NewMorph {{ 1%Z }})) N, !, + ring rmorphism-int In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +ring.additive V C NewMorph NewMorphInst In1 + {{ @RZAdditive lp:R lp:NewMorphInst lp:OutM1 }} Out VM :- + target-zmodule _, + coq.unify-eq V (global (const { canonical-Z-nmodule })) ok, + rmorphism->sring C R, rmorphism->morph C Morph, + mem VM (Morph (NewMorph {{ Zpos 1 }})) N, !, + ring rmorphism-Z In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +ring.additive V C NewMorph NewMorphInst In1 + {{ @RAdditive lp:V lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- !, + rmorphism->sring C R, rmorphism->morph C Morph, + if (coq.unify-eq {{ GRing.Nmodule.sort lp:V }} + {{ GRing.Zmodule.sort lp:V' }} ok) + (V'' = some V') (V'' = none), !, + nmod (additive V V'' (x\ Morph (NewMorph x))) In1 OutM1 Out1 VM, !. + +} diff --git a/theories/common.v b/theories/common.v index e3a160c..e88a37c 100644 --- a/theories/common.v +++ b/theories/common.v @@ -1,3 +1,4 @@ +From elpi Require Import elpi. From Coq Require Import QArith. From Coq.micromega Require Import OrderedRing RingMicromega. From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint. @@ -11,7 +12,7 @@ Unset Printing Implicit Defensive. Local Open Scope ring_scope. -Implicit Types (R : ringType) (F : fieldType). +Implicit Types (V : nmodType) (R : semiRingType) (F : fieldType). (* Some basic facts about `Decimal.uint` and `Hexadecimal.uint` *) @@ -115,22 +116,19 @@ Definition nat_of_pos_expand (p : positive) : nat := nat_of_pos_rec_expand p 1. Definition nat_of_N_expand (n : N) : nat := if n is N.pos p then nat_of_pos_expand p else 0%N. -Definition int_of_Z_expand (n : Z) : int := - match n with - | Z0 => Posz 0 - | Zpos p => Posz (nat_of_pos_expand p) - | Zneg p => Negz (nat_of_pos_expand p).-1 - end. +Lemma nat_of_N_expandE : nat_of_N_expand = nat_of_N. Proof. by []. Qed. -Definition Z_of_N_expand (n : N) : Z := - match n with - | N0 => Z0 - | N.pos p => Z.pos p - end. +(* For representing input terms of the form `S (... (S n) ...)` *) -Lemma nat_of_N_expandE : nat_of_N_expand = nat_of_N. Proof. by []. Qed. -Lemma int_of_Z_expandE : int_of_Z_expand = int_of_Z. Proof. by []. Qed. -Lemma Z_of_N_expandE : Z_of_N_expand = Z.of_N. Proof. by []. Qed. +Fixpoint add_pos_nat (p : positive) (n : nat) : nat := + match p with + | p0~1 => S (add_pos_nat p0 (add_pos_nat p0 n)) + | p0~0 => add_pos_nat p0 (add_pos_nat p0 n) + | 1 => S n + end%positive. + +Lemma add_pos_natE p n : add_pos_nat p n = Pos.to_nat p + n. +Proof. elim: p n => //= p IHp n; rewrite !IHp; lia. Qed. (* Data types for reifying `nat` and `int` constants, including large ones *) (* that uses `Number.uint` *) @@ -171,32 +169,1033 @@ rewrite -large_nat_N_nat; case: n => [n|[d|d]] //=; first lia. by rewrite /Z.of_hex_uint /N.of_hex_uint; lia. Qed. -Variant large_int := - | large_int_Z of Z - | large_int_Pos of Number.uint - | large_int_Neg of Number.uint. - -Definition int_of_large_int (n : large_int) : int := +Definition quote_icstr_helper (n : int) : bool * N := match n with - | large_int_Z n => int_of_Z_expand n - | large_int_Pos n => Posz (Nat.of_num_uint n) - | large_int_Neg n => Negz (Nat.of_num_uint n) + | Posz n => (true, N.of_nat n) + | Negz n => (false, N.of_nat n) end. -Definition Z_of_large_int (n : large_int) : Z := - match n with - | large_int_Z n => n - | large_int_Pos n => Z.of_num_uint n - | large_int_Neg n => - (Z.succ (Z.of_num_uint n)) +(* TODO: remove natn below when we drop support for MathComp 2.0 *) +Lemma natn n : n%:R%R = n :> nat. +Proof. by elim: n => // n; rewrite mulrS => ->. Qed. + +(* Type for reified expressions *) + +Inductive RExpr : semiRingType -> Type := + (* 0 *) + | R0 R : RExpr R + (* addition *) + | RAdd R : RExpr R -> RExpr R -> RExpr R + | RnatAdd : RExpr nat -> RExpr nat -> RExpr nat + | RNAdd : RExpr N -> RExpr N -> RExpr N + | RZAdd : RExpr Z -> RExpr Z -> RExpr Z + (* natmul *) + | RMuln R : RExpr R -> RExpr nat -> RExpr R + (* opposite and subtraction *) + | ROpp (R : ringType) : RExpr R -> RExpr R + | RZOpp : RExpr Z -> RExpr Z + | RZSub : RExpr Z -> RExpr Z -> RExpr Z + (* intmul *) + | RMulz (R : ringType) : RExpr R -> RExpr int -> RExpr R + (* 1 *) + | R1 R : RExpr R + (* multiplication *) + | RMul R : RExpr R -> RExpr R -> RExpr R + | RnatMul : RExpr nat -> RExpr nat -> RExpr nat + | RNMul : RExpr N -> RExpr N -> RExpr N + | RZMul : RExpr Z -> RExpr Z -> RExpr Z + (* exponentiation *) + | RExpn R : RExpr R -> large_nat -> RExpr R + | RExpPosz (R : unitRingType) : RExpr R -> large_nat -> RExpr R + | RExpNegz F : RExpr F -> large_nat -> RExpr F + | RnatExpn : RExpr nat -> large_nat -> RExpr nat + | RNExp : RExpr N -> N -> RExpr N + | RZExp : RExpr Z -> Z -> RExpr Z + (* multiplicative inverse *) + | RInv F : RExpr F -> RExpr F + (* constants *) + | RnatS : positive -> RExpr nat -> RExpr nat + | RnatC : large_nat -> RExpr nat + | RPosz : RExpr nat -> RExpr int + | RNegz : RExpr nat -> RExpr int + | RNC : N -> RExpr N + | RZC : Z -> RExpr Z + (* homomorphism applications *) + | RMorph R' R : {rmorphism R' -> R} -> RExpr R' -> RExpr R + | RnatMorph R : {rmorphism nat -> R} -> RExpr nat -> RExpr R + | RNMorph R : {rmorphism N -> R} -> RExpr N -> RExpr R + | RintMorph R : {rmorphism int -> R} -> RExpr int -> RExpr R + | RZMorph R : {rmorphism Z -> R} -> RExpr Z -> RExpr R + | RAdditive V R : {additive V -> R} -> MExpr V -> RExpr R + | RnatAdditive R : {additive nat -> R} -> RExpr nat -> RExpr R + | RNAdditive R : {additive N -> R} -> RExpr N -> RExpr R + | RintAdditive R : {additive int -> R} -> RExpr int -> RExpr R + | RZAdditive R : {additive Z -> R} -> RExpr Z -> RExpr R + (* variables *) + | RX R : R -> RExpr R +with MExpr : nmodType -> Type := + | M0 V : MExpr V + | MAdd V : MExpr V -> MExpr V -> MExpr V + | MMuln V : MExpr V -> RExpr nat -> MExpr V + | MOpp (V : zmodType) : MExpr V -> MExpr V + | MMulz (V : zmodType) : MExpr V -> RExpr int -> MExpr V + | MAdditive V' V : {additive V' -> V} -> MExpr V' -> MExpr V + | MnatAdditive V : {additive nat -> V} -> RExpr nat -> MExpr V + | MNAdditive V : {additive N -> V} -> RExpr N -> MExpr V + | MintAdditive V : {additive int -> V} -> RExpr int -> MExpr V + | MZAdditive V : {additive Z -> V} -> RExpr Z -> MExpr V + | MX V : V -> MExpr V. + +Scheme RExpr_ind' := Induction for RExpr Sort Prop + with MExpr_ind' := Induction for MExpr Sort Prop. + +(* Evaluation function for above type *) +(* Evaluating result of reification should be convertible to input expr. *) + +Fixpoint Reval R (e : RExpr R) : R := + match e with + | R0 _ => 0%R + | RAdd _ e1 e2 => Reval e1 + Reval e2 + | RnatAdd e1 e2 => addn (Reval e1) (Reval e2) + | RNAdd e1 e2 => N.add (Reval e1) (Reval e2) + | RZAdd e1 e2 => Z.add (Reval e1) (Reval e2) + | RMuln _ e1 e2 => Reval e1 *+ Reval e2 + | ROpp _ e1 => - Reval e1 + | RZOpp e1 => Z.opp (Reval e1) + | RZSub e1 e2 => Z.sub (Reval e1) (Reval e2) + | RMulz _ e1 e2 => Reval e1 *~ Reval e2 + | R1 _ => 1%R + | RMul _ e1 e2 => Reval e1 * Reval e2 + | RnatMul e1 e2 => muln (Reval e1) (Reval e2) + | RNMul e1 e2 => N.mul (Reval e1) (Reval e2) + | RZMul e1 e2 => Z.mul (Reval e1) (Reval e2) + | RExpn _ e1 n => Reval e1 ^+ nat_of_large_nat n + | RExpPosz _ e1 n => Reval e1 ^ Posz (nat_of_large_nat n) + | RExpNegz _ e1 n => Reval e1 ^ Negz (nat_of_large_nat n) + | RnatExpn e1 n => expn (Reval e1) (nat_of_large_nat n) + | RNExp e1 n => N.pow (Reval e1) n + | RZExp e1 n => Z.pow (Reval e1) n + | RInv _ e1 => (Reval e1)^-1 + | RnatS p e => add_pos_nat p (Reval e) + | RnatC n => nat_of_large_nat n + | RPosz e1 => Posz (Reval e1) + | RNegz e2 => Negz (Reval e2) + | RMorph _ _ f e1 + | RnatMorph _ f e1 | RNMorph _ f e1 + | RintMorph _ f e1 | RZMorph _ f e1 + | RnatAdditive _ f e1 | RNAdditive _ f e1 + | RintAdditive _ f e1 | RZAdditive _ f e1 => f (Reval e1) + | RAdditive _ _ f e1 => f (Meval e1) + | RNC n | RZC n => n + | RX _ x => x + end +with Meval V (e : MExpr V) : V := + match e with + | M0 _ => 0%R + | MAdd _ e1 e2 => Meval e1 + Meval e2 + | MMuln _ e1 e2 => Meval e1 *+ Reval e2 + | MOpp _ e1 => - Meval e1 + | MMulz _ e1 e2 => Meval e1 *~ Reval e2 + | MAdditive _ _ f e1 => f (Meval e1) + | MnatAdditive _ f e1 | MNAdditive _ f e1 + | MintAdditive _ f e1 | MZAdditive _ f e1 => f (Reval e1) + | MX _ x => x end. -Lemma large_int_Z_int (n : large_int) : - int_of_Z (Z_of_large_int n) = int_of_large_int n. +(* Pushing down morphisms in ring and field expressions by reflection *) +(* First for semirings, then for rings and finally for fields *) + +Module SemiRing. + +Section norm. + +Variables (R' : semiRingType) (R_of_N : N -> R'). +Variables (zero : R') (add : R' -> R' -> R'). +Variables (one : R') (mul : R' -> R' -> R') (exp : R' -> N -> R'). + +Fixpoint Rnorm R (f : R -> R') (e : RExpr R) : R' := + match e in RExpr R return (R -> R') -> R' with + | R0 _ => fun => zero + | RAdd _ e1 e2 | RnatAdd e1 e2 | RNAdd e1 e2 => + fun f => add (Rnorm f e1) (Rnorm f e2) + | RMuln _ e1 e2 => fun f => mul (Rnorm f e1) (Rnorm (GRing.natmul 1) e2) + | R1 _ => fun => one + | RMul _ e1 e2 | RnatMul e1 e2 | RNMul e1 e2 => + fun f => mul (Rnorm f e1) (Rnorm f e2) + | RExpn _ e1 n | RnatExpn e1 n => + fun f => exp (Rnorm f e1) (N_of_large_nat n) + | RExpPosz _ e1 n => fun f => exp (Rnorm f e1) (N_of_large_nat n) + | RNExp e1 n => fun f => exp (Rnorm f e1) n + | RnatS p e => fun f => add (R_of_N (Npos p)) (Rnorm f e) + | RnatC n => fun => R_of_N (N_of_large_nat n) + | RNC n => fun => R_of_N n + | RMorph _ _ g e1 => fun f => Rnorm (fun x => f (g x)) e1 + | RnatMorph _ _ e1 => fun => Rnorm (GRing.natmul 1) e1 + | RNMorph _ _ e1 => fun => Rnorm (fun n => (N.to_nat n)%:R) e1 + | RAdditive _ _ g e1 => fun f => Mnorm (fun x => f (g x)) e1 + | RnatAdditive _ g e1 => fun f => mul (f (g 1%N)) (Rnorm (GRing.natmul 1) e1) + | RNAdditive _ g e1 => fun f => + mul (f (g 1%num)) (Rnorm (fun n => (N.to_nat n)%:R) e1) + | RX _ x => fun f => f x + | _ => fun => f (Reval e) + end f +with Mnorm V (f : V -> R') (e : MExpr V) : R' := + match e in MExpr V return (V -> R') -> R' with + | M0 _ => fun => zero + | MAdd _ e1 e2 => fun f => add (Mnorm f e1) (Mnorm f e2) + | MMuln _ e1 e2 => fun f => mul (Mnorm f e1) (Rnorm (GRing.natmul 1) e2) + | MAdditive _ _ g e1 => fun f => Mnorm (fun x => f (g x)) e1 + | MnatAdditive _ g e1 => fun f => mul (f (g 1%N)) (Rnorm (GRing.natmul 1) e1) + | MNAdditive _ g e1 => fun f => + mul (f (g 1%num)) (Rnorm (fun n => (N.to_nat n)%:R) e1) + | MX _ x => fun f => f x + | _ => fun => f (Meval e) + end f. + +Lemma eq_Rnorm R (f f' : R -> R') (e : RExpr R) : + f =1 f' -> Rnorm f e = Rnorm f' e. +Proof. +pose P R e := forall (f f' : R -> R'), f =1 f' -> Rnorm f e = Rnorm f' e. +pose P0 V e := forall (f f' : V -> R'), f =1 f' -> Mnorm f e = Mnorm f' e. +move: f f'; elim e using (@RExpr_ind' P P0); rewrite {R e}/P {}/P0 //=. +- by move=> R e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> R e1 IHe1 e2 _ f f' feq; rewrite (IHe1 _ _ feq). +- by move=> R e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> R e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> R e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> p e1 IHe1 f f' feq; rewrite (IHe1 _ _ feq). +- by move=> S R g e1 IHe1 f f' feq; apply: IHe1 => x; apply: feq. +- by move=> V R g e1 IHe1 f f' feq; apply: IHe1 => x; apply: feq. +- by move=> R g e1 _ f f' ->. +- by move=> R g e1 _ f f' ->. +- by move=> V e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> V e1 IHe1 e2 _ f f' feq; rewrite (IHe1 _ _ feq). +- by move=> U V g e1 IHe1 f f' feq; apply: IHe1 => x; apply: feq. +- by move=> V g e1 _ f f' ->. +- by move=> V g e1 _ f f' ->. +Qed. + +End norm. + +Section correct. + +Variables (R' : semiRingType). + +Notation Rnorm := + (Rnorm (fun n => (nat_of_N n)%:R) 0 +%R 1 *%R (fun x n => x ^+ N.to_nat n)). +Notation Mnorm := + (Mnorm (fun n => (nat_of_N n)%:R) 0 +%R 1 *%R (fun x n => x ^+ N.to_nat n)). + +Lemma Rnorm_correct_rec R (f : {rmorphism R -> R'}) (e : RExpr R) : + f (Reval e) = Rnorm f e. +Proof. +pose P R e := forall (f : {rmorphism R -> R'}), f (Reval e) = Rnorm f e. +pose P0 V e := forall (f : {additive V -> R'}), f (Meval e) = Mnorm f e. +move: f; elim e using (@RExpr_ind' P P0); rewrite {R e}/P {}/P0 //=. +- by move=> R f; rewrite rmorph0. +- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2. +- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphMn -mulr_natr IHe1 IHe2. +- by move=> R f; rewrite rmorph1. +- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2. +- by move=> R e1 IHe1 n f; rewrite rmorphXn IHe1 -large_nat_N_nat. +- by move=> R e1 IHe1 n f; rewrite rmorphXn IHe1 -large_nat_N_nat. +- by move=> e1 IHe1 n f; rewrite rmorphXn IHe1 -large_nat_N_nat. +- move=> e1 IHe1 n f. + have ->: (Reval e1 ^ n)%num = Reval e1 ^+ N.to_nat n by lia. + by rewrite rmorphXn IHe1. +- move=> p e1 IHe1 f. + by rewrite add_pos_natE rmorphD IHe1 -[Pos.to_nat p]natn rmorph_nat. +- by move=> n f; rewrite -[nat_of_large_nat _]natn rmorph_nat -large_nat_N_nat. +- by move=> n f; rewrite -[RHS](rmorph_nat f); congr (f _); lia. +- by move=> R S g e1 IHe1 f; rewrite -/(comp f g _) IHe1. +- move=> R g e1 IHe1 f; rewrite -/(comp f g _) IHe1; apply: eq_Rnorm => /= n. + by rewrite -[RHS](rmorph_nat (f \o g)) natn. +- move=> R g e1 IHe1 f; rewrite -/(comp f g _) IHe1; apply: eq_Rnorm => /= n. + by rewrite -[RHS](rmorph_nat (f \o g)); congr (f (g _)); lia. +- by move=> V R g e1 IHe1 f; rewrite -/(comp f g _) IHe1. +- by move=> R g e1 IHe1 f; rewrite -[Reval e1]natn !raddfMn -mulr_natr IHe1. +- move=> R g e1 IHe1 f. + have ->: Reval e1 = (N.to_nat (Reval e1))%:R by lia. + by rewrite !raddfMn -mulr_natr -/(comp _ N.to_nat _) IHe1. +- by move=> V f; rewrite raddf0. +- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfD IHe1 IHe2. +- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfMn -mulr_natr IHe1 IHe2. +- by move=> V V' g e1 IHe1 f; rewrite -/(comp f g _) IHe1. +- by move=> V g e1 IHe1 f; rewrite -[Reval e1]natn !raddfMn -mulr_natr IHe1. +- move=> v g e1 IHe1 f. + have ->: Reval e1 = (N.to_nat (Reval e1))%:R by lia. + by rewrite !raddfMn -mulr_natr -/(comp _ N.to_nat _) IHe1. +Qed. + +Lemma Rnorm_correct (e : RExpr R') : Reval e = Rnorm id e. +Proof. exact: Rnorm_correct_rec idfun _. Qed. + +End correct. + +End SemiRing. + +Module Ring. + +Section norm. + +Variables (R' : ringType) (R_of_Z : Z -> R'). +Variables (zero : R') (add : R' -> R' -> R'). +Variables (opp : R' -> R') (sub : R' -> R' -> R'). +Variables (one : R') (mul : R' -> R' -> R') (exp : R' -> N -> R'). + +Fixpoint Rnorm R (f : R -> R') (e : RExpr R) : R' := + match e in RExpr R return (R -> R') -> R' with + | R0 _ => fun => zero + | RAdd _ e1 e2 | RnatAdd e1 e2 | RNAdd e1 e2 | RZAdd e1 e2 => + fun f => add (Rnorm f e1) (Rnorm f e2) + | RMuln _ e1 e2 => fun f => mul (Rnorm f e1) (Rnorm (GRing.natmul 1) e2) + | ROpp _ e1 | RZOpp e1 => fun f => opp (Rnorm f e1) + | RZSub e1 e2 => fun f => sub (Rnorm f e1) (Rnorm f e2) + | RMulz _ e1 e2 => fun f => mul (Rnorm f e1) (Rnorm intr e2) + | R1 _ => fun => one + | RMul _ e1 e2 | RnatMul e1 e2 | RNMul e1 e2 | RZMul e1 e2 => + fun f => mul (Rnorm f e1) (Rnorm f e2) + | RExpn _ e1 n | RnatExpn e1 n => + fun f => exp (Rnorm f e1) (N_of_large_nat n) + | RExpPosz _ e1 n => fun f => exp (Rnorm f e1) (N_of_large_nat n) + | RNExp e1 n => fun f => exp (Rnorm f e1) n + | RZExp e1 (Z.neg _) => fun f => zero + | RZExp e1 n => fun f => exp (Rnorm f e1) (Z.to_N n) + | RnatS p e => fun f => add (R_of_Z (Zpos p)) (Rnorm f e) + | RnatC n => fun => R_of_Z (Z_of_large_nat n) + | RPosz e1 => fun => Rnorm (GRing.natmul 1) e1 + | RNegz e1 => fun => opp (add one (Rnorm (GRing.natmul 1) e1)) + | RNC n => fun => R_of_Z (Z_of_N n) + | RZC n => fun => R_of_Z n + | RMorph _ _ g e1 => fun f => Rnorm (fun x => f (g x)) e1 + | RnatMorph _ _ e1 => fun => Rnorm (GRing.natmul 1) e1 + | RNMorph _ _ e1 => fun => Rnorm (fun n => (N.to_nat n)%:R) e1 + | RintMorph _ _ e1 => fun => Rnorm intr e1 + | RZMorph _ _ e1 => fun => Rnorm (fun n => (int_of_Z n)%:~R) e1 + | RAdditive _ _ g e1 => fun f => Mnorm (fun x => f (g x)) e1 + | RnatAdditive _ g e1 => fun f => mul (f (g 1%N)) (Rnorm (GRing.natmul 1) e1) + | RNAdditive _ g e1 => fun f => + mul (f (g 1%num)) (Rnorm (fun n => (N.to_nat n)%:R) e1) + | RintAdditive _ g e1 => fun f => mul (f (g 1%Z)) (Rnorm intr e1) + | RZAdditive _ g e1 => fun f => + mul (f (g (Zpos 1))) (Rnorm (fun n => (int_of_Z n)%:~R) e1) + | RX _ x => fun f => f x + | _ => fun => f (Reval e) + end f +with Mnorm V (f : V -> R') (e : MExpr V) : R' := + match e in MExpr V return (V -> R') -> R' with + | M0 _ => fun => zero + | MAdd _ e1 e2 => fun f => add (Mnorm f e1) (Mnorm f e2) + | MMuln _ e1 e2 => fun f => mul (Mnorm f e1) (Rnorm (GRing.natmul 1) e2) + | MOpp _ e1 => fun f => opp (Mnorm f e1) + | MMulz _ e1 e2 => fun f => mul (Mnorm f e1) (Rnorm intr e2) + | MAdditive _ _ g e1 => fun f => Mnorm (fun x => f (g x)) e1 + | MnatAdditive _ g e1 => fun f => mul (f (g 1%N)) (Rnorm (GRing.natmul 1) e1) + | MNAdditive _ g e1 => fun f => + mul (f (g 1%num)) (Rnorm (fun n => (N.to_nat n)%:R) e1) + | MintAdditive _ g e1 => fun f => mul (f (g 1%Z)) (Rnorm intr e1) + | MZAdditive _ g e1 => fun f => + mul (f (g (Zpos 1))) (Rnorm (fun n => (int_of_Z n)%:~R) e1) + | MX _ x => fun f => f x + end f. + +Lemma eq_Rnorm R (f f' : R -> R') (e : RExpr R) : + f =1 f' -> Rnorm f e = Rnorm f' e. +Proof. +pose P R e := forall (f f' : R -> R'), f =1 f' -> Rnorm f e = Rnorm f' e. +pose P0 V e := forall (f f' : V -> R'), f =1 f' -> Mnorm f e = Mnorm f' e. +move: f f'; elim e using (@RExpr_ind' P P0); rewrite {R e}/P {}/P0 //=. +- by move=> R e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> R e1 IHe1 e2 _ f f' feq; rewrite (IHe1 _ _ feq). +- by move=> R e1 IHe1 f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> R e1 IHe1 e2 _ f f' feq; rewrite (IHe1 _ _ feq). +- by move=> R e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> R e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> R e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 [|p|p] f f' feq //; rewrite (IHe1 _ _ feq). +- by move=> p e1 IHe1 f f' feq; rewrite (IHe1 _ _ feq). +- by move=> S R g e1 IHe1 f f' feq; apply: IHe1 => x; apply: feq. +- by move=> V R g e1 IHe1 f f' feq; apply: IHe1 => x; apply: feq. +- by move=> R g e1 _ f f' ->. +- by move=> R g e1 _ f f' ->. +- by move=> R g e1 _ f f' ->. +- by move=> R g e1 _ f f' ->. +- by move=> V e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> V e1 IHe1 e2 _ f f' feq; rewrite (IHe1 _ _ feq). +- by move=> V e1 IHe1 f f' feq; rewrite (IHe1 _ _ feq). +- by move=> V e1 IHe1 e2 _ f f' feq; rewrite (IHe1 _ _ feq). +- by move=> U V g e1 IHe1 f f' feq; apply: IHe1 => x; apply: feq. +- by move=> V g e1 _ f f' ->. +- by move=> V g e1 _ f f' ->. +- by move=> V g e1 _ f f' ->. +- by move=> V g e1 _ f f' ->. +Qed. + +End norm. + +Section correct. + +Variables (R' : ringType). + +Notation Rnorm := + (Rnorm (fun n : Z => (int_of_Z n)%:~R) 0 +%R -%R (fun x y => x - y) + 1 *%R (fun x n => x ^+ N.to_nat n)). +Notation Mnorm := + (Mnorm (fun n : Z => (int_of_Z n)%:~R) 0 +%R -%R (fun x y => x - y) + 1 *%R (fun x n => x ^+ N.to_nat n)). + +Lemma Rnorm_correct_rec R (f : {rmorphism R -> R'}) (e : RExpr R) : + f (Reval e) = Rnorm f e. +Proof. +pose P R e := forall (f : {rmorphism R -> R'}), f (Reval e) = Rnorm f e. +pose P0 V e := forall (f : {additive V -> R'}), f (Meval e) = Mnorm f e. +move: f; elim e using (@RExpr_ind' P P0); rewrite {R e}/P {}/P0 //=. +- by move=> R f; rewrite rmorph0. +- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2. +- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphMn -mulr_natr IHe1 IHe2. +- by move=> R e1 IHe1 f; rewrite rmorphN IHe1. +- by move=> e1 IHe1 f; rewrite rmorphN IHe1. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphB IHe1 IHe2. +- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphMz -mulrzr IHe1 IHe2. +- by move=> R f; rewrite rmorph1. +- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2. +- by move=> R e1 IHe1 n f; rewrite rmorphXn IHe1 -large_nat_N_nat. +- by move=> R e1 IHe1 n f; rewrite rmorphXn IHe1 -large_nat_N_nat. +- by move=> e1 IHe1 n f; rewrite rmorphXn IHe1 -large_nat_N_nat. +- move=> e1 IHe1 n f. + have ->: (Reval e1 ^ n)%num = Reval e1 ^+ N.to_nat n by lia. + by rewrite rmorphXn IHe1. +- move=> e1 IHe1 [|p|p] f; rewrite ?(rmorph0, rmorph1) //=. + by rewrite /Rnorm -/Rnorm -IHe1 -rmorphXn /=; congr (f _); lia. +- move=> p e1 IHe1 f. + by rewrite add_pos_natE rmorphD IHe1 -[Pos.to_nat p]natn rmorph_nat. +- move=> n f. + by rewrite -[nat_of_large_nat _]natn rmorph_nat pmulrn -large_nat_Z_int. +- by move=> e1 IHe1 f; rewrite -[Posz _]intz rmorph_int /intmul IHe1. +- by move=> e1 IHe1 f; rewrite -[Negz _]intz rmorph_int /intmul mulrS IHe1. +- move=> n f; rewrite /Rnorm. + have ->: int_of_Z (Z_of_N n) = nat_of_N n by lia. + by rewrite -[RHS](rmorph_nat f); congr (f _); lia. +- by move=> n f; rewrite -[RHS](rmorph_int f); congr (f _); lia. +- by move=> R S g e1 IHe1 f; rewrite -/(comp f g _) IHe1. +- move=> R g e1 IHe1 f; rewrite -/(comp f g _) IHe1; apply: eq_Rnorm => /= n. + by rewrite -[RHS](rmorph_nat (f \o g)) natn. +- move=> R g e1 IHe1 f; rewrite -/(comp f g _) IHe1; apply: eq_Rnorm => /= n. + by rewrite -[RHS](rmorph_nat (f \o g)); congr (f (g _)); lia. +- move=> R g e1 IHe1 f; rewrite -/(comp f g _) IHe1; apply: eq_Rnorm => /= n. + by rewrite -[RHS](rmorph_int (f \o g)); congr (f (g _)); lia. +- move=> R g e1 IHe1 f; rewrite -/(comp f g _) IHe1; apply: eq_Rnorm => /= n. + by rewrite -[RHS](rmorph_int (f \o g)); congr (f (g _)); lia. +- by move=> V R g e1 IHe1 f; rewrite -/(comp f g _) IHe1. +- by move=> R g e1 IHe1 f; rewrite -[Reval e1]natn !raddfMn -mulr_natr IHe1. +- move=> R g e1 IHe1 f. + have ->: Reval e1 = (N.to_nat (Reval e1))%:R by lia. + by rewrite !raddfMn -mulr_natr -/(comp _ N.to_nat _) IHe1. +- move=> R g e1 IHe1 f. + by rewrite -[Reval e1]intz [LHS](raddfMz (f \o g)) -mulrzr IHe1. +- move=> R g e1 IHe1 f. + have ->: Reval e1 = (int_of_Z (Reval e1))%:~R by lia. + by rewrite [LHS](raddfMz (f \o g)) -mulrzr -/(comp _ int_of_Z _) IHe1. +- by move=> V f; rewrite raddf0. +- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfD IHe1 IHe2. +- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfMn -mulr_natr IHe1 IHe2. +- by move=> V e1 IHe1 f; rewrite raddfN IHe1. +- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfMz -mulrzr IHe1 IHe2. +- by move=> V V' g e1 IHe1 f; rewrite -/(comp f g _) IHe1. +- by move=> V g e1 IHe1 f; rewrite -[Reval e1]natn !raddfMn -mulr_natr IHe1. +- move=> v g e1 IHe1 f. + have ->: Reval e1 = (N.to_nat (Reval e1))%:R by lia. + by rewrite !raddfMn -mulr_natr -/(comp _ N.to_nat _) IHe1. +- move=> V g e1 IHe1 f. + by rewrite -[Reval e1]intz [LHS](raddfMz (f \o g)) -mulrzr IHe1. +- move=> V g e1 IHe1 f. + have ->: Reval e1 = (int_of_Z (Reval e1))%:~R by lia. + by rewrite [LHS](raddfMz (f \o g)) -mulrzr -/(comp _ int_of_Z _) IHe1. +Qed. + +Lemma Rnorm_correct (e : RExpr R') : Reval e = Rnorm id e. +Proof. exact: Rnorm_correct_rec idfun _. Qed. + +End correct. + +End Ring. + +Module Field. + +Section norm. + +Variables (F : ringType) (F_of_Z : Z -> F). +Variables (zero : F) (add : F -> F -> F) (opp : F -> F) (sub : F -> F -> F). +Variables (one : F) (mul : F -> F -> F) (exp : F -> N -> F) (inv : F -> F). + +Fixpoint Rnorm R (f : R -> F) (e : RExpr R) : F := + match e in RExpr R return (R -> F) -> F with + | R0 _ => fun => zero + | RAdd _ e1 e2 | RnatAdd e1 e2 | RNAdd e1 e2 | RZAdd e1 e2 => + fun f => add (Rnorm f e1) (Rnorm f e2) + | RMuln _ e1 e2 => fun f => mul (Rnorm f e1) (Rnorm (GRing.natmul 1) e2) + | ROpp _ e1 | RZOpp e1 => fun f => opp (Rnorm f e1) + | RZSub e1 e2 => fun f => sub (Rnorm f e1) (Rnorm f e2) + | RMulz _ e1 e2 => fun f => mul (Rnorm f e1) (Rnorm intr e2) + | R1 _ => fun => one + | RMul _ e1 e2 | RnatMul e1 e2 | RNMul e1 e2 | RZMul e1 e2 => + fun f => mul (Rnorm f e1) (Rnorm f e2) + | RExpn _ e1 n | RnatExpn e1 n => fun f => exp (Rnorm f e1) (N_of_large_nat n) + | RExpPosz _ e1 n => fun f => exp (Rnorm f e1) (N_of_large_nat n) + | RExpNegz _ e1 n => + fun f => inv (exp (Rnorm f e1) (N.succ (N_of_large_nat n))) + | RNExp e1 n => fun f => exp (Rnorm f e1) n + | RZExp e1 (Z.neg _) => fun f => zero + | RZExp e1 n => fun f => exp (Rnorm f e1) (Z.to_N n) + | RInv _ e1 => fun f => inv (Rnorm f e1) + | RnatS p e => fun f => add (F_of_Z (Zpos p)) (Rnorm f e) + | RnatC n => fun => F_of_Z (Z_of_large_nat n) + | RPosz e1 => fun => Rnorm (GRing.natmul 1) e1 + | RNegz e1 => fun => opp (add one (Rnorm (GRing.natmul 1) e1)) + | RNC n => fun => F_of_Z (Z_of_N n) + | RZC n => fun => F_of_Z n + | RMorph _ _ g e1 => fun f => Rnorm (fun x => f (g x)) e1 + | RnatMorph _ _ e1 => fun => Rnorm (GRing.natmul 1) e1 + | RNMorph _ _ e1 => fun => Rnorm (fun n => (N.to_nat n)%:R) e1 + | RintMorph _ _ e1 => fun => Rnorm intr e1 + | RZMorph _ _ e1 => fun => Rnorm (fun n => (int_of_Z n)%:~R) e1 + | RAdditive _ _ g e1 => fun f => Mnorm (fun x => f (g x)) e1 + | RnatAdditive _ g e1 => fun f => mul (f (g 1%N)) (Rnorm (GRing.natmul 1) e1) + | RNAdditive _ g e1 => fun f => + mul (f (g 1%num)) (Rnorm (fun n => (N.to_nat n)%:R) e1) + | RintAdditive _ g e1 => fun f => mul (f (g 1%Z)) (Rnorm intr e1) + | RZAdditive _ g e1 => fun f => + mul (f (g (Zpos 1))) (Rnorm (fun n => (int_of_Z n)%:~R) e1) + | RX _ x => fun f => f x + end f +with Mnorm V (f : V -> F) (e : MExpr V) : F := + match e in MExpr V return (V -> F) -> F with + | M0 _ => fun => zero + | MAdd _ e1 e2 => fun f => add (Mnorm f e1) (Mnorm f e2) + | MMuln _ e1 e2 => fun f => mul (Mnorm f e1) (Rnorm (GRing.natmul 1) e2) + | MOpp _ e1 => fun f => opp (Mnorm f e1) + | MMulz _ e1 e2 => fun f => mul (Mnorm f e1) (Rnorm intr e2) + | MAdditive _ _ g e1 => fun f => Mnorm (fun x => f (g x)) e1 + | MnatAdditive _ g e1 => fun f => mul (f (g 1%N)) (Rnorm (GRing.natmul 1) e1) + | MNAdditive _ g e1 => fun f => + mul (f (g 1%num)) (Rnorm (fun n => (N.to_nat n)%:R) e1) + | MintAdditive _ g e1 => fun f => mul (f (g 1%Z)) (Rnorm intr e1) + | MZAdditive _ g e1 => fun f => + mul (f (g (Zpos 1))) (Rnorm (fun n => (int_of_Z n)%:~R) e1) + | MX _ x => fun f => f x + end f. + +Lemma eq_Rnorm R (f f' : R -> F) (e : RExpr R) : + f =1 f' -> Rnorm f e = Rnorm f' e. +Proof. +pose P R e := forall (f f' : R -> F), f =1 f' -> Rnorm f e = Rnorm f' e. +pose P0 V e := forall (f f' : V -> F), f =1 f' -> Mnorm f e = Mnorm f' e. +move: f f'; elim e using (@RExpr_ind' P P0); rewrite {R e}/P {}/P0 //=. +- by move=> R e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> R e1 IHe1 e2 _ f f' feq; rewrite (IHe1 _ _ feq). +- by move=> R e1 IHe1 f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> R e1 IHe1 e2 _ f f' feq; rewrite (IHe1 _ _ feq). +- by move=> R e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> R e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> R e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> R e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 n f f' feq; rewrite (IHe1 _ _ feq). +- by move=> e1 IHe1 [|p|p] f f' feq //; rewrite (IHe1 _ _ feq). +- by move=> R e1 IHe1 f f' feq; rewrite !(IHe1 _ _ feq). +- by move=> P e1 IHe1 f f' feq; rewrite (IHe1 _ _ feq). +- by move=> S R g e1 IHe1 f f' feq; apply: IHe1 => x; apply: feq. +- by move=> V R g e1 IHe1 f f' feq; apply: IHe1 => x; apply: feq. +- by move=> R g e1 _ f f' ->. +- by move=> R g e1 _ f f' ->. +- by move=> R g e1 _ f f' ->. +- by move=> R g e1 _ f f' ->. +- by move=> V e1 IHe1 e2 IHe2 f f' feq; rewrite (IHe1 _ _ feq) (IHe2 _ _ feq). +- by move=> V e1 IHe1 e2 _ f f' feq; rewrite (IHe1 _ _ feq). +- by move=> V e1 IHe1 f f' feq; rewrite (IHe1 _ _ feq). +- by move=> V e1 IHe1 e2 _ f f' feq; rewrite (IHe1 _ _ feq). +- by move=> U V g e1 IHe1 f f' feq; apply: IHe1 => x; apply: feq. +- by move=> V g e1 _ f f' ->. +- by move=> V g e1 _ f f' ->. +- by move=> V g e1 _ f f' ->. +- by move=> V g e1 _ f f' ->. +Qed. + +End norm. + +Section correct. + +Variables (F : fieldType). + +Notation Rnorm := + (Rnorm (fun (n : Z) => (int_of_Z n)%:~R) 0 +%R -%R (fun x y => x - y) + 1 *%R (fun x n => x ^+ N.to_nat n) GRing.inv). +Notation Mnorm := + (Mnorm (fun (n : Z) => (int_of_Z n)%:~R) 0 +%R -%R (fun x y => x - y) + 1 *%R (fun x n => x ^+ N.to_nat n) GRing.inv). + +Lemma Rnorm_correct_rec R (f : {rmorphism R -> F}) (e : RExpr R) : + f (Reval e) = Rnorm f e. +Proof. +pose P R e := forall (f : {rmorphism R -> F}), f (Reval e) = Rnorm f e. +pose P0 V e := forall (f : {additive V -> F}), f (Meval e) = Mnorm f e. +move: f; elim e using (@RExpr_ind' P P0); rewrite {R e}/P {}/P0 //=. +- by move=> R f; rewrite rmorph0. +- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2. +- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphMn -mulr_natr IHe1 IHe2. +- by move=> R e1 IHe1 f; rewrite rmorphN IHe1. +- by move=> e1 IHe1 f; rewrite rmorphN IHe1. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphB IHe1 IHe2. +- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphMz -mulrzr IHe1 IHe2. +- by move=> R f; rewrite rmorph1. +- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2. +- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2. +- by move=> R e1 IHe1 n f; rewrite rmorphXn IHe1 -large_nat_N_nat. +- by move=> R e1 IHe1 n f; rewrite rmorphXn IHe1 -large_nat_N_nat. +- move=> R e1 IHe1 n f; rewrite fmorphV rmorphXn IHe1 -large_nat_N_nat. + by congr (_ ^- _); lia. +- by move=> e1 IHe1 n f; rewrite rmorphXn IHe1 -large_nat_N_nat. +- move=> e1 IHe1 n f. + have ->: (Reval e1 ^ n)%num = Reval e1 ^+ N.to_nat n by lia. + by rewrite rmorphXn IHe1. +- move=> e1 IHe1 [|p|p] f; rewrite ?(rmorph0, rmorph1) //=. + by rewrite /Rnorm -/Rnorm -IHe1 -rmorphXn /=; congr (f _); lia. +- by move=> R e1 IHe1 f; rewrite fmorphV IHe1. +- move=> p e1 IHe1 f. + by rewrite add_pos_natE rmorphD IHe1 -[Pos.to_nat p]natn rmorph_nat. +- move=> n f. + by rewrite -[nat_of_large_nat _]natn rmorph_nat pmulrn -large_nat_Z_int. +- by move=> e1 IHe1 f; rewrite -[Posz _]intz rmorph_int /intmul IHe1. +- by move=> e1 IHe1 f; rewrite -[Negz _]intz rmorph_int /intmul mulrS IHe1. +- move=> n f; rewrite /Rnorm. + have ->: int_of_Z (Z_of_N n) = nat_of_N n by lia. + by rewrite -[RHS](rmorph_nat f); congr (f _); lia. +- by move=> n f; rewrite -[RHS](rmorph_int f); congr (f _); lia. +- by move=> R S g e1 IHe1 f; rewrite -/(comp f g _) IHe1. +- move=> R g e1 IHe1 f; rewrite -/(comp f g _) IHe1; apply: eq_Rnorm => /= n. + by rewrite -[RHS](rmorph_nat (f \o g)) natn. +- move=> R g e1 IHe1 f; rewrite -/(comp f g _) IHe1; apply: eq_Rnorm => /= n. + by rewrite -[RHS](rmorph_nat (f \o g)); congr (f (g _)); lia. +- move=> R g e1 IHe1 f; rewrite -/(comp f g _) IHe1; apply: eq_Rnorm => /= n. + by rewrite -[RHS](rmorph_int (f \o g)); congr (f (g _)); lia. +- move=> R g e1 IHe1 f; rewrite -/(comp f g _) IHe1; apply: eq_Rnorm => /= n. + by rewrite -[RHS](rmorph_int (f \o g)); congr (f (g _)); lia. +- by move=> V R g e1 IHe1 f; rewrite -/(comp f g _) IHe1. +- by move=> R g e1 IHe1 f; rewrite -[Reval e1]natn !raddfMn -mulr_natr IHe1. +- move=> R g e1 IHe1 f. + have ->: Reval e1 = (N.to_nat (Reval e1))%:R by lia. + by rewrite !raddfMn -mulr_natr -/(comp _ N.to_nat _) IHe1. +- move=> R g e1 IHe1 f. + by rewrite -[Reval e1]intz [LHS](raddfMz (f \o g)) -mulrzr IHe1. +- move=> R g e1 IHe1 f. + have ->: Reval e1 = (int_of_Z (Reval e1))%:~R by lia. + by rewrite [LHS](raddfMz (f \o g)) -mulrzr -/(comp _ int_of_Z _) IHe1. +- by move=> V f; rewrite raddf0. +- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfD IHe1 IHe2. +- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfMn -mulr_natr IHe1 IHe2. +- by move=> V e1 IHe1 f; rewrite raddfN IHe1. +- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfMz -mulrzr IHe1 IHe2. +- by move=> V V' g e1 IHe1 f; rewrite -/(comp f g _) IHe1. +- by move=> V g e1 IHe1 f; rewrite -[Reval e1]natn !raddfMn -mulr_natr IHe1. +- move=> v g e1 IHe1 f. + have ->: Reval e1 = (N.to_nat (Reval e1))%:R by lia. + by rewrite !raddfMn -mulr_natr -/(comp _ N.to_nat _) IHe1. +- move=> V g e1 IHe1 f. + by rewrite -[Reval e1]intz [LHS](raddfMz (f \o g)) -mulrzr IHe1. +- move=> V g e1 IHe1 f. + have ->: Reval e1 = (int_of_Z (Reval e1))%:~R by lia. + by rewrite [LHS](raddfMz (f \o g)) -mulrzr -/(comp _ int_of_Z _) IHe1. +Qed. + +Lemma Rnorm_correct (e : RExpr F) : Reval e = Rnorm id e. +Proof. exact: Rnorm_correct_rec idfun _. Qed. + +End correct. + +End Field. + +Module Lra. + +Section norm. + +Variables (F : ringType) (F_of_Z : bool -> Z -> F). +Variables (zero : F) (add : F -> F -> F) (opp : F -> F) (sub : F -> F -> F). +Variables (one : F) (mul : F -> F -> F) (exp : F -> N -> F) (inv : F -> F). + +Fixpoint Rnorm invb R (f : R -> F) (e : RExpr R) : F := + let invr r := if invb then inv r else r in + match e in RExpr R return (R -> F) -> F with + | R0 _ => fun => zero + | RAdd _ e1 e2 | RnatAdd e1 e2 | RNAdd e1 e2 | RZAdd e1 e2 => fun f => + invr (add (Rnorm false f e1) (Rnorm false f e2)) + | RMuln _ e1 e2 => fun f => + mul (Rnorm invb f e1) (Rnorm invb (GRing.natmul 1) e2) + | ROpp _ e1 | RZOpp e1 => fun f => opp (Rnorm invb f e1) + | RZSub e1 e2 => fun f => invr (sub (Rnorm false f e1) (Rnorm false f e2)) + | RMulz _ e1 e2 => fun f => mul (Rnorm invb f e1) (Rnorm invb intr e2) + | R1 _ => fun => one + | RMul _ e1 e2 | RnatMul e1 e2 | RNMul e1 e2 | RZMul e1 e2 => fun f => + mul (Rnorm invb f e1) (Rnorm invb f e2) + | RExpn _ e1 n | RnatExpn e1 n => fun f => + exp (Rnorm invb f e1) (N_of_large_nat n) + | RExpPosz _ e1 n => fun f => exp (Rnorm invb f e1) (N_of_large_nat n) + | RExpNegz _ e1 n => fun f => + exp (Rnorm (~~ invb) f e1) (N.succ (N_of_large_nat n)) + | RNExp e1 n => fun f => exp (Rnorm invb f e1) n + | RZExp e1 (Z.neg _) => fun f => zero + | RZExp e1 n => fun f => exp (Rnorm invb f e1) (Z.to_N n) + | RInv _ e1 => fun f => Rnorm (~~ invb) f e1 + | RnatS p e => fun f => invr (add (F_of_Z false (Zpos p)) (Rnorm false f e)) + | RnatC n => fun => F_of_Z invb (Z_of_large_nat n) + | RPosz e1 => fun => Rnorm invb (GRing.natmul 1) e1 + | RNegz e1 => fun => invr (opp (add one (Rnorm false (GRing.natmul 1) e1))) + | RNC n => fun => F_of_Z invb (Z_of_N n) + | RZC n => fun => F_of_Z invb n + | RMorph _ _ g e1 => fun f => Rnorm invb (fun x => f (g x)) e1 + | RnatMorph _ _ e1 => fun => Rnorm invb (GRing.natmul 1) e1 + | RNMorph _ _ e1 => fun => Rnorm invb (fun n => (N.to_nat n)%:R) e1 + | RintMorph _ _ e1 => fun => Rnorm invb intr e1 + | RZMorph _ _ e1 => fun => Rnorm invb (fun n => (int_of_Z n)%:~R) e1 + | RAdditive _ _ g e1 => fun f => Mnorm invb (fun x => f (g x)) e1 + | RnatAdditive _ g e1 => fun f => + mul (invr (f (g 1%N))) (Rnorm invb (GRing.natmul 1) e1) + | RNAdditive _ g e1 => fun f => + mul (invr (f (g 1%num))) (Rnorm invb (fun n => (N.to_nat n)%:R) e1) + | RintAdditive _ g e1 => fun f => + mul (invr (f (g 1%Z))) (Rnorm invb intr e1) + | RZAdditive _ g e1 => fun f => + mul (invr (f (g (Zpos 1)))) (Rnorm invb (fun n => (int_of_Z n)%:~R) e1) + | RX _ x => fun f => invr (f x) + end f +with Mnorm invb V (f : V -> F) (e : MExpr V) : F := + let invr r := if invb then inv r else r in + match e in MExpr V return (V -> F) -> F with + | M0 _ => fun => zero + | MAdd _ e1 e2 => fun f => invr (add (Mnorm false f e1) (Mnorm false f e2)) + | MMuln _ e1 e2 => fun f => + mul (Mnorm invb f e1) (Rnorm invb (GRing.natmul 1) e2) + | MOpp _ e1 => fun f => opp (Mnorm invb f e1) + | MMulz _ e1 e2 => fun f => mul (Mnorm invb f e1) (Rnorm invb intr e2) + | MAdditive _ _ g e1 => fun f => Mnorm invb (fun x => f (g x)) e1 + | MnatAdditive _ g e1 => fun f => + mul (invr (f (g 1%N))) (Rnorm invb (GRing.natmul 1) e1) + | MNAdditive _ g e1 => fun f => + mul (invr (f (g 1%num))) (Rnorm invb (fun n => (N.to_nat n)%:R) e1) + | MintAdditive _ g e1 => fun f => mul (invr (f (g 1%Z))) (Rnorm invb intr e1) + | MZAdditive _ g e1 => fun f => + mul (invr (f (g (Zpos 1)))) (Rnorm invb (fun n => (int_of_Z n)%:~R) e1) + | MX _ x => fun f => invr (f x) + end f. + +Lemma eq_Rnorm invb R (f f' : R -> F) (e : RExpr R) : + f =1 f' -> Rnorm invb f e = Rnorm invb f' e. Proof. -by case: n => [n|[d|d]|[d|d]] //=; rewrite -(uint_N_nat, hex_uint_N_nat); - rewrite /Z.of_uint /N.of_uint /Z.of_hex_uint /N.of_hex_uint; lia. +pose P R e := + forall invb (f f' : R -> F), f =1 f' -> Rnorm invb f e = Rnorm invb f' e. +pose P0 V e := + forall invb (f f' : V -> F), f =1 f' -> Mnorm invb f e = Mnorm invb f' e. +move: invb f f'; elim e using (@RExpr_ind' P P0); rewrite {R e}/P {}/P0 //=. +- move=> R e1 IHe1 e2 IHe2 invb f f' feq. + by rewrite (IHe1 _ _ _ feq) (IHe2 _ _ _ feq). +- move=> e1 IHe1 e2 IHe2 invb f f' feq. + by rewrite (IHe1 _ _ _ feq) (IHe2 _ _ _ feq). +- move=> e1 IHe1 e2 IHe2 invb f f' feq. + by rewrite (IHe1 _ _ _ feq) (IHe2 _ _ _ feq). +- move=> e1 IHe1 e2 IHe2 invb f f' feq. + by rewrite (IHe1 _ _ _ feq) (IHe2 _ _ _ feq). +- by move=> R e1 IHe1 e2 _ invb f f' feq; rewrite (IHe1 _ _ _ feq). +- by move=> R e1 IHe1 invb f f' feq; rewrite (IHe1 _ _ _ feq). +- by move=> e1 IHe1 invb f f' feq; rewrite (IHe1 _ _ _ feq). +- move=> e1 IHe1 e2 IHe2 invb f f' feq. + by rewrite (IHe1 _ _ _ feq) (IHe2 _ _ _ feq). +- by move=> R e1 IHe1 e2 _ invb f f' feq; rewrite (IHe1 _ _ _ feq). +- move=> R e1 IHe1 e2 IHe2 invb f f' feq. + by rewrite (IHe1 _ _ _ feq) (IHe2 _ _ _ feq). +- move=> e1 IHe1 e2 IHe2 invb f f' feq. + by rewrite (IHe1 _ _ _ feq) (IHe2 _ _ _ feq). +- move=> e1 IHe1 e2 IHe2 invb f f' feq. + by rewrite (IHe1 _ _ _ feq) (IHe2 _ _ _ feq). +- move=> e1 IHe1 e2 IHe2 invb f f' feq. + by rewrite (IHe1 _ _ _ feq) (IHe2 _ _ _ feq). +- by move=> R e1 IHe1 n invb f f' feq; rewrite (IHe1 _ _ _ feq). +- by move=> R e1 IHe1 n invb f f' feq; rewrite (IHe1 _ _ _ feq). +- by move=> R e1 IHe1 n invb f f' feq; rewrite (IHe1 _ _ _ feq). +- by move=> e1 IHe1 n invb f f' feq; rewrite (IHe1 _ _ _ feq). +- by move=> e1 IHe1 n invb f f' feq; rewrite (IHe1 _ _ _ feq). +- by move=> e1 IHe1 [|p|p] invb f f' feq //; rewrite (IHe1 _ _ _ feq). +- by move=> R e1 IHe1 invb f f' feq; rewrite !(IHe1 _ _ _ feq). +- by move=> P e1 IHe1 invb f f' feq; rewrite (IHe1 _ _ _ feq). +- by move=> S R g e1 IHe1 invb f f' feq; apply: IHe1 => x; apply: feq. +- by move=> V R g e1 IHe1 invb f f' feq; apply: IHe1 => x; apply: feq. +- by move=> R g e1 _ invb f f' ->. +- by move=> R g e1 _ invb f f' ->. +- by move=> R g e1 _ invb f f' ->. +- by move=> R g e1 _ invb f f' ->. +- by move=> R x invb f f' ->. +- move=> V e1 IHe1 e2 IHe2 invb f f' feq. + by rewrite (IHe1 _ _ _ feq) (IHe2 _ _ _ feq). +- by move=> V e1 IHe1 e2 _ invb f f' feq; rewrite (IHe1 _ _ _ feq). +- by move=> V e1 IHe1 invb f f' feq; rewrite (IHe1 _ _ _ feq). +- by move=> V e1 IHe1 e2 _ invb f f' feq; rewrite (IHe1 _ _ _ feq). +- by move=> U V g e1 IHe1 invb f f' feq; apply: IHe1 => x; apply: feq. +- by move=> V g e1 _ invb f f' ->. +- by move=> V g e1 _ invb f f' ->. +- by move=> V g e1 _ invb f f' ->. +- by move=> V g e1 _ invb f f' ->. +- by move=> V x invb f f' ->. Qed. +End norm. + +Lemma Rnorm_eq invb (F : ringType) (f f' : bool -> Z -> F) + zero add opp sub one mul exp inv : f =2 f' -> + forall (R : semiRingType) (env : R -> F) e, + Rnorm f zero add opp sub one mul exp inv invb env e = + Rnorm f' zero add opp sub one mul exp inv invb env e. +Proof. +move=> ff' R m e. +pose P R e := forall f f' invb (m : R -> F), f =2 f' -> + Rnorm f zero add opp sub one mul exp inv invb m e = + Rnorm f' zero add opp sub one mul exp inv invb m e. +pose P0 V e := forall f f' invb (m : V -> F), f =2 f' -> + Mnorm f zero add opp sub one mul exp inv invb m e = + Mnorm f' zero add opp sub one mul exp inv invb m e. +move: f f' invb m ff'. +elim e using (@RExpr_ind' P P0); rewrite {R e}/P {}/P0 //=. +- move=> R e1 IHe1 e2 IHe2 f f'. + by case=> m ff'; [congr inv|]; (congr add; [exact: IHe1|exact: IHe2]). +- move=> e1 IHe1 e2 IHe2 f f'. + by case=> m ff'; [congr inv|]; (congr add; [exact: IHe1|exact: IHe2]). +- move=> e1 IHe1 e2 IHe2 f f'. + by case=> m ff'; [congr inv|]; (congr add; [exact: IHe1|exact: IHe2]). +- move=> e1 IHe1 e2 IHe2 f f'. + by case=> m ff'; [congr inv|]; (congr add; [exact: IHe1|exact: IHe2]). +- move=> R e1 IHe1 e2 IHe2 f f' invb m ff'. + by congr mul; [exact: IHe1|exact: IHe2]. +- by move=> R e1 IHe1 f f' invb m ff'; congr opp; exact: IHe1. +- by move=> e1 IHe1 f f' invb m ff'; congr opp; exact: IHe1. +- move=> e1 IHe1 e2 IHe2 f f'. + by case=> m ff'; [congr inv|]; (congr sub; [exact: IHe1|exact: IHe2]). +- move=> R e1 IHe1 e2 IHe2 f f' invb m ff'. + by congr mul; [exact: IHe1|exact: IHe2]. +- move=> R e1 IHe1 e2 IHe2 f f' invb m ff'. + by congr mul; [exact: IHe1|exact: IHe2]. +- move=> e1 IHe1 e2 IHe2 f f' invb m ff'. + by congr mul; [exact: IHe1|exact: IHe2]. +- move=> e1 IHe1 e2 IHe2 f f' invb m ff'. + by congr mul; [exact: IHe1|exact: IHe2]. +- move=> e1 IHe1 e2 IHe2 f f' invb m ff'. + by congr mul; [exact: IHe1|exact: IHe2]. +- by move=> R e1 IHe1 n f f' invb m ff'; congr exp; exact: IHe1. +- by move=> R e1 IHe1 n f f' invb m ff'; congr exp; exact: IHe1. +- by move=> R e1 IHe1 n f f' invb m ff'; congr exp; exact: IHe1. +- by move=> e1 IHe1 n f f' invb m ff'; congr exp; exact: IHe1. +- by move=> e1 IHe1 n f f' invb m ff'; congr exp; exact: IHe1. +- by move=> e1 IHe1 [|p|//] f f' invb m ff'; congr exp; exact: IHe1. +- by move=> R e1 IHe1 f f' invb m ff'; apply: IHe1. +- move=> p e IHe f f'. + by case=> m ff'; [congr inv|]; congr add; rewrite ?ff'//; exact: IHe. +- by move=> n f f' invb m ff'; rewrite /Rnorm ff'. +- by move=> e IHe f f' invb m ff'; exact: IHe. +- by move=> e IHe f f' [] m ff'; [congr inv|]; congr opp; congr add; exact: IHe. +- by move=> n f f' invb m ff'; rewrite /Rnorm ff'. +- by move=> n f f' invb m ff'; rewrite /Rnorm ff'. +- by move=> R' R g e IHe f f' invb m ff'; exact: IHe. +- by move=> R g e IHe f f' invb m ff'; exact: IHe. +- by move=> R g e IHe f f' invb m ff'; exact: IHe. +- by move=> R g e IHe f f' invb m ff'; exact: IHe. +- by move=> R g e IHe f f' invb m ff'; exact: IHe. +- by move=> V R g e IHe f f' invb m ff'; exact: IHe. +- by move=> R g e IHe f f' invb m ff'; congr mul; exact: IHe. +- by move=> R g e IHe f f' invb m ff'; congr mul; exact: IHe. +- by move=> R g e IHe f f' invb m ff'; congr mul; exact: IHe. +- by move=> R g e IHe f f' invb m ff'; congr mul; exact: IHe. +- move=> V e1 IHe1 e2 IHe2 f f'. + by case=> m ff'; [congr inv|]; (congr add; [exact: IHe1|exact: IHe2]). +- move=> V e1 IHe1 e2 IHe2 f f' invb m ff'. + by congr mul; [exact: IHe1|exact: IHe2]. +- by move=> V e IHe f f' invb m ff'; congr opp; exact: IHe. +- move=> V e1 IHe1 e2 IHe2 f f' invb m ff'. + by congr mul; [exact: IHe1|exact: IHe2]. +- by move=> V V' g e IHe f f' invb m ff'; exact: IHe. +- by move=> V g e IHe f f' invb m ff'; congr mul; exact: IHe. +- by move=> V g e IHe f f' invb m ff'; congr mul; exact: IHe. +- by move=> V g e IHe f f' invb m ff'; congr mul; exact: IHe. +- by move=> V g e IHe f f' invb m ff'; congr mul; exact: IHe. +Qed. + +Section correct. + +Variables (F : fieldType). + +Notation F_of_Z := + (fun b (n : Z) => if b then (int_of_Z n)%:~R^-1 else (int_of_Z n)%:~R). +Notation Rnorm := + (Rnorm F_of_Z 0 +%R -%R (fun x y => x - y) + 1 *%R (fun x n => x ^+ N.to_nat n) GRing.inv). +Notation Mnorm := + (Mnorm F_of_Z 0 +%R -%R (fun x y => x - y) + 1 *%R (fun x n => x ^+ N.to_nat n) GRing.inv). + +Lemma Rnorm_correct_rec (invb : bool) R (f : {rmorphism R -> F}) (e : RExpr R) : + (if invb then (f (Reval e))^-1 else f (Reval e)) = Rnorm invb f e. +Proof. +pose P R e := forall invb (f : {rmorphism R -> F}), + (if invb then (f (Reval e))^-1 else f (Reval e)) = Rnorm invb f e. +pose P0 V e := forall invb (f : {additive V -> F}), + (if invb then (f (Meval e))^-1 else f (Meval e)) = Mnorm invb f e. +move: invb f; elim e using (@RExpr_ind' P P0); rewrite {R e}/P {}/P0 //=. +- by move=> R invb f; rewrite rmorph0 invr0 if_same. +- by move=> R e1 IHe1 e2 IHe2 invb f; rewrite rmorphD (IHe1 false) (IHe2 false). +- by move=> e1 IHe1 e2 IHe2 invb f; rewrite rmorphD (IHe1 false) (IHe2 false). +- by move=> e1 IHe1 e2 IHe2 invb f; rewrite rmorphD (IHe1 false) (IHe2 false). +- by move=> e1 IHe1 e2 IHe2 invb f; rewrite rmorphD (IHe1 false) (IHe2 false). +- move=> R e1 IHe1 e2 IHe2 invb f; rewrite rmorphMn -mulr_natr invfM. + by rewrite (IHe1 true) (IHe2 true) (IHe1 false) (IHe2 false); case: invb. +- move=> R e1 IHe1 invb f. + by rewrite rmorphN invrN (IHe1 true) (IHe1 false); case: invb. +- move=> e1 IHe1 invb f. + by rewrite rmorphN invrN (IHe1 true) (IHe1 false); case: invb. +- by move=> e1 IHe1 e2 IHe2 invb f; rewrite rmorphB (IHe1 false) (IHe2 false). +- move=> R e1 IHe1 e2 IHe2 invb f; rewrite rmorphMz -mulrzr invfM. + by rewrite (IHe1 true) (IHe2 true) (IHe1 false) (IHe2 false); case: invb. +- by move=> R invb f; rewrite rmorph1 invr1 if_same. +- move=> R e1 IHe1 e2 IHe2 invb f; rewrite rmorphM invfM. + by rewrite (IHe1 true) (IHe2 true) (IHe1 false) (IHe2 false); case: invb. +- move=> e1 IHe1 e2 IHe2 invb f; rewrite rmorphM invfM. + by rewrite (IHe1 true) (IHe2 true) (IHe1 false) (IHe2 false); case: invb. +- move=> e1 IHe1 e2 IHe2 invb f; rewrite rmorphM invfM. + by rewrite (IHe1 true) (IHe2 true) (IHe1 false) (IHe2 false); case: invb. +- move=> e1 IHe1 e2 IHe2 invb f; rewrite rmorphM invfM. + by rewrite (IHe1 true) (IHe2 true) (IHe1 false) (IHe2 false); case: invb. +- move=> R e1 IHe1 n invb f; rewrite rmorphXn -exprVn (IHe1 true) (IHe1 false). + by rewrite -large_nat_N_nat; case: invb. +- move=> R e1 IHe1 n invb f; rewrite rmorphXn -exprVn (IHe1 true) (IHe1 false). + by rewrite -large_nat_N_nat; case: invb. +- move=> R e1 IHe1 n invb f; rewrite fmorphV rmorphXn invrK -exprVn. + rewrite (IHe1 true) (IHe1 false) -large_nat_N_nat. + by case: invb; congr (_ ^+ _); lia. +- move=> e1 IHe1 n invb f; rewrite rmorphXn -exprVn (IHe1 true) (IHe1 false). + by rewrite -large_nat_N_nat; case: invb. +- move=> e1 IHe1 n invb f. + have ->: (Reval e1 ^ n)%num = Reval e1 ^+ N.to_nat n by lia. + by rewrite rmorphXn -exprVn (IHe1 true) (IHe1 false); case: invb. +- move=> e1 IHe1 [|p|p] invb f; + rewrite ?(rmorph0, rmorph1, invr0, invr1, if_same) //=. + rewrite /Rnorm /= -/(Rnorm _) -IHe1 (fun_if (fun x => GRing.exp x _)). + by rewrite exprVn -rmorphXn; congr (if _ then (f _)^-1 else f _); lia. +- by move=> R e1 IHe1 invb f; rewrite fmorphV invrK -if_neg IHe1. +- move=> p e1 IHe1 invb f. + by rewrite add_pos_natE rmorphD (IHe1 false) -[Pos.to_nat p]natn rmorph_nat. +- move=> n invb f. + by rewrite -[nat_of_large_nat _]natn rmorph_nat pmulrn -large_nat_Z_int. +- move=> e1 IHe1 invb f; rewrite -[Posz _]intz rmorph_int -pmulrn. + by rewrite (IHe1 true) (IHe1 false); case: invb. +- move=> e1 IHe1 invb f. + by rewrite -[Negz _]intz rmorph_int /intmul mulrS (IHe1 false). +- move=> n invb f; rewrite /Rnorm. + have ->: int_of_Z (Z_of_N n) = nat_of_N n by lia. + rewrite -[_%:~R](rmorph_nat f). + by case: invb; [congr (_ ^-1)|]; congr (f _); lia. +- move=> n invb f; rewrite /Rnorm -(rmorph_int f). + by case: invb; [congr (_ ^-1)|]; congr (f _); lia. +- by move=> R S g e1 IHe1 invb f; rewrite -/(comp f g _) IHe1. +- move=> R g e1 IHe1 invb f; rewrite -/(comp f g _) IHe1. + by apply: eq_Rnorm => /= n; rewrite -[RHS](rmorph_nat (f \o g)) natn. +- move=> R g e1 IHe1 invb f; rewrite -/(comp f g _) IHe1. + apply: eq_Rnorm => /= n; rewrite -[RHS](rmorph_nat (f \o g)). + by congr (f (g _)); lia. +- move=> R g e1 IHe1 invb f; rewrite -/(comp f g _) IHe1. + apply: eq_Rnorm => /= n; rewrite -[RHS](rmorph_int (f \o g)). + by congr (f (g _)); lia. +- move=> R g e1 IHe1 invb f; rewrite -/(comp f g _) IHe1. + apply: eq_Rnorm => /= n; rewrite -[RHS](rmorph_int (f \o g)). + by congr (f (g _)); lia. +- by move=> V R g e1 IHe1 invb f; rewrite -/(comp f g _) IHe1. +- move=> R g e1 IHe1 invb f. + rewrite -[Reval e1]natn !raddfMn -mulr_natr ?invfM. + by rewrite (IHe1 true) (IHe1 false); case: invb. +- move=> R g e1 IHe1 invb f. + have ->: Reval e1 = (N.to_nat (Reval e1))%:R by lia. + rewrite !raddfMn -mulr_natr -/(comp _ N.to_nat _) ?invfM. + by rewrite (IHe1 true) (IHe1 false); case: invb. +- move=> R g e1 IHe1 invb f. + rewrite -[Reval e1]intz ![f _](raddfMz (f \o g)) -mulrzr ?invfM. + by rewrite (IHe1 true) (IHe1 false); case:invb. +- move=> R g e1 IHe1 invb f. + have ->: Reval e1 = (int_of_Z (Reval e1))%:~R by lia. + rewrite [f _](raddfMz (f \o g)) -mulrzr -/(comp _ int_of_Z _) ?invfM. + by rewrite (IHe1 true) (IHe1 false); case:invb. +- by move=> V invb f; rewrite raddf0 invr0 if_same. +- by move=> V e1 IHe1 e2 IHe2 invb f; rewrite raddfD (IHe1 false) (IHe2 false). +- move=> V e1 IHe1 e2 IHe2 invb f; rewrite raddfMn -mulr_natr invfM. + by rewrite (IHe1 true) (IHe2 true) (IHe1 false) (IHe2 false); case: invb. +- move=> V e1 IHe1 invb f. + by rewrite raddfN invrN (IHe1 true) (IHe1 false); case: invb. +- move=> V e1 IHe1 e2 IHe2 invb f; rewrite raddfMz -mulrzr invfM. + by rewrite (IHe1 true) (IHe2 true) (IHe1 false) (IHe2 false); case: invb. +- by move=> V V' g e1 IHe1 invb f; rewrite -/(comp f g _) IHe1. +- move=> V g e1 IHe1 invb f; rewrite -[Reval e1]natn !raddfMn -mulr_natr invfM. + by rewrite (IHe1 true) (IHe1 false); case: invb. +- move=> V g e1 IHe1 invb f. + have ->: Reval e1 = (N.to_nat (Reval e1))%:R by lia. + rewrite !raddfMn -mulr_natr invfM -/(comp _ N.to_nat _). + by rewrite (IHe1 true) (IHe1 false); case: invb. +- move=> V g e1 IHe1 invb f. + rewrite -[Reval e1]intz ![f _](raddfMz (f \o g)) -mulrzr invfM. + by rewrite (IHe1 true) (IHe1 false); case: invb. +- move=> V g e1 IHe1 invb f. + have ->: Reval e1 = (int_of_Z (Reval e1))%:~R by lia. + rewrite [f _](raddfMz (f \o g)) -mulrzr -/(comp _ int_of_Z _) invfM. + by rewrite (IHe1 true) (IHe1 false); case: invb. +Qed. + +Lemma Rnorm_correct (e : RExpr F) : Reval e = Rnorm false id e. +Proof. by rewrite -(Rnorm_correct_rec _ idfun). Qed. + +End correct. + +End Lra. + (* Embedding of rational numbers `Q` in a generic `unitRingType` *) Definition R_of_Q {R : unitRingType} (x : Q) : R := @@ -228,27 +1227,20 @@ Proof. by rewrite /R_of_Q /= mulrACA -invfM -intrM -natrM; congr (_%:~R / _%:R); lia. Qed. -Lemma R_of_Q_inv (F : numFieldType) x : R_of_Q (/ x) = (R_of_Q x)^-1 :> F. -Proof. -case: x => [[|n|n] d]; rewrite /R_of_Q ?mul0r ?invr0 //= invf_div //=. -apply/eqP; rewrite eqr_div ?pnatr_eq0 ?intr_eq0; try lia. -rewrite -intrM -natrM pmulrn; apply/eqP; congr _%:~R. -by rewrite !NegzE mulrNN !prednK; lia. (* FIXME *) -Qed. +(* Some instances required to adapt `ring`, `field`, and `lra` tactics to *) +(* MathComp *) -Lemma R_of_Q_invZ (R : unitRingType) x : - R_of_Q (/ (x # 1)) = (int_of_Z x)%:~R^-1 :> R. +Lemma RN (SR : semiRingType) : semi_morph (0 : SR) 1 +%R *%R eq + N.zero N.one N.add N.mul N.eqb (fun n => (nat_of_N n)%:R). Proof. -case: x => [|n|n]; rewrite /R_of_Q ?mul0r ?invr0 ?mul1r ?mulN1r ?invrN //=. -by congr (- _%:R^-1); lia. +split=> //= [x y | x y | x y]. +- by rewrite -natrD; congr _%:R; lia. +- by rewrite -natrM; congr _%:R; lia. +- by move=> ?; congr _%:R; lia. Qed. -(* Some instances required to adapt `ring`, `field`, and `lra` tactics to *) -(* MathComp *) - -Lemma RZ R : ring_morph 0 1 +%R *%R (fun x y : R => x - y) -%R eq - 0 1 Z.add Z.mul Z.sub Z.opp Z.eqb - (fun n => (int_of_Z n)%:~R). +Lemma RZ (R : ringType) : ring_morph 0 1 +%R *%R (fun x y : R => x - y) -%R eq + 0 1 Z.add Z.mul Z.sub Z.opp Z.eqb (fun n => (int_of_Z n)%:~R). Proof. split=> //= [x y | x y | x y | x | x y /Z.eqb_eq -> //]. - by rewrite !rmorphD. @@ -257,13 +1249,17 @@ split=> //= [x y | x y | x y | x | x y /Z.eqb_eq -> //]. - by rewrite !rmorphN. Qed. -Lemma PN R : @power_theory R 1 *%R eq N id (fun x n => x ^+ nat_of_N n). +Lemma PN (SR : semiRingType) : @power_theory SR 1 *%R eq + N id (fun x n => x ^+ nat_of_N n). Proof. split => r [] //=; elim=> //= p <-. - by rewrite Pos2Nat.inj_xI ?exprS -exprD addnn -mul2n. - by rewrite Pos2Nat.inj_xO ?exprS -exprD addnn -mul2n. Qed. +Lemma RS (SR : comSemiRingType) : @semi_ring_theory SR 0 1 +%R *%R eq. +Proof. exact/mk_srt/mulrDl/mulrA/mulrC/mul0r/mul1r/addrA/addrC/add0r. Qed. + Lemma RR (R : comRingType) : @ring_theory R 0 1 +%R *%R (fun x y => x - y) -%R eq. Proof. @@ -300,7 +1296,7 @@ apply: mk_SOR_theory. + by left. + by right; right. + by right; left. -- by move=> x y z; rewrite ler_add2l. +- by move=> x y z; rewrite lerD2l. - exact: mulr_gt0. - by apply/eqP; rewrite eq_sym oner_neq0. Qed. @@ -340,8 +1336,8 @@ Qed. Lemma R_of_Q_le x y : Qle_bool x y = (R_of_Q x <= R_of_Q y :> F). Proof. rewrite /Qle_bool /R_of_Q /=. -rewrite ler_pdivr_mulr ?ltr0n; last lia. -rewrite mulrAC ler_pdivl_mulr ?ltr0n; last lia. +rewrite ler_pdivrMr ?ltr0n; last lia. +rewrite mulrAC ler_pdivlMr ?ltr0n; last lia. rewrite !pmulrn -!intrM ler_int; lia. Qed. @@ -371,3 +1367,26 @@ apply: mk_SOR_addon. Qed. End RealField. + +Elpi Db canonicals.db lp:{{ + +pred canonical-nat-nmodule o:constant. +pred canonical-nat-semiring o:constant. +pred canonical-nat-comsemiring o:constant. +pred canonical-N-nmodule o:constant. +pred canonical-N-semiring o:constant. +pred canonical-N-comsemiring o:constant. +pred canonical-int-nmodule o:constant. +pred canonical-int-zmodule o:constant. +pred canonical-int-semiring o:constant. +pred canonical-int-ring o:constant. +pred canonical-int-comring o:constant. +pred canonical-int-unitring o:constant. +pred canonical-Z-nmodule o:constant. +pred canonical-Z-zmodule o:constant. +pred canonical-Z-semiring o:constant. +pred canonical-Z-ring o:constant. +pred canonical-Z-comring o:constant. +pred canonical-Z-unitring o:constant. + +}}. diff --git a/theories/lra.elpi b/theories/lra.elpi index 8d9419a..f89ff7e 100644 --- a/theories/lra.elpi +++ b/theories/lra.elpi @@ -1,314 +1,164 @@ -% [field-mode] is true if we are on a realFieldType, -% otherwise we are on a realDomainType. -pred field-mode. - -% [ring->field Ring Field]: [Field] is optionally a [fieldType] instance such -% that [GRing.Field.ringType Field = Ring]. -pred ring->field i:term, o:option term. -ring->field R (some F) :- - field-mode, - coq.unify-eq {{ GRing.Ring.sort lp:R }} {{ GRing.Field.sort lp:F }} ok, !. -ring->field _ none. - -% Type to contain the carrier type and the following structure instances -% attached to it: realFieldType (optional), realDomainType, -% fieldType (optional), unitRingType (optional), ringType, porderType, eqType, -% Type -kind carrier type. -type carrier option term -> term -> option term -> option term -> term -> - term -> term -> Type -> carrier. - -pred type->carrier i:term, o:carrier, o:prop. -type->carrier Ty (carrier (some RF) RD (some F) (some UR) R PO EQ Ty) - field-mode :- - std.do! [ coq.unify-eq Ty {{ Num.RealField.sort lp:RF }} ok, - coq.unify-eq Ty {{ Num.RealDomain.sort lp:RD }} ok, - coq.unify-eq Ty {{ GRing.Field.sort lp:F }} ok, - coq.unify-eq Ty {{ GRing.UnitRing.sort lp:UR }} ok, - coq.unify-eq Ty {{ GRing.Ring.sort lp:R }} ok, - coq.unify-eq Ty {{ @Order.POrder.sort _ lp:PO }} ok, - coq.unify-eq Ty {{ Equality.sort lp:EQ }} ok ]. -type->carrier Ty (carrier none RD none none R PO EQ Ty) true :- - std.do! [ coq.unify-eq Ty {{ Num.RealDomain.sort lp:RD }} ok, - coq.unify-eq Ty {{ GRing.Ring.sort lp:R }} ok, - coq.unify-eq Ty {{ @Order.POrder.sort _ lp:PO }} ok, - coq.unify-eq Ty {{ Equality.sort lp:EQ }} ok ]. - -pred carrier->realField i:carrier, o:term. -carrier->realField (carrier (some RF) _ _ _ _ _ _ _) RF :- !. - -pred carrier->realDomain i:carrier, o:term. -carrier->realDomain (carrier _ RD _ _ _ _ _ _) RD :- !. +% [target-unitring R] asserts that the target carrier type has the unit ring +% instance [R]. +pred target-unitring o:term. -pred carrier->field i:carrier, o:term. -carrier->field (carrier _ _ (some F) _ _ _ _ _) F :- !. +% Type to contain the carrier type and structure instances attached to it +kind carrier type. +type carrier + term -> % Type + term -> % eqType + term -> % porderType + term -> % nmodType + term -> % zmodType + term -> % semiRingType + term -> % ringType + term -> % unitRingType + option term -> % fieldType + term -> % realDomainType + option term -> % realFieldType + carrier. + +pred carrier->rmorphism i:carrier, o:rmorphism. +carrier->rmorphism + (carrier _ _ _ U V SR R UR F' _ _) + (rmorphism U (some V) SR (some R) (some UR) F' (x\ x)) :- !. -pred carrier->unitRing i:carrier, o:term. -carrier->unitRing (carrier _ _ _ (some UR) _ _ _ _) UR :- !. +pred carrier->type i:carrier, o:term. +carrier->type (carrier Ty _ _ _ _ _ _ _ _ _ _) Ty :- !. -pred carrier->ring i:carrier, o:term. -carrier->ring (carrier _ _ _ _ R _ _ _) R :- !. +pred carrier->eq i:carrier, o:term. +carrier->eq (carrier _ EQ _ _ _ _ _ _ _ _ _) EQ :- !. pred carrier->porder i:carrier, o:term. -carrier->porder (carrier _ _ _ _ _ PO _ _) PO :- !. - -pred carrier->eq i:carrier, o:term. -carrier->eq (carrier _ _ _ _ _ _ EQ _) EQ :- !. +carrier->porder (carrier _ _ PO _ _ _ _ _ _ _ _) PO :- !. -pred carrier->type i:carrier, o:term. -carrier->type (carrier _ _ _ _ _ _ _ Ty) Ty :- !. +pred carrier->ring i:carrier, o:term. +carrier->ring (carrier _ _ _ _ _ _ R _ _ _ _) R :- !. -pred field->unitRing o:term, o:term. -field->unitRing F R :- !, coq.unify-eq {{ GRing.Field.unitRingType lp:F }} R ok. +pred carrier->realDomain i:carrier, o:term. +carrier->realDomain (carrier _ _ _ _ _ _ _ _ _ RD _) RD :- !. -pred ring->zmod o:term, o:term. -ring->zmod R V :- !, coq.unify-eq {{ GRing.Ring.zmodType lp:R }} V ok. +pred carrier->realField i:carrier, o:term. +carrier->realField (carrier _ _ _ _ _ _ _ _ _ _ (some RF)) RF :- !. + +pred mk-carrier i:term, o:carrier, o:list prop. +mk-carrier Ty (carrier Ty EQ PO U V SR R UR F' RD RF') Env :- std.do! [ + std.assert-ok! (coq.unify-eq Ty {{ Equality.sort lp:EQ }}) + "Cannot find a declared eqType", + std.assert-ok! (coq.unify-eq Ty {{ @Order.POrder.sort _ lp:PO }}) + "Cannot find a declared porderType", + std.assert-ok! (coq.unify-eq Ty {{ GRing.Nmodule.sort lp:U }}) + "Cannot find a declared nmodType", + std.assert-ok! (coq.unify-eq Ty {{ GRing.Zmodule.sort lp:V }}) + "Cannot find a declared zmodType", + std.assert-ok! (coq.unify-eq Ty {{ GRing.SemiRing.sort lp:SR }}) + "Cannot find a declared semiRingType", + std.assert-ok! (coq.unify-eq Ty {{ GRing.Ring.sort lp:R }}) + "Cannot find a declared ringType", + std.assert-ok! (coq.unify-eq Ty {{ GRing.UnitRing.sort lp:UR }}) + "Cannot find a declared unitRingType", + std.assert-ok! (coq.unify-eq Ty {{ Num.RealDomain.sort lp:RD }}) + "Cannot find a declared realDomainType", + if (coq.unify-eq Ty {{ GRing.Field.sort lp:F }} ok, + coq.unify-eq Ty {{ Num.RealField.sort lp:RF }} ok) + (F' = some F, RF' = some RF, + Env = [field-mode, target-nmodule U, target-semiring SR, + target-zmodule V, target-unitring UR, + (pi C C' In OutM Out VM\ + quote.exprw C In OutM Out VM :- !, + carrier->rmorphism C C', quote.lra.ring ff C' In OutM Out VM)]) + (F' = none, RF' = none, + Env = [target-nmodule U, target-semiring SR, + target-zmodule V, target-unitring UR, + (pi C C' In OutM Out VM\ + quote.exprw C In OutM Out VM :- !, + carrier->rmorphism C C', quote.ring C' In OutM Out VM)]) +]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Parse goal (and hypotheses) to extract a realFieldType or realDomainType % from (in)equalities it contains % carrier type from a term of type bool -pred rfstr.bool i:term, o:carrier, o:prop. -rfstr.bool {{ lp:Ty1 ==> lp:Ty2 }} C IsField :- !, - (rfstr.bool Ty2 C IsField; rfstr.bool Ty1 C IsField). -rfstr.bool {{ ~~ lp:Ty }} C IsField :- !, rfstr.bool Ty C IsField. -rfstr.bool {{ lp:Ty1 && lp:Ty2 }} C IsField :- !, - (rfstr.bool Ty2 C IsField; rfstr.bool Ty1 C IsField). -rfstr.bool {{ lp:Ty1 || lp:Ty2 }} C IsField :- !, - (rfstr.bool Ty2 C IsField; rfstr.bool Ty1 C IsField). -rfstr.bool {{ @Order.le _ lp:Ty _ _ }} C IsField :- !, - type->carrier {{ @Order.POrder.sort _ lp:Ty }} C IsField. -rfstr.bool {{ @Order.lt _ lp:Ty _ _ }} C IsField :- !, - type->carrier {{ @Order.POrder.sort _ lp:Ty }} C IsField. +pred rfstr.bool i:term, o:carrier, o:list prop. +rfstr.bool {{ lp:Ty1 ==> lp:Ty2 }} C Env :- !, + (rfstr.bool Ty2 C Env; rfstr.bool Ty1 C Env). +rfstr.bool {{ ~~ lp:Ty }} C Env :- !, rfstr.bool Ty C Env. +rfstr.bool {{ lp:Ty1 && lp:Ty2 }} C Env :- !, + (rfstr.bool Ty2 C Env; rfstr.bool Ty1 C Env). +rfstr.bool {{ lp:Ty1 || lp:Ty2 }} C Env :- !, + (rfstr.bool Ty2 C Env; rfstr.bool Ty1 C Env). +rfstr.bool {{ @Order.le _ lp:Ty _ _ }} C Env :- !, + mk-carrier {{ @Order.POrder.sort _ lp:Ty }} C Env. +rfstr.bool {{ @Order.lt _ lp:Ty _ _ }} C Env :- !, + mk-carrier {{ @Order.POrder.sort _ lp:Ty }} C Env. % carrier type from a term of type Prop -pred rfstr.prop i:term, o:carrier, o:prop. -rfstr.prop {{ lp:Ty1 -> lp:Ty2 }} C IsField :- !, - (rfstr.prop Ty2 C IsField; rfstr.prop Ty1 C IsField). -rfstr.prop {{ iff lp:Ty1 lp:Ty2 }} C IsField :- !, - (rfstr.prop Ty2 C IsField; rfstr.prop Ty1 C IsField). -rfstr.prop {{ ~ lp:Type }} C IsField :- rfstr.prop Type C IsField. -rfstr.prop {{ lp:Ty1 /\ lp:Ty2 }} C IsField :- !, - (rfstr.prop Ty2 C IsField; rfstr.prop Ty1 C IsField). -rfstr.prop {{ lp:Ty1 \/ lp:Ty2 }} C IsField :- !, - (rfstr.prop Ty2 C IsField; rfstr.prop Ty1 C IsField). -rfstr.prop {{ is_true lp:Ty }} C IsField :- !, rfstr.bool Ty C IsField. -rfstr.prop {{ @eq lp:Bool lp:Ty1 lp:Ty2 }} C IsField :- +pred rfstr.prop i:term, o:carrier, o:list prop. +rfstr.prop {{ lp:Ty1 -> lp:Ty2 }} C Env :- !, + (rfstr.prop Ty2 C Env; rfstr.prop Ty1 C Env). +rfstr.prop {{ iff lp:Ty1 lp:Ty2 }} C Env :- !, + (rfstr.prop Ty2 C Env; rfstr.prop Ty1 C Env). +rfstr.prop {{ ~ lp:Type }} C Env :- !, rfstr.prop Type C Env. +rfstr.prop {{ lp:Ty1 /\ lp:Ty2 }} C Env :- !, + (rfstr.prop Ty2 C Env; rfstr.prop Ty1 C Env). +rfstr.prop {{ lp:Ty1 \/ lp:Ty2 }} C Env :- !, + (rfstr.prop Ty2 C Env; rfstr.prop Ty1 C Env). +rfstr.prop {{ is_true lp:Ty }} C Env :- !, rfstr.bool Ty C Env. +rfstr.prop {{ @eq lp:Bool lp:Ty1 lp:Ty2 }} C Env :- coq.unify-eq Bool {{ bool }} ok, !, - (rfstr.bool Ty2 C IsField; rfstr.bool Ty1 C IsField). -rfstr.prop {{ @eq lp:Ty _ _ }} C IsField :- !, type->carrier Ty C IsField. + (rfstr.bool Ty2 C Env; rfstr.bool Ty1 C Env). +rfstr.prop {{ @eq lp:Ty _ _ }} C Env :- !, mk-carrier Ty C Env. -pred rfstr.hyps i:list prop, o:carrier, o:prop. -rfstr.hyps [decl _ _ H|_] C IsField :- rfstr.prop H C IsField. -rfstr.hyps [_|Ctx] C IsField :- rfstr.hyps Ctx C IsField. +pred rfstr.hyps i:list prop, o:carrier, o:list prop. +rfstr.hyps [decl _ _ H|_] C Env :- rfstr.prop H C Env. +rfstr.hyps [_|Ctx] C Env :- rfstr.hyps Ctx C Env. -pred rfstr i:list prop, i:term, o:carrier, o:prop. -rfstr _ Type C IsField :- rfstr.prop Type C IsField, !. -rfstr Ctx _ C IsField :- rfstr.hyps {std.rev Ctx} C IsField, !. -rfstr _ _ _ _ :- coq.ltac.fail _ "Cannot find a realDomainType". +pred rfstr i:list prop, i:term, o:carrier, o:list prop. +rfstr _ Type C Env :- rfstr.prop Type C Env, !. +rfstr Ctx _ C Env :- rfstr.hyps {std.rev Ctx} C Env, !. +rfstr _ _ _ _ :- coq.ltac.fail 0 "Cannot find a realDomainType". %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Reification procedure -% [coqZ] represents Coq terms of type [Z]. Since we often have to take their -% multiplicative inverse (of type [Q]), we expose the head constructor in the -% Elpi level. -kind coqZ type. -type coqZ0 coqZ. -type coqZpos term -> coqZ. -type coqZneg term -> coqZ. - -pred coqZ->N o:coqZ, o:term. -coqZ->N coqZ0 {{ N0 }} :- !. -coqZ->N (coqZpos P) {{ Npos lp:P }} :- !. - -pred coqZ->Z o:coqZ, o:term. -coqZ->Z coqZ0 {{ Z0 }} :- !. -coqZ->Z (coqZpos P) {{ Zpos lp:P }} :- !. -coqZ->Z (coqZneg P) {{ Zneg lp:P }} :- !. - -pred coqZ->Q i:bool, i:coqZ, o:term. -coqZ->Q _ coqZ0 {{ Qmake 0 1 }} :- !. -coqZ->Q ff (coqZpos P) {{ Qmake (Zpos lp:P) 1 }} :- !. -coqZ->Q ff (coqZneg P) {{ Qmake (Zneg lp:P) 1 }} :- !. -coqZ->Q tt (coqZpos P) {{ Qmake 1 lp:P }} :- !. -coqZ->Q tt (coqZneg P) {{ Qmake (-1) lp:P }} :- !. - -% [quote.nat In OutM Out] reifies natural number constant [In] of type [nat] to -% a term [OutM] of type [large_nat] and [Out] of type [coqZ]. -pred quote.nat i:term, o:term, o:coqZ. -quote.nat {{ lp:In : _ }} OutM Out :- !, quote.nat In OutM Out. -quote.nat {{ Nat.of_num_uint lp:X }} {{ large_nat_uint lp:X }} Out :- - ground-uint X, !, - coq.reduction.vm.norm {{ N.of_num_uint lp:X }} {{ N }} XN, !, - coqZ->N Out XN. -quote.nat X {{ large_nat_N lp:XN }} Out :- - reduction-N {{ N.of_nat lp:X }} XN, !, coqZ->N Out XN. - -% [quote.int In OutM Out] reifies integer constant [In] of type [int] to a term -% [OutM] of type [large_int] and [Out] of type [coqZ]. -pred quote.int i:term, o:term, o:coqZ. -quote.int {{ lp:In : _ }} OutM Out :- !, quote.int In OutM Out. -quote.int {{ Posz (Nat.of_num_uint lp:X) }} {{ large_int_Pos lp:X }} Out :- - ground-uint X, !, - coq.reduction.vm.norm {{ N.of_num_uint lp:X }} {{ N }} XN, !, coqZ->N Out XN. -quote.int {{ Posz lp:N }} {{ large_int_Z lp:NZ }} Out :- - reduction-Z {{ Z.of_nat lp:N }} NZ, !, coqZ->Z Out NZ. -quote.int {{ Negz (Nat.of_num_uint lp:X) }} {{ large_int_Neg lp:X }} - (coqZneg P) :- - ground-uint X, !, - coq.reduction.vm.norm {{ N.succ_pos (N.of_num_uint lp:X) }} {{ positive }} P. -quote.int {{ Negz lp:N }} {{ large_int_Z (Zneg lp:P) }} (coqZneg P) :- - reduction-pos {{ N.succ_pos (N.of_nat lp:N) }} P, !. - -% [quote.expr Inv R F TR TUR Morph In OutM Out VM] reifies arithmetic -% expressions -% - [Inv] is a Boolean flag indicating that [Out] should represent the -% multiplicative inverse of [In], -% - [R] is a [ringType] instance, -% - [F] is optionally a [fieldType] instance such that -% [GRing.Field.ringType F = R], -% - [TR] is a [ringType] instance, -% - [TUR] is optionally a [unitRingType] instance such that -% [GRing.UnitRing.ringType TUR = TR], -% - [Morph] is a function from [R] to [TR], -% - [In] is a term of type [R], -% - [OutM] is a reified expression of type [RExpr R], -% - [Out] is a reified expression of type [PExpr Q], and -% - [VM] is a variable map, that is a list of terms of type [R]. -pred quote.expr i:bool, i:term, i:option term, i:term, i:option term, - i:(term -> term), i:term, o:term, o:term, o:list term. -% _ : _ -quote.expr ff R F TR TUR Morph {{ lp:In : _ }} OutM Out VM :- !, - quote.expr ff R F TR TUR Morph In OutM Out VM. -% 0%R -quote.expr _ R _ _ _ _ {{ @GRing.zero lp:U }} - {{ @R0 lp:R }} {{ PEc (Qmake 0 1) }} _ :- - ring->zmod R U, !. -% -%R -quote.expr Inv R F TR TUR Morph {{ @GRing.opp lp:U lp:In }} - {{ @ROpp lp:R lp:OutM }} {{ PEopp lp:Out }} VM :- - ring->zmod R U, !, - quote.expr Inv R F TR TUR Morph In OutM Out VM. -% +%R -quote.expr ff R F TR TUR Morph {{ @GRing.add lp:U lp:In1 lp:In2 }} - {{ @RAdd lp:R lp:OutM1 lp:OutM2 }} {{ PEadd lp:Out1 lp:Out2 }} VM :- - ring->zmod R U, !, - quote.expr ff R F TR TUR Morph In1 OutM1 Out1 VM, !, - quote.expr ff R F TR TUR Morph In2 OutM2 Out2 VM. -% (_ *+ _)%R -quote.expr Inv R F TR TUR Morph {{ @GRing.natmul lp:U lp:In1 lp:In2 }} - {{ @RMuln lp:R lp:OutM1 lp:OutM2 }} - {{ PEmul lp:Out1 (PEc lp:Out2') }} VM :- - ring->zmod R U, quote.nat In2 OutM2 Out2, !, - quote.expr Inv R F TR TUR Morph In1 OutM1 Out1 VM, !, - coqZ->Q Inv Out2 Out2'. -% (_ *~ _)%R -quote.expr Inv R F TR TUR Morph {{ @intmul lp:U lp:In1 lp:In2 }} - {{ @RMulz lp:R lp:OutM1 lp:OutM2 }} {{ PEmul lp:Out1 lp:Out2 }} VM :- - ring->zmod R U, !, - quote.expr Inv R F TR TUR Morph In1 OutM1 Out1 VM, !, - quote.expr Inv {{ int_Ring }} none TR TUR - (n\ {{ @intmul (GRing.Ring.zmodType lp:TR) (@GRing.one lp:TR) lp:n }}) - In2 OutM2 Out2 VM. -% 1%R -quote.expr _ R _ _ _ _ {{ @GRing.one lp:R' }} - {{ @R1 lp:R }} {{ PEc (Qmake 1 1) }} _ :- - coq.unify-eq R R' ok, !. -% *%R -quote.expr Inv R F TR TUR Morph {{ @GRing.mul lp:R' lp:In1 lp:In2 }} - {{ @RMul lp:R lp:OutM1 lp:OutM2 }} {{ PEmul lp:Out1 lp:Out2 }} VM :- - coq.unify-eq R R' ok, !, - quote.expr Inv R F TR TUR Morph In1 OutM1 Out1 VM, !, - quote.expr Inv R F TR TUR Morph In2 OutM2 Out2 VM. -% (_ ^+ _)%R -quote.expr Inv R F TR TUR Morph {{ @GRing.exp lp:R' lp:In1 lp:In2 }} - {{ @RExpn lp:R lp:OutM1 lp:OutM2 }} - {{ PEpow lp:Out1 lp:Out2' }} VM :- - coq.unify-eq R R' ok, quote.nat In2 OutM2 Out2, !, - quote.expr Inv R F TR TUR Morph In1 OutM1 Out1 VM, !, - coqZ->N Out2 Out2'. -% _^-1 -quote.expr Inv R (some F) TR TUR Morph {{ @GRing.inv lp:R' lp:In }} - {{ @RInv lp:F lp:OutM }} Out VM :- - field-mode, - field->unitRing F R', !, - quote.expr { negb Inv } R (some F) TR TUR Morph In OutM Out VM. -% morphisms -quote.expr Inv R _ TR TUR Morph In - {{ @RMorph lp:R' lp:R lp:NewMorphInst lp:OutM }} Out VM :- - NewMorph = (x\ {{ @GRing.RMorphism.apply - lp:R' lp:R _ lp:NewMorphInst lp:x }}), - coq.unify-eq In (NewMorph In1) ok, !, - quote.expr Inv R' { ring->field R' } TR TUR (x\ Morph (NewMorph x)) In1 - OutM Out VM. -% int constants -quote.expr Inv _ _ _ _ _ In {{ RintC lp:OutM }} {{ PEc lp:Out' }} _ :- - quote.int In OutM Out, !, - coqZ->Q Inv Out Out'. -% Z constants -quote.expr _ _ _ _ _ _ {{ Z0 }} {{ RZC Z0 }} {{ PEc (Qmake 0 1) }} _ :- !. -quote.expr Inv _ _ _ _ _ {{ Zpos lp:P }} {{ RZC (Zpos lp:P') }} - {{ PEc lp:Out }} _ :- !, - reduction-pos P P', coqZ->Q Inv (coqZpos P') Out. -quote.expr Inv _ _ _ _ _ {{ Zneg lp:P }} {{ RZC (Zneg lp:P') }} - {{ PEc lp:Out }} _ :- !, - reduction-pos P P', coqZ->Q Inv (coqZneg P') Out. -% variables -quote.expr ff R _ _ _ Morph In {{ @RX lp:R lp:In }} {{ PEX lp:P }} VM :- !, - mem VM (Morph In) N, !, positive-constant { calc (N + 1) } P. -quote.expr tt R _ _ (some TUR) Morph In {{ @RX lp:R lp:In }} {{ PEX lp:P }} VM :- - !, - mem VM {{ @GRing.inv lp:TUR lp:{{ Morph In }} }} N, !, - positive-constant { calc (N + 1) } P. -quote.expr _ _ _ _ _ _ In _ _ _ :- coq.error "Unknown" {coq.term->string In}. +namespace quote { -% [quote.exprw C In OutM Out VM] reifies arithmetic expressions -% - [C] is the carrier type and structure instances, -% - [In] is a term of type [C], -% - [OutM] is a reified expression of type [RExpr C], -% - [Out] is a reified expression of type [PExpr Q], and -pred quote.exprw i:carrier, i:term, o:term, o:term, o:list term. -quote.exprw (carrier _ _ F TR R _ _ _) In OutM Out VM :- - quote.expr ff R F R TR (x\ x) In OutM Out VM. +% Constructors for reified terms -% [quote.bop2 C In OutM Out VM] reifies boolean (in)equalities -% - [C] is the carrier type and structure instances, -% - [In] is a term of type [bool], -% - [OutM] is a reified expression of type [RFormula C], -% - [Out] is a reified expression of type [Formula Q], and -% - [VM] is a variable map, that is a list of terms of type [C]. -pred quote.bop2 i:carrier, i:term, o:term, o:term, o:list term. -quote.bop2 C {{ @Order.le _ lp:O lp:X lp:Y }} - {{ Build_RFormula lp:XM' OpLe lp:YM' }} - {{ Build_Formula lp:X' OpLe lp:Y' }} VM :- - coq.unify-eq { carrier->porder C } O ok, !, - quote.exprw C X XM' X' VM, !, quote.exprw C Y YM' Y' VM. -quote.bop2 C {{ @Order.lt _ lp:O lp:X lp:Y }} - {{ Build_RFormula lp:XM' OpLt lp:YM' }} - {{ Build_Formula lp:X' OpLt lp:Y' }} VM :- - coq.unify-eq { carrier->porder C } O ok, !, - quote.exprw C X XM' X' VM, !, quote.exprw C Y YM' Y' VM. -quote.bop2 C {{ @eq_op lp:T lp:X lp:Y }} - {{ Build_RFormula lp:XM' OpEq lp:YM' }} - {{ Build_Formula lp:X' OpEq lp:Y' }} VM :- - coq.unify-eq { carrier->eq C } T ok, !, - quote.exprw C X XM' X' VM, !, quote.exprw C Y YM' Y' VM. +build.variable In {{ @PEX Q lp:In }} :- !. -% [quote.pop2 C In OutM Out VM] reifies (in)equalities of type Prop -% - [C] is the carrier type and structure instances, -% - [In] is a term of type [Prop], -% - [OutM] is a reified expression of type [RFormula C], -% - [Out] is a reified expression of type [Formula Q], and -% - [VM] is a variable map, that is a list of terms of type [C]. -pred quote.pop2 i:carrier, i:term, o:term, o:term, o:list term. -quote.pop2 C {{ is_true lp:E }} OutM Out VM :- quote.bop2 C E OutM Out VM. -quote.pop2 C {{ @eq lp:T lp:X lp:Y }} - {{ Build_RFormula lp:XM' OpEq lp:YM' }} - {{ Build_Formula lp:X' OpEq lp:Y' }} VM :- - coq.unify-eq {carrier->type C} T ok, !, - quote.exprw C X XM' X' VM, !, quote.exprw C Y YM' Y' VM. +build.zero {{ @PEc Q (Qmake Z0 1) }} :- !. + +build.opp In {{ @PEopp Q lp:In }} :- !. + +build.add In1 In2 {{ @PEadd Q lp:In1 lp:In2 }} :- !. + +build.sub In1 In2 {{ @PEsub Q lp:In1 lp:In2 }} :- !. + +build.one {{ @PEc Q (Qmake (Zpos xH) 1) }} :- !. + +build.mul In1 In2 {{ @PEmul Q lp:In1 lp:In2 }} :- !. + +build.exp In1 In2 {{ @PEpow Q lp:In1 lp:In2 }} :- !. + +build.Z-constant In {{ @PEc Q (Qmake lp:In 1) }} :- !. + +build.N-constant {{ N0 }} {{ @PEc Q (Qmake 0 1) }} :- !. +build.N-constant {{ Npos lp:In }} {{ @PEc Q (Qmake (Zpos lp:In) 1) }} :- !. + +pred build.invZ-constant i:bool, i:term, o:term. +build.invZ-constant ff In {{ @PEc Q (Qmake lp:In 1) }} :- !. +build.invZ-constant tt {{ Z0 }} {{ @PEc Q (Qmake 0 1) }} :- !. +build.invZ-constant tt {{ Zpos lp:In }} {{ @PEc Q (Qmake 1 lp:In) }} :- !. +build.invZ-constant tt {{ Zneg lp:In }} {{ @PEc Q (Qmake (-1) lp:In) }} :- !. + +pred build.invN-constant i:bool, i:term, o:term. +build.invN-constant _ {{ N0 }} {{ @PEc Q (Qmake Z0 1) }} :- !. +build.invN-constant ff {{ Npos lp:In }} {{ @PEc Q (Qmake (Zpos lp:In) 1) }} :- + ground-pos In, !. +build.invN-constant tt {{ Npos lp:In }} {{ @PEc Q (Qmake 1 lp:In) }} :- + ground-pos In, !. % GFormula constructors pred build.implb i:term, i:term, o:term. @@ -337,7 +187,7 @@ build.implp In1 In2 {{ IMPL lp:In1 None lp:In2 }} :- !. pred build.iffp i:term, i:term, o:term. build.iffp {{ X _ lp:In1 }} {{ X _ lp:In2 }} - {{ X isProp (iff lp:In1 lp:In2) }} :- !. + {{ X isProp (iff lp:In1 lp:In2) }} :- !. build.iffp In1 In2 {{ IFF lp:In1 lp:In2 }} :- !. pred build.andp i:term, i:term, o:term. @@ -354,63 +204,506 @@ pred build.negp i:term, o:term. build.negp {{ X _ lp:In1 }} {{ X isProp (~ lp:In1) }} :- !. build.negp In {{ NOT lp:In }} :- !. -% [quote.bool C In OutM Out VM] reifies boolean formulas +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +namespace lra { + +pred cond-inv i:bool, i:term, o:term. +cond-inv ff In In :- !. +cond-inv tt In {{ @GRing.inv lp:TUR lp:In }} :- !, target-unitring TUR. + +% [quote.lra.nmod Inv C Input OutM Out VM] reifies an expression [Input] +% under the additive morphism [C] +% - [Inv] if [tt] then [Out] encodes the multiplicative inverse of [Input], +% - [C] stores instances on the carrier type and the additive function from it, +% - [Input] is a term of the carrier type, +% - [OutM] is a reified terms of [Input] of type [RExpr C], +% it is such that [Meval OutM] is exactly [Input], +% - [Out] is a reified term of [Input] built by build.*, +% it has morphisms pushed inward such that the eval of [Out] +% is [Lra.Mnorm OutM] +% - [VM] is a variable map. +pred nmod i:bool, i:additive, i:term, o:term, o:term, o:list term. +% _ : _ +nmod Inv C {{ lp:In : _ }} OutM Out VM :- !, + nmod Inv C In OutM Out VM. +% 0%R +nmod _ (additive U _ _) {{ @GRing.zero lp:U' }} {{ @M0 lp:U }} Out _ :- + coq.unify-eq U U' ok, !, + build.zero Out. +% +%R +nmod ff (additive U _ _ as C) {{ @GRing.add lp:U' lp:In1 lp:In2 }} + {{ @MAdd lp:U lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq U U' ok, !, + nmod ff C In1 OutM1 Out1 VM, !, + nmod ff C In2 OutM2 Out2 VM, !, + build.add Out1 Out2 Out. +% (_ *+ _)%R +nmod Inv (additive U _ _ as C) {{ @GRing.natmul lp:U' lp:In1 lp:In2 }} + {{ @MMuln lp:U lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq U U' ok, !, + nmod Inv C In1 OutM1 Out1 VM, !, + ring Inv rmorphism-nat In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% -%R +nmod Inv (additive _ (some U) _ as C) {{ @GRing.opp lp:U' lp:In1 }} + {{ @MOpp lp:U lp:OutM1 }} Out VM :- + coq.unify-eq U U' ok, !, + nmod Inv C In1 OutM1 Out1 VM, !, + build.opp Out1 Out. +% (_ *~ _)%R +nmod Inv (additive _ (some U) _ as C) {{ @intmul lp:U' lp:In1 lp:In2 }} + {{ @MMulz lp:U lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq U U' ok, !, + nmod Inv C In1 OutM1 Out1 VM, !, + ring Inv rmorphism-int In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% additive functions +nmod Inv (additive U _ _ as C) In OutM Out VM :- + % TODO: for concrete additive functions, should we unpack [NewMorphInst]? + NewMorph = (x\ {{ @GRing.Additive.sort lp:V lp:U lp:NewMorphInst lp:x }}), + coq.unify-eq In (NewMorph In1) ok, !, + nmod.additive Inv V C NewMorph NewMorphInst In1 OutM Out VM. +% variables +nmod Inv (additive U _ Morph) In {{ @MX lp:U lp:In }} Out VM :- + mem VM { cond-inv Inv (Morph In) } N, !, + build.variable { positive-constant {calc (N + 1)} } Out. +nmod _ _ In _ _ _ :- coq.error "Unknown" {coq.term->string In}. + +pred nmod.additive i:bool, i:term, i:additive, i:term -> term, i:term, i:term, + o:term, o:term, o:list term. +nmod.additive Inv V (additive U _ Morph) NewMorph NewMorphInst In1 + {{ @MnatAdditive lp:U lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-nat-nmodule })) ok, + mem VM { cond-inv Inv (Morph (NewMorph {{ 1%N }})) } N, !, + ring Inv rmorphism-nat In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +nmod.additive Inv V (additive U _ Morph) NewMorph NewMorphInst In1 + {{ @MNAdditive lp:U lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-N-nmodule })) ok, + mem VM { cond-inv Inv (Morph (NewMorph {{ 1%num }})) } N, !, + ring Inv rmorphism-N In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +nmod.additive Inv V (additive U _ Morph) NewMorph NewMorphInst In1 + {{ @MintAdditive lp:U lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-int-nmodule })) ok, + mem VM { cond-inv Inv (Morph (NewMorph {{ 1%Z }})) } N, !, + ring Inv rmorphism-int In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +nmod.additive Inv V (additive U _ Morph) NewMorph NewMorphInst In1 + {{ @MZAdditive lp:U lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-Z-nmodule })) ok, + mem VM { cond-inv Inv (Morph (NewMorph {{ Zpos 1 }})) } N, !, + ring Inv rmorphism-Z In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +nmod.additive Inv V (additive U _ Morph) NewMorph NewMorphInst In1 + {{ @MAdditive lp:V lp:U lp:NewMorphInst lp:OutM1 }} Out1 VM :- !, + if (coq.unify-eq {{ GRing.Nmodule.sort lp:V }} + {{ GRing.Zmodule.sort lp:V' }} ok) + (V'' = some V') (V'' = none), !, + nmod Inv (additive V V'' (x\ Morph (NewMorph x))) In1 OutM1 Out1 VM. + +% [quote.lra.ring Inv C Input OutM Out VM] reifies an expression [Input] +% under the ring morphism [C] +% - [Inv] if [tt] then [Out] encodes the multiplicative inverse of [Input], +% - [C] stores instances on the carrier type and the (semi)ring homomorphism +% from it, +% - [Input] is a term of the carrier type, +% - [OutM] is a reified terms of [Input] of type [RExpr C], +% it is such that [Reval OutM] is exactly [Input], +% - [Out] is a reified term of [Input] built by build.*, +% it has morphisms pushed inward such that the eval of [Out] +% is [Lra.Rnorm OutM] +% - [VM] is a variable map. +pred ring i:bool, i:rmorphism, i:term, o:term, o:term, o:list term. +% _ : _ +ring Inv C {{ lp:In : _ }} OutM Out VM :- !, + ring Inv C In OutM Out VM. +% 0%R +ring _ C {{ @GRing.zero lp:U }} {{ @R0 lp:R }} Out _ :- + coq.unify-eq { rmorphism->nmod C } U ok, + rmorphism->sring C R, !, + build.zero Out. +% +%R +ring ff C {{ @GRing.add lp:U lp:In1 lp:In2 }} + {{ @RAdd lp:R lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq { rmorphism->nmod C } U ok, + rmorphism->sring C R, !, + ring ff C In1 OutM1 Out1 VM, !, + ring ff C In2 OutM2 Out2 VM, !, + build.add Out1 Out2 Out. +% addn +ring ff rmorphism-nat {{ addn lp:In1 lp:In2 }} + {{ @RnatAdd lp:OutM1 lp:OutM2 }} Out VM :- !, + ring ff rmorphism-nat In1 OutM1 Out1 VM, !, + ring ff rmorphism-nat In2 OutM2 Out2 VM, !, + build.add Out1 Out2 Out. +% N.add +ring ff rmorphism-N {{ N.add lp:In1 lp:In2 }} + {{ @RNAdd lp:OutM1 lp:OutM2 }} Out VM :- !, + ring ff rmorphism-N In1 OutM1 Out1 VM, !, + ring ff rmorphism-N In2 OutM2 Out2 VM, !, + build.add Out1 Out2 Out. +% Z.add +ring ff rmorphism-Z {{ Z.add lp:In1 lp:In2 }} + {{ @RZAdd lp:OutM1 lp:OutM2 }} Out VM :- !, + ring ff rmorphism-Z In1 OutM1 Out1 VM, !, + ring ff rmorphism-Z In2 OutM2 Out2 VM, !, + build.add Out1 Out2 Out. +% (_ *+ _)%R +ring Inv C {{ @GRing.natmul lp:U lp:In1 lp:In2 }} + {{ @RMuln lp:R lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq { rmorphism->nmod C } U ok, + rmorphism->sring C R, !, + ring Inv C In1 OutM1 Out1 VM, !, + ring Inv rmorphism-nat In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% -%R +ring Inv C {{ @GRing.opp lp:U lp:In1 }} {{ @ROpp lp:R lp:OutM1 }} Out VM :- + coq.unify-eq { rmorphism->zmod C } U ok, + rmorphism->ring C R, !, + ring Inv C In1 OutM1 Out1 VM, !, + build.opp Out1 Out. +% Z.opp +ring Inv rmorphism-Z {{ Z.opp lp:In1 }} {{ @RZOpp lp:OutM1 }} Out VM :- !, + ring Inv rmorphism-Z In1 OutM1 Out1 VM, !, + build.opp Out1 Out. +% Z.sub +ring ff rmorphism-Z {{ Z.sub lp:In1 lp:In2 }} + {{ @RZSub lp:OutM1 lp:OutM2 }} Out VM :- !, + ring ff rmorphism-Z In1 OutM1 Out1 VM, !, + ring ff rmorphism-Z In2 OutM2 Out2 VM, !, + build.sub Out1 Out2 Out. +% (_ *~ _)%R +ring Inv C {{ @intmul lp:U lp:In1 lp:In2 }} + {{ @RMulz lp:R lp:OutM1 lp:OutM2 }} Out VM :- + coq.unify-eq { rmorphism->zmod C } U ok, + rmorphism->ring C R, !, + ring Inv C In1 OutM1 Out1 VM, !, + ring Inv rmorphism-int In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% 1%R +ring _ C {{ @GRing.one lp:R' }} {{ @R1 lp:R }} Out _ :- + rmorphism->sring C R, + coq.unify-eq R R' ok, !, + build.one Out. +% *%R +ring Inv C {{ @GRing.mul lp:R' lp:In1 lp:In2 }} + {{ @RMul lp:R lp:OutM1 lp:OutM2 }} Out VM :- + rmorphism->sring C R, + coq.unify-eq R R' ok, !, + ring Inv C In1 OutM1 Out1 VM, !, + ring Inv C In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% muln +ring Inv rmorphism-nat {{ muln lp:In1 lp:In2 }} + {{ @RnatMul lp:OutM1 lp:OutM2 }} Out VM :- !, + ring Inv rmorphism-nat In1 OutM1 Out1 VM, !, + ring Inv rmorphism-nat In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% N.mul +ring Inv rmorphism-N {{ N.mul lp:In1 lp:In2 }} + {{ @RNMul lp:OutM1 lp:OutM2 }} Out VM :- !, + ring Inv rmorphism-N In1 OutM1 Out1 VM, !, + ring Inv rmorphism-N In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% Z.mul +ring Inv rmorphism-Z {{ Z.mul lp:In1 lp:In2 }} + {{ @RZMul lp:OutM1 lp:OutM2 }} Out VM :- !, + ring Inv rmorphism-Z In1 OutM1 Out1 VM, !, + ring Inv rmorphism-Z In2 OutM2 Out2 VM, !, + build.mul Out1 Out2 Out. +% (_ ^+ _)%R +ring Inv C {{ @GRing.exp lp:R' lp:In1 lp:In2 }} + {{ @RExpn lp:R lp:OutM1 lp:OutM2 }} Out VM :- + rmorphism->sring C R, + coq.unify-eq R R' ok, + quote.n-const In2 OutM2 Out2, !, + ring Inv C In1 OutM1 Out1 VM, !, + build.exp Out1 Out2 Out. +% (_ ^ _)%R +ring Inv C {{ @exprz lp:R' lp:In1 lp:In2 }} OutM Out VM :- + quote.z-const In2 Pos OutM2 Out2, + rmorphism->uring C R, + coq.unify-eq R R' ok, + if (Pos = tt) + (CONT = + (!, ring Inv C In1 OutM1 Out1 VM, !, + OutM = {{ @RExpPosz lp:R lp:OutM1 lp:OutM2 }}, !, + build.exp Out1 Out2 Out)) + (CONT = + (rmorphism->field C F, !, + ring { negb Inv } C In1 OutM1 Out1 VM, !, + OutM = {{ @RExpNegz lp:F lp:OutM1 lp:OutM2 }}, !, + build.exp Out1 Out2 Out)), + CONT. +% expn +ring Inv rmorphism-nat {{ expn lp:In1 lp:In2 }} + {{ @RnatExpn lp:OutM1 lp:OutM2 }} Out VM :- + quote.n-const In2 OutM2 Out2, !, + ring Inv rmorphism-nat In1 OutM1 Out1 VM, !, + build.exp Out1 Out2 Out. +% N.pow +ring Inv rmorphism-N {{ N.pow lp:In1 lp:In2 }} + {{ @RNExp lp:OutM1 lp:Out2 }} Out VM :- + reduction-N In2 Out2, !, + ring Inv rmorphism-N In1 OutM1 Out1 VM, !, + build.exp Out1 Out2 Out. +% Z.pow +ring Inv rmorphism-Z {{ Z.pow lp:In1 lp:In2 }} + {{ @RZExp lp:OutM1 lp:OutM2 }} Out VM :- + reduction-Z In2 OutM2, !, + ((OutM2 = {{ Z0 }}, !, Out2 = {{ N0 }}; % If [In2] is non-negative + OutM2 = {{ Zpos lp:P }}, !, Out2 = {{ Npos lp:P }}), !, + ring Inv rmorphism-Z In1 OutM1 Out1 VM, !, + build.exp Out1 Out2 Out; + build.zero Out). % If [In2] is negative +% _^-1 +ring Inv C {{ @GRing.inv lp:R lp:In1 }} {{ @RInv lp:F lp:OutM1 }} Out1 VM :- + rmorphism->field C F, + coq.unify-eq { rmorphism->uring C } R ok, !, + ring { negb Inv } C In1 OutM1 Out1 VM. +% S (..(S ..)..) and nat constants +ring Inv rmorphism-nat {{ lib:num.nat.S lp:In }} OutM Out VM :- !, + quote.count-succ In N In2, + if (In2 = {{ lib:num.nat.O }}) + (Cont = (OutM = {{ RnatC (large_nat_N lp:Out1) }}, !, + build.invN-constant Inv Out1 Out)) + (Inv = ff, + Cont = (ring ff rmorphism-nat In2 OutM2 Out2 VM, !, + OutM = {{ RnatS lp:Pos lp:OutM2 }}, !, + build.add { build.invN-constant ff Out1 } Out2 Out)), !, + positive-constant {calc (N + 1)} Pos, !, + Out1 = {{ N.pos lp:Pos }}, !, + Cont. +ring Inv rmorphism-nat {{ lib:num.nat.O }} {{ RnatC (large_nat_N N0) }} Out _ :- + !, build.invN-constant Inv {{ N0 }} Out. +ring Inv rmorphism-nat {{ Nat.of_num_uint lp:In }} + {{ RnatC (large_nat_uint lp:In) }} Out _ :- !, + ground-uint In, !, + coq.reduction.vm.norm {{ N.of_num_uint lp:In }} {{ N }} InN, !, + build.invN-constant Inv InN Out. +% Posz +ring Inv rmorphism-int {{ Posz lp:In }} {{ @RPosz lp:OutM }} Out VM :- !, + ring Inv rmorphism-nat In OutM Out VM. +% Negz +ring ff rmorphism-int {{ Negz lp:In }} {{ RNegz lp:OutM1 }} Out VM :- !, + ring ff rmorphism-nat In OutM1 Out1 VM, !, + build.opp { build.add { build.one } Out1 } Out. +% N constants +ring Inv rmorphism-N In {{ @RNC lp:In }} Out _ :- + ground-N In, !, build.invN-constant Inv In Out. +% Z constants +ring Inv rmorphism-Z In {{ @RZC lp:In }} Out _ :- + ground-Z In, !, build.invZ-constant Inv In Out. +% morphisms +ring Inv C In OutM Out VM :- + rmorphism->sring C R, + % TODO: for concrete additive functions, should we unpack [NewMorphInst]? + NewMorph = (x\ {{ @GRing.RMorphism.sort lp:S lp:R lp:NewMorphInst lp:x }}), + coq.unify-eq In (NewMorph In1) ok, !, + ring.rmorphism Inv S C NewMorph NewMorphInst In1 OutM Out VM. +% additive functions +ring Inv C In OutM Out VM :- + rmorphism->nmod C U, + % TODO: for concrete additive functions, should we unpack [NewMorphInst]? + NewMorph = (x\ {{ @GRing.Additive.sort lp:V lp:U lp:NewMorphInst lp:x }}), + coq.unify-eq In (NewMorph In1) ok, !, + ring.additive Inv V C NewMorph NewMorphInst In1 OutM Out VM. +% variables +ring Inv C In {{ @RX lp:R lp:In }} Out VM :- !, + rmorphism->sring C R, rmorphism->morph C Morph, + mem VM { cond-inv Inv (Morph In) } N, !, + build.variable { positive-constant {calc (N + 1)} } Out. +ring _ _ In _ _ _ :- coq.error "Unknown" {coq.term->string In}. +% TODO: converse ring + +pred ring.rmorphism.aux i:term, i:term -> term, o:rmorphism. +ring.rmorphism.aux SR Morph (rmorphism U V' SR R' UR' F' Morph) :- !, + Sort = {{ GRing.SemiRing.sort lp:SR }}, + coq.unify-eq Sort {{ GRing.Nmodule.sort lp:U }} ok, + if (target-zmodule _, coq.unify-eq Sort {{ GRing.Ring.sort lp:R }} ok, + coq.unify-eq Sort {{ GRing.Zmodule.sort lp:V }} ok) + (V' = some V, R' = some R, + if (coq.unify-eq Sort {{ GRing.UnitRing.sort lp:UR }} ok) + (UR' = some UR, + if (field-mode, coq.unify-eq Sort {{ GRing.Field.sort lp:F }} ok) + (F' = some F) (F' = none)) + (UR' = none, F' = none)) + (V' = none, R' = none, UR' = none, F' = none). + +pred ring.rmorphism i:bool, i:term, i:rmorphism, i:term -> term, i:term, i:term, + o:term, o:term, o:list term. +ring.rmorphism Inv S C _ NewMorphInst In1 + {{ @RnatMorph lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- + coq.unify-eq S (global (const { canonical-nat-semiring })) ok, !, + rmorphism->sring C R, !, + ring Inv rmorphism-nat In1 OutM1 Out1 VM. +ring.rmorphism Inv S C _ NewMorphInst In1 + {{ @RNMorph lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- + coq.unify-eq S (global (const { canonical-N-semiring })) ok, !, + rmorphism->sring C R, !, + ring Inv rmorphism-N In1 OutM1 Out1 VM. +ring.rmorphism Inv S C _ NewMorphInst In1 + {{ @RintMorph lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- + coq.unify-eq S (global (const { canonical-int-semiring })) ok, !, + rmorphism->sring C R, !, + ring Inv rmorphism-int In1 OutM1 Out1 VM. +ring.rmorphism Inv S C _ NewMorphInst In1 + {{ @RZMorph lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- + coq.unify-eq S (global (const { canonical-Z-semiring })) ok, !, + rmorphism->sring C R, !, + ring Inv rmorphism-Z In1 OutM1 Out1 VM. +ring.rmorphism Inv S C NewMorph NewMorphInst In1 + {{ @RMorph lp:S lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- !, + rmorphism->sring C R, !, + rmorphism->morph C Morph, !, + ring.rmorphism.aux S (x\ Morph (NewMorph x)) C', !, + ring Inv C' In1 OutM1 Out1 VM. + +pred ring.additive i:bool, i:term, i:rmorphism, i:term -> term, i:term, i:term, + o:term, o:term, o:list term. +ring.additive Inv V C NewMorph NewMorphInst In1 + {{ @RnatAdditive lp:R lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-nat-nmodule })) ok, + rmorphism->sring C R, rmorphism->morph C Morph, + mem VM { cond-inv Inv (Morph (NewMorph {{ 1%N }})) } N, !, + ring Inv rmorphism-nat In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +ring.additive Inv V C NewMorph NewMorphInst In1 + {{ @RNAdditive lp:R lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-N-nmodule })) ok, + rmorphism->sring C R, rmorphism->morph C Morph, + mem VM { cond-inv Inv (Morph (NewMorph {{ 1%num }})) } N, !, + ring Inv rmorphism-N In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +ring.additive Inv V C NewMorph NewMorphInst In1 + {{ @RintAdditive lp:R lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-int-nmodule })) ok, + rmorphism->sring C R, rmorphism->morph C Morph, + mem VM { cond-inv Inv (Morph (NewMorph {{ 1%Z }})) } N, !, + ring Inv rmorphism-int In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +ring.additive Inv V C NewMorph NewMorphInst In1 + {{ @RZAdditive lp:R lp:NewMorphInst lp:OutM1 }} Out VM :- + coq.unify-eq V (global (const { canonical-Z-nmodule })) ok, + rmorphism->sring C R, rmorphism->morph C Morph, + mem VM { cond-inv Inv (Morph (NewMorph {{ Zpos 1 }})) } N, !, + ring Inv rmorphism-Z In1 OutM1 Out1 VM, !, + build.mul { build.variable { positive-constant {calc (N + 1)} } } Out1 Out. +ring.additive Inv V C NewMorph NewMorphInst In1 + {{ @RAdditive lp:V lp:R lp:NewMorphInst lp:OutM1 }} Out1 VM :- !, + rmorphism->sring C R, rmorphism->morph C Morph, + if (coq.unify-eq {{ GRing.Nmodule.sort lp:V }} + {{ GRing.Zmodule.sort lp:V' }} ok) + (V'' = some V') (V'' = none), !, + nmod Inv (additive V V'' (x\ Morph (NewMorph x))) In1 OutM1 Out1 VM, !. + +} + +% [quote.exprw C In OutM Out VM] reifies arithmetic expressions +% (should be instantiated by each tactic call) +% - [C] is the carrier type and structure instances, +% - [In] is a term of type [C], +% - [OutM] is a reified expression of type [RExpr C], +% - [Out] is a reified expression of type [PExpr Q], and +% - [VM] is a variable map, that is a list of terms of type [C]. +pred exprw i:carrier, i:term, o:term, o:term, o:list term. + +% [quote.bop2 C In OutM Out VM] reifies boolean (in)equalities +% - [C] is the carrier type and structure instances, +% - [In] is a term of type [bool], +% - [OutM] is a reified expression of type [RFormula C], +% - [Out] is a reified expression of type [Formula Q], and +% - [VM] is a variable map, that is a list of terms of type [C]. +pred bop2 i:carrier, i:term, o:term, o:term, o:list term. +bop2 C {{ @Order.le _ lp:O lp:X lp:Y }} + {{ Build_RFormula lp:XM' OpLe lp:YM' }} + {{ Build_Formula lp:X' OpLe lp:Y' }} VM :- + coq.unify-eq { carrier->porder C } O ok, !, + exprw C X XM' X' VM, !, exprw C Y YM' Y' VM. +bop2 C {{ @Order.lt _ lp:O lp:X lp:Y }} + {{ Build_RFormula lp:XM' OpLt lp:YM' }} + {{ Build_Formula lp:X' OpLt lp:Y' }} VM :- + coq.unify-eq { carrier->porder C } O ok, !, + exprw C X XM' X' VM, !, exprw C Y YM' Y' VM. +bop2 C {{ @eq_op lp:T lp:X lp:Y }} + {{ Build_RFormula lp:XM' OpEq lp:YM' }} + {{ Build_Formula lp:X' OpEq lp:Y' }} VM :- + coq.unify-eq { carrier->eq C } T ok, !, + exprw C X XM' X' VM, !, exprw C Y YM' Y' VM. + +% [quote.pop2 C In OutM Out VM] reifies (in)equalities of type Prop +% - [C] is the carrier type and structure instances, +% - [In] is a term of type [Prop], +% - [OutM] is a reified expression of type [RFormula C], +% - [Out] is a reified expression of type [Formula Q], and +% - [VM] is a variable map, that is a list of terms of type [C]. +pred pop2 i:carrier, i:term, o:term, o:term, o:list term. +pop2 C {{ is_true lp:E }} OutM Out VM :- bop2 C E OutM Out VM. +pop2 C {{ @eq lp:T lp:X lp:Y }} + {{ Build_RFormula lp:XM' OpEq lp:YM' }} + {{ Build_Formula lp:X' OpEq lp:Y' }} VM :- + coq.unify-eq { carrier->type C } T ok, !, + exprw C X XM' X' VM, !, exprw C Y YM' Y' VM. + +% [quote.boolean C In OutM Out VM] reifies boolean formulas % - [C] is the carrier type and structure instances, % - [In] is a term of type [bool], % - [OutM] is a reified formula of type [BFormula (RFormula C) isBool], % - [Out] is a reified formula of type [BFormula (Formula Q) isBool], and % - [VM] is a variable map, that is a list of terms of type [C]. -pred quote.bool i:carrier, i:term, o:term, o:term, o:list term. -quote.bool C {{ lp:In1 ==> lp:In2 }} OutM Out VM :- !, std.do! - [quote.bool C In1 OutM1 Out1 VM, quote.bool C In2 OutM2 Out2 VM, +pred boolean i:carrier, i:term, o:term, o:term, o:list term. +boolean C {{ lp:In1 ==> lp:In2 }} OutM Out VM :- !, std.do! + [boolean C In1 OutM1 Out1 VM, boolean C In2 OutM2 Out2 VM, build.implb OutM1 OutM2 OutM, build.implb Out1 Out2 Out]. -quote.bool C {{ lp:In1 && lp:In2 }} OutM Out VM :- !, std.do! - [quote.bool C In1 OutM1 Out1 VM, quote.bool C In2 OutM2 Out2 VM, +boolean C {{ lp:In1 && lp:In2 }} OutM Out VM :- !, std.do! + [boolean C In1 OutM1 Out1 VM, boolean C In2 OutM2 Out2 VM, build.andb OutM1 OutM2 OutM, build.andb Out1 Out2 Out]. -quote.bool C {{ lp:In1 || lp:In2 }} OutM Out VM :- !, std.do! - [quote.bool C In1 OutM1 Out1 VM, quote.bool C In2 OutM2 Out2 VM, +boolean C {{ lp:In1 || lp:In2 }} OutM Out VM :- !, std.do! + [boolean C In1 OutM1 Out1 VM, boolean C In2 OutM2 Out2 VM, build.orb OutM1 OutM2 OutM, build.orb Out1 Out2 Out]. -quote.bool C {{ ~~ lp:In1 }} OutM Out VM :- !, std.do! - [quote.bool C In1 OutM1 Out1 VM, build.negb OutM1 OutM, build.negb Out1 Out]. -quote.bool _ {{ true }} {{ TT isBool }} {{ TT isBool }} _ :- !. -quote.bool _ {{ false }} {{ FF isBool }} {{ FF isBool }} _ :- !. -quote.bool C In {{ A isBool lp:OutM tt }} {{ A isBool lp:Out tt }} VM :- - quote.bop2 C In OutM Out VM. -quote.bool _ In {{ X isBool lp:In }} {{ X isBool lp:In }} _ :- !. - -% [quote.prop C In OutM Out VM] reifies formulas of type Prop +boolean C {{ ~~ lp:In1 }} OutM Out VM :- !, std.do! + [boolean C In1 OutM1 Out1 VM, build.negb OutM1 OutM, build.negb Out1 Out]. +boolean _ {{ true }} {{ TT isBool }} {{ TT isBool }} _ :- !. +boolean _ {{ false }} {{ FF isBool }} {{ FF isBool }} _ :- !. +boolean C In {{ A isBool lp:OutM tt }} {{ A isBool lp:Out tt }} VM :- + bop2 C In OutM Out VM. +boolean _ In {{ X isBool lp:In }} {{ X isBool lp:In }} _ :- !. + +% [quote.proposition C In OutM Out VM] reifies formulas of type Prop % - [C] is the carrier type and structure instances, % - [In] is a term of type [Prop], % - [OutM] is a reified formula of type [BFormula (RFormula C) isProp], % - [Out] is a reified formula of type [BFormula (Formula Q) isProp], and % - [VM] is a variable map, that is a list of terms of type [C]. -pred quote.prop i:carrier, i:term, o:term, o:term, o:list term. -quote.prop C {{ lp:In1 -> lp:In2 }} OutM Out VM :- !, std.do! - [quote.prop C In1 OutM1 Out1 VM, quote.prop C In2 OutM2 Out2 VM, +pred proposition i:carrier, i:term, o:term, o:term, o:list term. +proposition C {{ lp:In1 -> lp:In2 }} OutM Out VM :- !, std.do! + [proposition C In1 OutM1 Out1 VM, proposition C In2 OutM2 Out2 VM, build.implp OutM1 OutM2 OutM, build.implp Out1 Out2 Out]. -quote.prop C {{ iff lp:In1 lp:In2 }} OutM Out VM :- !, std.do! - [quote.prop C In1 OutM1 Out1 VM, quote.prop C In2 OutM2 Out2 VM, +proposition C {{ iff lp:In1 lp:In2 }} OutM Out VM :- !, std.do! + [proposition C In1 OutM1 Out1 VM, proposition C In2 OutM2 Out2 VM, build.iffp OutM1 OutM2 OutM, build.iffp Out1 Out2 Out]. -quote.prop C {{ lp:In1 /\ lp:In2 }} OutM Out VM :- !, std.do! - [quote.prop C In1 OutM1 Out1 VM, quote.prop C In2 OutM2 Out2 VM, +proposition C {{ lp:In1 /\ lp:In2 }} OutM Out VM :- !, std.do! + [proposition C In1 OutM1 Out1 VM, proposition C In2 OutM2 Out2 VM, build.andp OutM1 OutM2 OutM, build.andp Out1 Out2 Out]. -quote.prop C {{ lp:In1 \/ lp:In2 }} OutM Out VM :- !, std.do! - [quote.prop C In1 OutM1 Out1 VM, quote.prop C In2 OutM2 Out2 VM, - build.orb OutM1 OutM2 OutM, build.orb Out1 Out2 Out]. -quote.prop C {{ ~ lp:In1 }} OutM Out VM :- !, std.do! - [quote.prop C In1 OutM1 Out1 VM, build.negp OutM1 OutM, build.negp Out1 Out]. -quote.prop _ {{ True }} {{ TT isProp }} {{ TT isProp }} _ :- !. -quote.prop _ {{ False }} {{ FF isProp }} {{ FF isProp }} _ :- !. -quote.prop C {{ is_true lp:In1 }} +proposition C {{ lp:In1 \/ lp:In2 }} OutM Out VM :- !, std.do! + [proposition C In1 OutM1 Out1 VM, proposition C In2 OutM2 Out2 VM, + build.orp OutM1 OutM2 OutM, build.orp Out1 Out2 Out]. +proposition C {{ ~ lp:In1 }} OutM Out VM :- !, std.do! + [proposition C In1 OutM1 Out1 VM, build.negp OutM1 OutM, build.negp Out1 Out]. +proposition _ {{ True }} {{ TT isProp }} {{ TT isProp }} _ :- !. +proposition _ {{ False }} {{ FF isProp }} {{ FF isProp }} _ :- !. +proposition C {{ is_true lp:In1 }} {{ EQ lp:OutM1 (TT isBool) }} {{ EQ lp:Out1 (TT isBool) }} VM :- !, - quote.bool C In1 OutM1 Out1 VM, !. -quote.prop C {{ @eq lp:Bool lp:In1 lp:In2 }} OutM Out VM :- + boolean C In1 OutM1 Out1 VM, !. +proposition C {{ @eq lp:Bool lp:In1 lp:In2 }} OutM Out VM :- coq.unify-eq Bool {{ bool }} ok, !, - quote.bool C In1 OutM1 Out1 VM, !, quote.bool C In2 OutM2 Out2 VM, !, + boolean C In1 OutM1 Out1 VM, !, boolean C In2 OutM2 Out2 VM, !, OutM = {{ EQ lp:OutM1 lp:OutM2 }}, !, Out = {{ EQ lp:Out1 lp:Out2 }}. -quote.prop C In {{ A isProp lp:OutM tt }} {{ A isProp lp:Out tt }} VM :- - quote.pop2 C In OutM Out VM. -quote.prop _ In {{ X isProp lp:In }} {{ X isProp lp:In }} _ :- !. +proposition C In {{ A isProp lp:OutM tt }} {{ A isProp lp:Out tt }} VM :- + pop2 C In OutM Out VM. +proposition _ In {{ X isProp lp:In }} {{ X isProp lp:In }} _ :- !. % [quote.goal C Ctx Goal Goal' NS OutM Out VM] reifies the goal [Goal], % including the arithmetic hypotheses in the context [Ctx], in the form of @@ -424,16 +717,21 @@ quote.prop _ In {{ X isProp lp:In }} {{ X isProp lp:In }} _ :- !. % - [OutM] is the reified term of type [BFormula (RFormula C) isProp], % - [ReifiedOut] is the reified term of type [BFormula (Formula Q) isProp], and % - [VM] is a variable map, that is a list of terms of type [C]. -pred quote.goal i:carrier, i:list prop, i:term, - o:term, o:list term, o:term, o:term, o:list term. -quote.goal C [decl N _ In1|Ctx] Type {{ lp:In1 -> lp:Type' }} [N|NS] +pred goal i:carrier, i:list prop, i:term, + o:term, o:list term, o:term, o:term, o:list term. +goal C [decl N _ In1|Ctx] Type {{ lp:In1 -> lp:Type' }} [N|NS] {{ IMPL lp:OutM1 None lp:OutM2 }} {{ IMPL lp:Out1 None lp:Out2 }} VM :- - quote.prop C In1 OutM1 Out1 VM, not (Out1 = {{ X _ _ }}), !, - quote.goal C Ctx Type Type' NS OutM2 Out2 VM. -quote.goal C [_|Ctx] Type Type' NS OutM Out VM :- !, - quote.goal C Ctx Type Type' NS OutM Out VM. -quote.goal C [] Type Type [] OutM Out VM :- !, quote.prop C Type OutM Out VM. + proposition C In1 OutM1 Out1 VM, not (Out1 = {{ X _ _ }}), !, + goal C Ctx Type Type' NS OutM2 Out2 VM. +goal C [_|Ctx] Type Type' NS OutM Out VM :- !, + goal C Ctx Type Type' NS OutM Out VM. +goal C [] Type Type [] OutM Out VM :- !, proposition C Type OutM Out VM. + +} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Main tactic % [exfalso_if_not_prop In Out Bool] changes [In] to [False] % when [In] is not a [Prop] (and then set [Bool] to [tt]) @@ -441,9 +739,6 @@ pred exfalso_if_not_prop i:term, o:term, o:bool. exfalso_if_not_prop Type Type ff :- coq.typecheck Type {{ Prop }} ok. exfalso_if_not_prop _ {{ False }} tt. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% Main tactic - pred gen-witness i:string, i:argument, i:term, i:goal, o:sealed-goal. gen-witness TacW N Out G G' :- coq.ltac.call TacW [N, trm Out] G [G']. gen-witness _ _ _ _ _ :- coq.ltac.fail 0 "Cannot find witness". @@ -483,8 +778,8 @@ lra-reflection _ _ _ _ _ _ _ _ _ :- % [realFieldType] or [realDomainType]. solve (goal Ctx _ Type _ [str TacW, str TacF, str TacR, N] as G) GS :- std.do! [ exfalso_if_not_prop Type Type' Efalso, - rfstr Ctx Type' C IsField, - (IsField => quote.goal C Ctx Type' Type'' NS OutM Out VM), + rfstr Ctx Type' C Env, + Env => quote.goal C Ctx Type' Type'' NS OutM Out VM, carrier->ring C R, std.assert-ok! (coq.typecheck OutM {{ BFormula (@RFormula lp:R) isProp }}) diff --git a/theories/lra.v b/theories/lra.v index ad06462..ea1fade 100644 --- a/theories/lra.v +++ b/theories/lra.v @@ -20,94 +20,12 @@ Module Import Internals. Implicit Types (k : kind) (R S : ringType) (F : fieldType). -Inductive RExpr : ringType -> Type := - | RX R : R -> RExpr R - | R0 R : RExpr R - | ROpp R : RExpr R -> RExpr R - | RAdd R : RExpr R -> RExpr R -> RExpr R - (* TODO: support nat expressions: *) - | RMuln R : RExpr R -> large_nat -> RExpr R - | RMulz R : RExpr R -> RExpr [ringType of int] -> RExpr R - | R1 R : RExpr R - | RMul R : RExpr R -> RExpr R -> RExpr R - | RExpn R : RExpr R -> large_nat -> RExpr R - | RInv F : RExpr F -> RExpr F - | RMorph R R' : {rmorphism R -> R'} -> RExpr R -> RExpr R' - | RintC : large_int -> RExpr [ringType of int] - | RZC : Z -> RExpr [ringType of Z]. - -Fixpoint Reval_expr R (e : RExpr R) : R := - match e with - | RX _ x => x - | R0 _ => 0%R - | ROpp _ e => - Reval_expr e - | RAdd _ e1 e2 => Reval_expr e1 + Reval_expr e2 - | RMuln _ e n => Reval_expr e *+ nat_of_large_nat n - | RMulz _ e1 e2 => Reval_expr e1 *~ Reval_expr e2 - | R1 _ => 1%R - | RMul _ e1 e2 => Reval_expr e1 * Reval_expr e2 - | RExpn _ e n => Reval_expr e ^+ nat_of_large_nat n - | RInv _ e => (Reval_expr e)^-1 - | RMorph _ _ f e => f (Reval_expr e) - | RintC x => int_of_large_int x - | RZC x => x - end. - (* Define [Reval_formula] the semantics of [BFormula (Formula Z) Tauto.isProp] as arithmetic expressions on some [realDomainType]. Then prove [RTautoChecker_sound] stating that [ZTautoChecker f w = true] implies that the formula [Reval_formula f] holds. *) Record RFormula R := { Rlhs : RExpr R; Rop : Op2; Rrhs : RExpr R }. -Section Rnorm_expr. - -Variables (R' : ringType). -Variables (R_of_Z : Z -> R') (R_of_ZE : R_of_Z = (fun n => (int_of_Z n)%:~R)). -Variables (opp : R' -> R') (oppE : opp = -%R). -Variables (add : R' -> R' -> R') (addE : add = +%R). -Variables (mul : R' -> R' -> R') (mulE : mul = *%R). -Variables (exp : R' -> N -> R') (expE : exp = (fun x n => x ^+ nat_of_N n)). - -Fixpoint Rnorm_expr R (f : R -> R') (e : RExpr R) : R' := - match e in RExpr R return (R -> R') -> R' with - | RX _ x => fun f => f x - | R0 _ => fun=> R_of_Z 0 - | ROpp _ e => fun f => opp (Rnorm_expr f e) - | RAdd _ e1 e2 => fun f => add (Rnorm_expr f e1) (Rnorm_expr f e2) - | RMuln _ e n => fun f => mul (Rnorm_expr f e) (R_of_Z (Z_of_large_nat n)) - | RMulz _ e1 e2 => fun f => mul (Rnorm_expr f e1) (Rnorm_expr intr e2) - | R1 _ => fun=> R_of_Z 1 - | RMul _ e1 e2 => fun f => mul (Rnorm_expr f e1) (Rnorm_expr f e2) - | RExpn _ e1 n => fun f => exp (Rnorm_expr f e1) (N_of_large_nat n) - | RInv _ _ => fun=> f (Reval_expr e) - | RMorph _ _ g e => fun f => Rnorm_expr (fun x => f (g x)) e - | RintC x => fun=> R_of_Z (Z_of_large_int x) - | RZC x => fun=> R_of_Z x - end f. - -Lemma Rnorm_expr_correct_rec R (f : {rmorphism R -> R'}) (e : RExpr R) : - f (Reval_expr e) = Rnorm_expr f e. -Proof. -move: f; elim: e => {R} //=. -- by move=> R f; rewrite R_of_ZE rmorph0. -- by move=> R e IHe f; rewrite oppE rmorphN IHe. -- by move=> R e1 IHe1 e2 IHe2 f; rewrite addE rmorphD IHe1 IHe2. -- move=> R e IHe n f. - by rewrite mulE R_of_ZE rmorphMn -mulr_natr IHe large_nat_Z_int. -- by move=> R e1 IHe1 e2 IHe2 f; rewrite mulE rmorphMz -mulrzr IHe1 IHe2. -- by move=> R f; rewrite R_of_ZE rmorph1. -- by move=> R e1 IHe1 e2 IHe2 f; rewrite mulE rmorphM IHe1 IHe2. -- by move=> R e IHe n f; rewrite expE rmorphX IHe large_nat_N_nat. -- by move=> R S g e IHe f; rewrite -/(comp f g) -IHe. -- by move=> x f; rewrite R_of_ZE -(rmorph_int f) intz large_int_Z_int. -- by move=> x f; rewrite R_of_ZE -(rmorph_int f); congr (f _); lia. -Qed. - -Lemma Rnorm_expr_correct (e : RExpr R') : Reval_expr e = Rnorm_expr id e. -Proof. exact: Rnorm_expr_correct_rec [rmorphism of idfun] _. Qed. - -End Rnorm_expr. - Section Rnorm_formula. Variables (R : numDomainType). @@ -122,7 +40,8 @@ Variables (eqBool : R -> R -> bool) (eqBoolE : eqBool = eq_op). Variables (le : R -> R -> bool) (leE : le = <=%O). Variables (lt : R -> R -> bool) (ltE : lt = <%O). -Notation Rnorm_expr := (Rnorm_expr R_of_Z opp add mul exp). +Local Notation Rnorm_expr := + (Ring.Rnorm R_of_Z (R_of_Z 0) add opp sub (R_of_Z 1) mul exp). Definition Reval_pop2 (o : Op2) : R -> R -> Prop := match o with @@ -148,7 +67,7 @@ Definition Reval_op2 k : Op2 -> R -> R -> rtyp k := match k with isProp => Reval_pop2 | isBool => Reval_bop2 end. Definition Reval_formula k (ff : RFormula R) : rtyp k := - let (lhs,o,rhs) := ff in Reval_op2 k o (Reval_expr lhs) (Reval_expr rhs). + let (lhs,o,rhs) := ff in Reval_op2 k o (Reval lhs) (Reval rhs). Definition Rnorm_formula k (ff : RFormula R) := let (lhs,o,rhs) := ff in @@ -156,7 +75,10 @@ Definition Rnorm_formula k (ff : RFormula R) := Lemma Rnorm_formula_correct k (ff : RFormula R) : Reval_formula k ff = Rnorm_formula k ff. -Proof. by case: ff => l o r /=; rewrite -!Rnorm_expr_correct. Qed. +Proof. +case: ff => l o r /=. +by rewrite !Ring.Rnorm_correct R_of_ZE addE oppE subE mulE expE. +Qed. Lemma Rnorm_bf_correct k (ff : BFormula (RFormula R) k) : eval_bf Reval_formula ff = eval_bf Rnorm_formula ff. @@ -212,13 +134,13 @@ Lemma RTautoChecker_sound (ff : BFormula (RFormula R) isProp) (f : BFormula (Formula Z) isProp) (w : seq (Psatz Z)) (env : PolEnv R) : (forall R_of_Z opp add sub mul exp eqProp eqBool le lt, - let norm_ff := Rnorm_formula R_of_Z opp add mul exp eqProp eqBool le lt in + let norm_ff := Rnorm_formula R_of_Z opp add sub mul exp eqProp eqBool le lt in let eval_f := Reval_PFormula R_of_Z opp add sub mul exp eqProp eqBool le lt env in eval_bf norm_ff ff = eval_bf eval_f f) -> ZTautoChecker f w -> eval_bf (Reval_formula eq eq_op <=%O <%O) ff. Proof. -rewrite (Rnorm_bf_correct erefl erefl erefl erefl erefl). +rewrite (Rnorm_bf_correct erefl erefl erefl erefl erefl erefl). move=> /(_ _ _ _ (fun x y => x - y)) -> Hchecker. move: Hchecker env; apply: (tauto_checker_sound _ _ _ _ Reval_nformula). - exact: (eval_nformula_dec Rsor). @@ -235,82 +157,6 @@ Qed. End RealDomain. -Section Fnorm_expr. - -Variables (F : fieldType). -Variables (F_of_Q : Q -> F) (F_of_QE : F_of_Q = R_of_Q). -Variables (opp : F -> F) (oppE : opp = -%R). -Variables (add : F -> F -> F) (addE : add = +%R). -Variables (mul : F -> F -> F) (mulE : mul = *%R). -Variables (exp : F -> N -> F) (expE : exp = (fun x n => x ^+ nat_of_N n)). -Variables (inv : F -> F) (invE : inv = GRing.inv). - -Fixpoint Fnorm_expr R (f : R -> F) (e : RExpr R) (invb : bool) : - F := - match e in RExpr R, invb return (R -> F) -> F with - | RX _ x, false => fun f => f x - | RX _ x, true => fun f => inv (f x) - | R0 _, _ => fun=> F_of_Q 0 - | ROpp _ e, _ => fun f => opp (Fnorm_expr f e invb) - | RAdd _ e1 e2, false => - fun f => add (Fnorm_expr f e1 false) (Fnorm_expr f e2 false) - | RMuln _ e n, _ => fun f => - mul (Fnorm_expr f e invb) - (if invb then - F_of_Q (Qinv (Z_of_large_nat n # 1)) - else F_of_Q (Z_of_large_nat n # 1)) - | RMulz _ e1 e2, _ => fun f => - mul (Fnorm_expr f e1 invb) (Fnorm_expr intr e2 invb) - | R1 _, _ => fun=> F_of_Q 1 - | RMul _ e1 e2, _ => - fun f => mul (Fnorm_expr f e1 invb) (Fnorm_expr f e2 invb) - | RExpn _ e1 n, _ => fun f => exp (Fnorm_expr f e1 invb) (N_of_large_nat n) - | RInv _ e, _ => fun f => Fnorm_expr f e (negb invb) - | RMorph _ _ g e, _ => fun f => Fnorm_expr (fun x => f (g x)) e invb - | RintC x, false => fun=> F_of_Q (Z_of_large_int x # 1) - | RintC x, true => fun=> F_of_Q (Qinv (Z_of_large_int x # 1)) - | RZC x, false => fun=> F_of_Q (x # 1) - | RZC x, true => fun=> F_of_Q (Qinv (x # 1)) - | _, true => fun=> inv (f (Reval_expr e)) - end f. - -Lemma Fnorm_expr_correct_rec R (f : {rmorphism R -> F}) (e : RExpr R) : - (f (Reval_expr e) = Fnorm_expr f e false) /\ - ((f (Reval_expr e))^-1 = Fnorm_expr f e true). -Proof. -move: f; elim: e => {R} //=. -- by move=> R x f; rewrite invE. -- by move=> R f; rewrite F_of_QE rmorph0 invr0 /R_of_Q divr1. -- move=> R e IHe f; case: (IHe f) => {}IHe IHe'. - by rewrite oppE rmorphN invrN IHe' IHe. -- move=> R e1 IHe1 e2 IHe2 f; move: (IHe1 f) (IHe2 f) => [{}IHe1 _] [{}IHe2 _]. - by rewrite addE invE rmorphD IHe1 IHe2. -- move=> R e IHe n f; move: (IHe f) => [{}IHe IHe']. - rewrite mulE F_of_QE rmorphMn -mulr_natr invfM IHe' IHe R_of_Q_invZ. - by rewrite /R_of_Q divr1 large_nat_Z_int. -- move=> R e1 IHe1 e2 IHe2 f. - move: (IHe1 f) (IHe2 [rmorphism of intr]) => [{}IHe1 IHe1'] [{}IHe2 IHe2']. - by rewrite mulE rmorphMz -mulrzr invfM IHe1' IHe1 IHe2' IHe2. -- by move=> R f; rewrite F_of_QE rmorph1 invr1 /R_of_Q divr1. -- move=> R e1 IHe1 e2 IHe2 f. - move: (IHe1 f) (IHe2 f) => [{}IHe1 IHe1'] [{}IHe2 IHe2']. - by rewrite mulE rmorphM invfM IHe1' IHe1 IHe2' IHe2. -- move=> R e IHe n f; case: (IHe f) => {}IHe IHe'. - by rewrite expE rmorphX -exprVn IHe' IHe large_nat_N_nat. -- move=> R e IHe f; case: (IHe f) => {}IHe IHe'. - by rewrite fmorphV invrK IHe' IHe. -- by move=> R S g e IHe f; case: (IHe [rmorphism of f \o g]); split. -- move=> x f; rewrite F_of_QE R_of_Q_invZ /R_of_Q divr1 /= -(rmorph_int f). - by rewrite intz large_int_Z_int. -- move=> x f; rewrite F_of_QE R_of_Q_invZ /R_of_Q divr1 /= -(rmorph_int f). - by split; [congr (f _) | congr (f _)^-1]; lia. -Qed. - -Lemma Fnorm_expr_correct (e : RExpr F) : Reval_expr e = Fnorm_expr id e false. -Proof. by have [] := Fnorm_expr_correct_rec [rmorphism of idfun] e. Qed. - -End Fnorm_expr. - Section Fnorm_formula. Variables (F : numFieldType). @@ -325,7 +171,11 @@ Variables (eqBool : F -> F -> bool) (eqBoolE : eqBool = eq_op). Variables (le : F -> F -> bool) (leE : le = <=%O). Variables (lt : F -> F -> bool) (ltE : lt = <%O). -Notation Fnorm_expr := (Fnorm_expr F_of_Q opp add mul exp GRing.inv). +Local Notation F_of_Z invb n := + (if invb then F_of_Q (Qinv (Qmake n 1)) else F_of_Q (Qmake n 1)). + +Notation Fnorm_expr := (Lra.Rnorm (fun b n => F_of_Z b n) (F_of_Z false 0) + add opp sub (F_of_Z false 1) mul exp GRing.inv false). Notation Feval_pop2 := (Reval_pop2 eqProp le lt). Notation Feval_bop2 := (Reval_bop2 eqBool le lt). Notation Feval_op2 := (Reval_op2 eqProp eqBool le lt). @@ -333,11 +183,17 @@ Notation Feval_formula := (Reval_formula eqProp eqBool le lt). Definition Fnorm_formula k (ff : RFormula F) := let (lhs,o,rhs) := ff in - Feval_op2 k o (Fnorm_expr id lhs false) (Fnorm_expr id rhs false). + Feval_op2 k o (Fnorm_expr id lhs) (Fnorm_expr id rhs). Lemma Fnorm_formula_correct k (ff : RFormula F) : Feval_formula k ff = Fnorm_formula k ff. -Proof. by case: ff => l o r /=; rewrite -!Fnorm_expr_correct. Qed. +Proof. +case: ff => l o r /=; rewrite !Lra.Rnorm_correct addE oppE subE mulE expE. +rewrite F_of_QE /R_of_Q/= mul0r mul1r invr1. +by congr Feval_op2; apply: Lra.Rnorm_eq => invb n; rewrite mulr1; + case: n => [|p|p] /=; rewrite ?(invr0, mul0r, mul1r)//; + rewrite mulNr -divrN mul1r NegzE prednK ?nmulrn//; lia. +Qed. Lemma Fnorm_bf_correct k (ff : BFormula (RFormula F) k) : eval_bf Feval_formula ff = eval_bf Fnorm_formula ff. @@ -385,14 +241,15 @@ Lemma FTautoChecker_sound (ff : BFormula (RFormula F) isProp) (f : BFormula (Formula Q) isProp) (w : seq (Psatz Q)) (env : PolEnv F) : (forall F_of_Q opp add sub mul exp eqProp eqBool le lt, - let norm_ff := Fnorm_formula F_of_Q opp add mul exp eqProp eqBool le lt in + let norm_ff := + Fnorm_formula F_of_Q opp add sub mul exp eqProp eqBool le lt in let eval_f := Feval_PFormula F_of_Q opp add sub mul exp eqProp eqBool le lt env in eval_bf norm_ff ff = eval_bf eval_f f) -> QTautoChecker f w -> eval_bf (Reval_formula eq eq_op <=%O <%O) ff. Proof. -rewrite (Fnorm_bf_correct erefl erefl erefl erefl erefl). -move=> /(_ _ _ _ (fun x y => x - y)) -> Hchecker. +rewrite (Fnorm_bf_correct erefl erefl erefl erefl erefl erefl). +move/(_ R_of_Q) => -> Hchecker. move: Hchecker env; apply: (tauto_checker_sound _ _ _ _ Feval_nformula). - exact: (eval_nformula_dec Rsor). - by move=> [? ?] ? ?; apply: (check_inconsistent_sound Rsor FSORaddon). @@ -526,16 +383,16 @@ Ltac tacR R hyps rff ff varmap wit := End Internals. Strategy expand [addn_expand nat_of_pos_rec_expand nat_of_pos_expand]. -Strategy expand [nat_of_N_expand int_of_Z_expand Z_of_N_expand]. +Strategy expand [nat_of_N_expand]. Strategy expand [nat_of_large_nat N_of_large_nat Z_of_large_nat]. -Strategy expand [int_of_large_int Z_of_large_int]. -Strategy expand [Reval_expr Rnorm_expr Fnorm_expr]. +Strategy expand [Reval Meval Ring.Rnorm Ring.Mnorm Lra.Rnorm Lra.Mnorm]. Strategy expand [Reval_pop2 Reval_bop2 Reval_op2]. Strategy expand [Reval_formula Rnorm_formula Fnorm_formula]. Strategy expand [Reval_PFormula Feval_PFormula]. Elpi Tactic lra. +Elpi Accumulate Db canonicals.db. Elpi Accumulate File common lra. Elpi Typecheck. @@ -544,3 +401,5 @@ Tactic Notation "nra" := elpi lra "nra_witness" "tacF" "tacR" 0. Tactic Notation "psatz" integer(n) := elpi lra "psatz_witness" "tacF" "tacR" ltac_int:(n). Tactic Notation "psatz" := elpi lra "psatz_witness" "tacF" "tacR" (-1). + +Elpi Query lp:{{ canonical-init library "canonicals.db" }}. diff --git a/theories/ring.elpi b/theories/ring.elpi index 9b28b6b..39c8d6b 100644 --- a/theories/ring.elpi +++ b/theories/ring.elpi @@ -1,375 +1,160 @@ -% [field-mode] is true if the target is a field equation. -pred field-mode. - -% [ring->field Ring Field]: [Field] is optionally a [fieldType] instance such -% that [GRing.Field.ringType Field = Ring]. -pred ring->field i:term, o:option term. -ring->field R (some F) :- - field-mode, - coq.unify-eq {{ GRing.Ring.sort lp:R }} {{ GRing.Field.sort lp:F }} ok, !. -ring->field _ none. - -% Constructors for reified terms -pred quote.expr.variable i:term, o:term. -quote.expr.variable In {{ @FEX Z lp:In }} :- field-mode, !. -quote.expr.variable In {{ @PEX Z lp:In }} :- !. - -pred quote.expr.constant i:term, o:term. -quote.expr.constant In {{ @FEc Z lp:In }} :- field-mode, !. -quote.expr.constant In {{ @PEc Z lp:In }} :- !. - -pred quote.expr.zero o:term. -quote.expr.zero {{ @FEO Z }} :- field-mode, !. -quote.expr.zero {{ @PEO Z }} :- !. - -pred quote.expr.opp i:term, o:term. -quote.expr.opp In {{ @FEopp Z lp:In }} :- field-mode, !. -quote.expr.opp In {{ @PEopp Z lp:In }} :- !. - -pred quote.expr.add i:term, i:term, o:term. -quote.expr.add In1 In2 {{ @FEadd Z lp:In1 lp:In2 }} :- field-mode, !. -quote.expr.add In1 In2 {{ @PEadd Z lp:In1 lp:In2 }} :- !. - -pred quote.expr.sub i:term, i:term, o:term. -quote.expr.sub In1 In2 {{ @FEsub Z lp:In1 lp:In2 }} :- field-mode, !. -quote.expr.sub In1 In2 {{ @PEsub Z lp:In1 lp:In2 }} :- !. - -pred quote.expr.one o:term. -quote.expr.one {{ @FEI Z }} :- field-mode, !. -quote.expr.one {{ @PEI Z }} :- !. - -pred quote.expr.mul i:term, i:term, o:term. -quote.expr.mul In1 In2 {{ @FEmul Z lp:In1 lp:In2 }} :- field-mode, !. -quote.expr.mul In1 In2 {{ @PEmul Z lp:In1 lp:In2 }} :- !. - -pred quote.expr.exp i:term, i:term, o:term. -quote.expr.exp In1 In2 {{ @FEpow Z lp:In1 lp:In2 }} :- field-mode, !. -quote.expr.exp In1 In2 {{ @PEpow Z lp:In1 lp:In2 }} :- !. - -% [quote.ncstr In OutM Out] reifies natural number constant [In] of type [nat] -% to a term [OutM] of type [large_nat] and a term [Out] of type [N]. -pred quote.ncstr i:term, o:term, o:term. -quote.ncstr {{ lp:In : _ }} OutM Out :- !, quote.ncstr In OutM Out. -quote.ncstr {{ Nat.of_num_uint lp:In }} {{ large_nat_uint lp:In }} Out :- - ground-uint In, !, - coq.reduction.vm.norm {{ N.of_num_uint lp:In }} {{ N }} Out. -quote.ncstr In {{ large_nat_N lp:Out }} Out :- - reduction-N {{ N.of_nat lp:In }} Out. - -% [quote.icstr In Pos OutM Out] reifies integer constant -pred quote.icstr i:term, o:bool, o:term, o:term. -quote.icstr {{ lp:In : _ }} Pos OutM Out :- !, quote.icstr In Pos OutM Out. -quote.icstr {{ Posz (Nat.of_num_uint lp:In) }} - tt {{ large_nat_uint lp:In }} Out :- - ground-uint In, !, - coq.reduction.vm.norm {{ N.of_num_uint lp:In }} {{ N }} Out. -quote.icstr {{ Negz (Nat.of_num_uint lp:In) }} - ff {{ large_nat_uint lp:In }} Out :- - ground-uint In, !, - coq.reduction.vm.norm {{ N.of_num_uint lp:In }} {{ N }} Out. -quote.icstr In Pos {{ large_nat_N lp:Out }} Out :- !, - coq.reduction.vm.norm {{ quote_icstr_helper lp:In }} {{ (bool * N)%type }} - {{ (lp:Pos', lp:Out) }}, !, - ((Pos' = {{ true }}, !, Pos = tt); (Pos' = {{ false }}, !, Pos = ff)), !, - ground-N Out. - -% [quote.nat R Input OutM Out VarMap] -% - [R] is a [ringType] instance, -% - [Input] is a term of type [nat], -% - [OutM] and [Out] are reified terms of [Input], and -% - [VarMap] is a variable map. -pred quote.nat i:term, i:term, o:term, o:term, o:list term. -quote.nat R {{ lp:In : _ }} OutM Out VarMap :- !, - quote.nat R In OutM Out VarMap. -quote.nat _ {{ lib:num.nat.O }} {{ NC (large_nat_N lib:num.N.N0) }} Out _ :- !, - quote.expr.constant {{ lib:num.Z.Z0 }} Out. -quote.nat R {{ lib:num.nat.S lp:In }} OutM Out VarMap :- !, - quote.count-succ In N In2, !, - positive-constant {calc (N + 1)} Out1, !, - if (In2 = {{ lib:num.nat.O }}) - (OutM = {{ NC (large_nat_N (lib:num.N.Npos lp:Out1)) }}, - quote.expr.constant {{ lib:num.Z.Zpos lp:Out1 }} Out) - (quote.nat R In2 OutM2 Out2 VarMap, !, - OutM = {{ NAdd (NC (large_nat_N (lib:num.N.Npos lp:Out1))) lp:OutM2 }}, - quote.expr.add - {quote.expr.constant {{ lib:num.Z.Zpos lp:Out1 }} } Out2 Out). -quote.nat _ {{ Nat.of_num_uint lp:X }} {{ NC (large_nat_uint lp:X) }} Out _ :- - ground-uint X, !, - coq.reduction.vm.norm {{ Z.of_num_uint lp:X }} {{ Z }} XZ, !, - quote.expr.constant XZ Out. -quote.nat R {{ addn lp:In1 lp:In2 }} {{ NAdd lp:OutM1 lp:OutM2 }} Out VarMap :- - !, - quote.nat R In1 OutM1 Out1 VarMap, !, - quote.nat R In2 OutM2 Out2 VarMap, !, - quote.expr.add Out1 Out2 Out. -quote.nat R {{ muln lp:In1 lp:In2 }} {{ NMul lp:OutM1 lp:OutM2 }} Out VarMap :- - !, - quote.nat R In1 OutM1 Out1 VarMap, !, - quote.nat R In2 OutM2 Out2 VarMap, !, - quote.expr.mul Out1 Out2 Out. -quote.nat R {{ expn lp:In1 lp:In2 }} {{ NExp lp:OutM1 lp:OutM2 }} Out VarMap :- - quote.ncstr In2 OutM2 Out2, !, - quote.nat R In1 OutM1 Out1 VarMap, !, - quote.expr.exp Out1 Out2 Out. -quote.nat R In {{ NX lp:In }} Out VarMap :- !, - Zmodule = {{ GRing.Ring.zmodType lp:R }}, - mem VarMap {{ @GRing.natmul lp:Zmodule (@GRing.one lp:R) lp:In }} N, !, - quote.expr.variable { positive-constant {calc (N + 1)} } Out. -pred quote.count-succ i:term, o:int, o:term. -quote.count-succ {{ lib:num.nat.S lp:In }} N' Out :- !, - quote.count-succ In N Out, N' is N + 1. -quote.count-succ In 0 In :- !. - -% [quote.zmod U R Morph Input OutM Out VarMap] -% - [U] is a [zmodType] instance, -% - [R] is a [ringType] instance, -% - [Morph] is an additive function from [U] to [R], -% - [Input] is a term of type [U], -% - [OutM] and [Out] are reified terms of [Input], and -% - [VarMap] is a variable map. -pred quote.zmod i:term, i:term, i:(term -> term), i:term, - o:term, o:term, o:list term. -% _ : _ -quote.zmod U R Morph {{ lp:In : _ }} OutM Out VarMap :- !, - quote.zmod U R Morph In OutM Out VarMap. -% 0%R -quote.zmod U _ _ {{ @GRing.zero lp:U' }} {{ @ZM0 lp:U }} Out _ :- - coq.unify-eq U U' ok, !, - quote.expr.zero Out. -% -%R -quote.zmod U R Morph {{ @GRing.opp lp:U' lp:In1 }} - {{ @ZMOpp lp:U lp:OutM1 }} Out VarMap :- - coq.unify-eq U U' ok, !, - quote.zmod U R Morph In1 OutM1 Out1 VarMap, !, - quote.expr.opp Out1 Out. -% +%R -quote.zmod U R Morph {{ @GRing.add lp:U' lp:In1 lp:In2 }} - {{ @ZMAdd lp:U lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq U U' ok, !, - quote.zmod U R Morph In1 OutM1 Out1 VarMap, !, - quote.zmod U R Morph In2 OutM2 Out2 VarMap, !, - quote.expr.add Out1 Out2 Out. -% (_ *+ _)%R -quote.zmod U R Morph {{ @GRing.natmul lp:U' lp:In1 lp:In2 }} - {{ @ZMMuln lp:U lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq U U' ok, !, - quote.zmod U R Morph In1 OutM1 Out1 VarMap, !, - quote.nat R In2 OutM2 Out2 VarMap, !, - quote.expr.mul Out1 Out2 Out. -% (_ *~ _)%R -quote.zmod U R Morph {{ @intmul lp:U' lp:In1 lp:In2 }} - {{ @ZMMulz lp:U lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq U U' ok, !, - quote.zmod U R Morph In1 OutM1 Out1 VarMap, !, - quote.ring - {{ int_Ring }} none R - (n\ {{ @intmul (GRing.Ring.zmodType lp:R) (@GRing.one lp:R) lp:n }}) - In2 OutM2 Out2 VarMap, !, - quote.expr.mul Out1 Out2 Out. -% additive functions -quote.zmod U R Morph In - {{ @ZMMorph lp:V lp:U lp:NewMorphInst lp:OutM }} Out VarMap :- - NewMorph = (x\ {{ @GRing.Additive.apply lp:V lp:U _ lp:NewMorphInst lp:x }}), - coq.unify-eq In (NewMorph In1) ok, !, - % TODO: for concrete additive functions, should we unpack [NewMorph]? - quote.zmod V R (x\ Morph (NewMorph x)) In1 OutM Out VarMap. -% variables -quote.zmod U _ Morph In {{ @ZMX lp:U lp:In }} Out VarMap :- - mem VarMap (Morph In) N, - quote.expr.variable { positive-constant {calc (N + 1)} } Out, !. -quote.zmod _ _ _ In _ _ _ :- coq.error "Unknown" {coq.term->string In}. - -% [quote.ring R F TR Morph Input OutM Out VarMap] -% - [R] and [TR] are [ringType] instances, -% - [F] is optionally a [fieldType] instance such that -% [GRing.Field.ringType F = R], -% - [Morph] is a ring morphism from [R] to [TR], -% - [Input] is a term of type [R], -% - [OutM] and [Out] are reified terms of [Input], and -% - [VarMap] is a variable map. -pred quote.ring i:term, i:option term, i:term, i:(term -> term), - i:term, o:term, o:term, o:list term. -% _ : _ -quote.ring R F TR Morph {{ lp:In : _ }} OutM Out VarMap :- !, - quote.ring R F TR Morph In OutM Out VarMap. -% 0%R -quote.ring R _ _ _ {{ @GRing.zero lp:U }} {{ @R0 lp:R }} Out _ :- - coq.unify-eq U {{ GRing.Ring.zmodType lp:R }} ok, !, - quote.expr.zero Out. -% -%R -quote.ring R F TR Morph {{ @GRing.opp lp:U lp:In1 }} - {{ @ROpp lp:R lp:OutM1 }} Out VarMap :- - coq.unify-eq U {{ GRing.Ring.zmodType lp:R }} ok, !, - quote.ring R F TR Morph In1 OutM1 Out1 VarMap, !, - quote.expr.opp Out1 Out. -% Z.opp -quote.ring R none TR Morph - {{ Z.opp lp:In1 }} {{ @RZOpp lp:OutM1 }} Out VarMap :- - coq.unify-eq {{ ZInstances.Z_ringType }} R ok, !, - quote.ring R none TR Morph In1 OutM1 Out1 VarMap, !, - quote.expr.opp Out1 Out. -% +%R -quote.ring R F TR Morph {{ @GRing.add lp:U lp:In1 lp:In2 }} - {{ @RAdd lp:R lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq U {{ GRing.Ring.zmodType lp:R }} ok, !, - quote.ring R F TR Morph In1 OutM1 Out1 VarMap, !, - quote.ring R F TR Morph In2 OutM2 Out2 VarMap, !, - quote.expr.add Out1 Out2 Out. -% Z.add -quote.ring R none TR Morph {{ Z.add lp:In1 lp:In2 }} - {{ @RZAdd lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq {{ ZInstances.Z_ringType }} R ok, !, - quote.ring R none TR Morph In1 OutM1 Out1 VarMap, !, - quote.ring R none TR Morph In2 OutM2 Out2 VarMap, !, - quote.expr.add Out1 Out2 Out. -% Z.sub -quote.ring R none TR Morph {{ Z.sub lp:In1 lp:In2 }} - {{ @RZSub lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq {{ ZInstances.Z_ringType }} R ok, !, - quote.ring R none TR Morph In1 OutM1 Out1 VarMap, !, - quote.ring R none TR Morph In2 OutM2 Out2 VarMap, !, - quote.expr.sub Out1 Out2 Out. -% (_ *+ _)%R -quote.ring R F TR Morph {{ @GRing.natmul lp:U lp:In1 lp:In2 }} - {{ @RMuln lp:R lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq U {{ @GRing.Ring.zmodType lp:R }} ok, !, - quote.ring R F TR Morph In1 OutM1 Out1 VarMap, !, - quote.nat TR In2 OutM2 Out2 VarMap, !, - quote.expr.mul Out1 Out2 Out. -% (_ *~ _)%R -quote.ring R F TR Morph {{ @intmul lp:U lp:In1 lp:In2 }} - {{ @RMulz lp:R lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq U {{ @GRing.Ring.zmodType lp:R }} ok, !, - quote.ring R F TR Morph In1 OutM1 Out1 VarMap, !, - quote.ring - {{ int_Ring }} none TR - (n\ {{ @intmul (GRing.Ring.zmodType lp:TR) (@GRing.one lp:TR) lp:n }}) - In2 OutM2 Out2 VarMap, !, - quote.expr.mul Out1 Out2 Out. -% 1%R -quote.ring R _ _ _ {{ @GRing.one lp:R' }} {{ @R1 lp:R }} Out _ :- - coq.unify-eq R' R ok, !, - quote.expr.one Out. -% *%R -quote.ring R F TR Morph {{ @GRing.mul lp:R' lp:In1 lp:In2 }} - {{ @RMul lp:R lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq R' R ok, !, - quote.ring R F TR Morph In1 OutM1 Out1 VarMap, !, - quote.ring R F TR Morph In2 OutM2 Out2 VarMap, !, - quote.expr.mul Out1 Out2 Out. -% Z.mul -quote.ring R none TR Morph {{ Z.mul lp:In1 lp:In2 }} - {{ @RZMul lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq {{ ZInstances.Z_ringType }} R ok, !, - quote.ring R none TR Morph In1 OutM1 Out1 VarMap, !, - quote.ring R none TR Morph In2 OutM2 Out2 VarMap, !, - quote.expr.mul Out1 Out2 Out. -% (_ ^+ _)%R -quote.ring R F TR Morph {{ @GRing.exp lp:R' lp:In1 lp:In2 }} - {{ @RExpn lp:R lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq R' R ok, quote.ncstr In2 OutM2 Out2, !, - quote.ring R F TR Morph In1 OutM1 Out1 VarMap, !, - quote.expr.exp Out1 Out2 Out. -% (_ ^ _)%R -quote.ring R F TR Morph {{ @exprz lp:R' lp:In1 lp:In2 }} OutM Out VarMap :- - quote.icstr In2 Pos OutM2 Out2, - if (Pos = tt) - (CONT = - (coq.unify-eq {{ GRing.UnitRing.ringType lp:R' }} R ok, !, - quote.ring R F TR Morph In1 OutM1 Out1 VarMap, !, - OutM = {{ @RExpPosz lp:R' lp:OutM1 lp:OutM2 }}, !, - quote.expr.exp Out1 Out2 Out)) - (CONT = - (field-mode, - F = some F', - coq.unify-eq R' {{ GRing.Field.unitRingType lp:F' }} ok, !, - quote.ring R F TR Morph In1 OutM1 Out1 VarMap, !, - OutM = {{ @RExpNegz lp:F' lp:OutM1 lp:OutM2 }}, !, - Out = {{ @FEinv Z (@FEpow Z lp:Out1 lp:Out2) }})), - CONT. -% Z.pow -quote.ring R none TR Morph {{ Z.pow lp:In1 lp:In2 }} - {{ @RZExp lp:OutM1 lp:OutM2 }} Out VarMap :- - coq.unify-eq {{ ZInstances.Z_ringType }} R ok, - reduction-Z In2 OutM2, !, - ((((OutM2 = {{ Z0 }}, !, Out2 = {{ N0 }}); % If [In2] is non-negative - (OutM2 = {{ Zpos lp:P }}, !, Out2 = {{ Npos lp:P }})), !, - quote.ring R none TR Morph In1 OutM1 Out1 VarMap, !, - quote.expr.exp Out1 Out2 Out); - quote.expr.zero Out). % If [In2] is negative -% _^-1 -quote.ring R (some F) TR Morph {{ @GRing.inv lp:R' lp:In1 }} - {{ @RInv lp:F lp:OutM1 }} {{ @FEinv Z lp:Out1 }} VarMap :- - field-mode, - coq.unify-eq R' {{ GRing.Field.unitRingType lp:F }} ok, !, - quote.ring R (some F) TR Morph In1 OutM1 Out1 VarMap. -% Posz -quote.ring R _ TR _ {{ Posz lp:In }} {{ @RPosz lp:OutM }} Out VarMap :- - coq.unify-eq {{ int_Ring }} R ok, !, - quote.nat TR In OutM Out VarMap. -% Negz -quote.ring R _ TR _ {{ Negz lp:In }} {{ @RNegz lp:OutM1 }} Out VarMap :- - coq.unify-eq {{ int_Ring }} R ok, !, - quote.nat TR In OutM1 Out1 VarMap, !, - quote.expr.opp { quote.expr.add { quote.expr.one } Out1 } Out. -% Z constants -quote.ring R _ _ _ In {{ @RZC lp:In }} Out _ :- - coq.unify-eq {{ ZInstances.Z_ringType }} R ok, - ground-Z In, !, - quote.expr.constant In Out. -% morphisms -quote.ring R _ TR Morph In - {{ @RMorph lp:Q lp:R lp:NewMorphInst lp:OutM }} Out VarMap :- - NewMorph = (x\ {{ @GRing.RMorphism.apply - lp:Q lp:R _ lp:NewMorphInst lp:x }}), - coq.unify-eq In (NewMorph In1) ok, - !, - % TODO: for concrete morphisms, should we unpack [NewMorph]? - quote.ring Q { ring->field Q } TR (x\ Morph (NewMorph x)) In1 OutM Out VarMap. -% additive functions -quote.ring R _ TR Morph In - {{ @RMorph' lp:U lp:R lp:NewMorphInst lp:OutM }} Out VarMap :- - NewMorph = - (x\ {{ @GRing.Additive.apply - lp:U (GRing.Ring.zmodType lp:R) _ lp:NewMorphInst lp:x }}), - coq.unify-eq In (NewMorph In1) ok, - !, - % TODO: for concrete additive functions, should we unpack [NewMorph]? - quote.zmod U TR (x\ Morph (NewMorph x)) In1 OutM Out VarMap. -% variables -quote.ring R _ _ Morph In {{ @RX lp:R lp:In }} Out VarMap :- !, - mem VarMap (Morph In) N, !, - quote.expr.variable { positive-constant {calc (N + 1)} } Out. -quote.ring _ _ _ _ In _ _ _ :- coq.error "Unknown" {coq.term->string In}. -% TODO: converse ring - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Constructor [mk-ring-morphism Ty Morph ComR Env] takes a type [Ty], +% looks for a canonical [comRingType] (or at least [comSemiRingType]) +% on it and returns it in [ComR] as well as packed in a rmorphism +% [Morph] (with the identity function), the result [Env] lists the +% appropriate [target-nmodule], [target-zmodule] and [target-semiring] +% If [field-mode] attempt to fill the field field, otherwise don't even attempt +pred mk-ring-morphism i:term, o:rmorphism, o:term, o:term, o:list prop. +mk-ring-morphism Ty rmorphism-nat {{ semiring_correct }} {{ target_nat }} Env :- + coq.unify-eq Ty {{ nat }} ok, !, + canonical-nat-nmodule NatNmodule, + canonical-nat-semiring NatSemiRing, + semiring-env SREnv, + Env = [target-nmodule (global (const NatNmodule)), + target-semiring (global (const NatSemiRing)) | SREnv]. +mk-ring-morphism Ty rmorphism-N {{ semiring_correct }} {{ target_N }} Env :- + coq.unify-eq Ty {{ N }} ok, !, + canonical-N-nmodule NNmodule, + canonical-N-semiring NSemiRing, + semiring-env SREnv, + Env = [target-nmodule (global (const NNmodule)), + target-semiring (global (const NSemiRing)) | SREnv]. +mk-ring-morphism Ty rmorphism-int {{ ring_correct }} {{ target_int }} Env :- + coq.unify-eq Ty {{ int }} ok, !, + canonical-int-nmodule IntNmodule, + canonical-int-semiring IntSemiRing, + canonical-int-zmodule IntZmodule, + ring-env REnv, + Env = [target-nmodule (global (const IntNmodule)), + target-semiring (global (const IntSemiRing)), + target-zmodule (global (const IntZmodule)) | REnv]. +mk-ring-morphism Ty rmorphism-Z {{ ring_correct }} {{ target_Z }} Env :- + coq.unify-eq Ty {{ Z }} ok, !, + canonical-Z-nmodule ZNmodule, + canonical-Z-semiring ZSemiRing, + canonical-Z-zmodule ZZmodule, + ring-env REnv, + Env = [target-nmodule (global (const ZNmodule)), + target-semiring (global (const ZSemiRing)), + target-zmodule (global (const ZZmodule)) | REnv]. +mk-ring-morphism Ty (rmorphism U V' SR R' UR' none (x\ x)) Lem CR Env :- !, + std.assert-ok! (coq.unify-eq Ty {{ GRing.Nmodule.sort lp:U }}) + "Cannot find a declared nmodType", + std.assert-ok! (coq.unify-eq Ty {{ GRing.SemiRing.sort lp:SR }}) + "Cannot find a declared semiRingType", + if (coq.unify-eq Ty {{ GRing.Zmodule.sort lp:V }} ok, + coq.unify-eq Ty {{ GRing.Ring.sort lp:R }} ok) + % if the target is a ring + (V' = some V, R' = some R, + if (coq.unify-eq Ty {{ GRing.UnitRing.sort lp:UR }} ok) + (UR' = some UR) (UR' = none), + Lem = {{ ring_correct }}, + std.assert-ok! (coq.unify-eq Ty {{ GRing.ComRing.sort lp:CR' }}) + "Cannot find a declared comRingType", + CR = {{ target_other_comRing lp:CR' }}, + ring-env REnv, + Env = [target-nmodule U, target-semiring SR, target-zmodule V | REnv]) + % if the target is a semiring + (V' = none, R' = none, UR' = none, + Lem = {{ semiring_correct }}, + std.assert-ok! (coq.unify-eq Ty {{ GRing.ComSemiRing.sort lp:CR' }}) + "Cannot find a declared comSemiRingType", + CR = {{ target_other_comSemiRing lp:CR' }}, + semiring-env SREnv, + Env = [target-nmodule U, target-semiring SR | SREnv]). + +pred mk-field-morphism + i:term, o:rmorphism, o:term, o:term, o:list prop, o:list prop. +mk-field-morphism + Ty (rmorphism U (some V) SR (some R) (some UR) (some F) (x\ x)) Lem Field + [target-nmodule U, target-semiring SR, target-zmodule V | REnv] + [field-mode, target-nmodule U, target-semiring SR, target-zmodule V | FEnv] :- + std.do! [ + std.assert-ok! (coq.unify-eq Ty {{ GRing.Nmodule.sort lp:U }}) + "Cannot find a declared nmodType", + std.assert-ok! (coq.unify-eq Ty {{ GRing.Zmodule.sort lp:V }}) + "Cannot find a declared zmodType", + std.assert-ok! (coq.unify-eq Ty {{ GRing.SemiRing.sort lp:SR }}) + "Cannot find a declared semiRingType", + std.assert-ok! (coq.unify-eq Ty {{ GRing.Ring.sort lp:R }}) + "Cannot find a declared ringType", + std.assert-ok! (coq.unify-eq Ty {{ GRing.UnitRing.sort lp:UR }}) + "Cannot find a declared unitRingType", + std.assert-ok! (coq.unify-eq Ty {{ GRing.Field.sort lp:F }}) + "Cannot find a declared fieldType", + (coq.unify-eq Ty {{ Num.NumField.sort lp:Field }} ok, + Lem = {{ numField_correct }}; + Field = F, Lem = {{ field_correct }}), + ring-env REnv, + field-env FEnv ]. + +pred semiring-env o:list prop. +semiring-env + [(pi In\ quote.build.variable In {{ @PEX N lp:In }} :- !), + (quote.build.zero {{ @PEO N }} :- !), + (pi In\ quote.build.opp In {{ @PEopp N lp:In }} :- !), + (pi In1 In2\ quote.build.add In1 In2 {{ @PEadd N lp:In1 lp:In2 }} :- !), + (pi In1 In2\ quote.build.sub In1 In2 {{ @PEsub N lp:In1 lp:In2 }} :- !), + (quote.build.one {{ @PEI N }} :- !), + (pi In1 In2\ quote.build.mul In1 In2 {{ @PEmul N lp:In1 lp:In2 }} :- !), + (pi In1 In2\ + quote.build.exp In1 In2 {{ @PEpow N lp:In1 lp:In2 }} :- !), + (pi In\ quote.build.N-constant In {{ @PEc N lp:In }} :- !)] :- !. + +pred ring-env o:list prop. +ring-env + [(pi In\ quote.build.variable In {{ @PEX Z lp:In }} :- !), + (quote.build.zero {{ @PEO Z }} :- !), + (pi In\ quote.build.opp In {{ @PEopp Z lp:In }} :- !), + (pi In1 In2\ quote.build.add In1 In2 {{ @PEadd Z lp:In1 lp:In2 }} :- !), + (pi In1 In2\ quote.build.sub In1 In2 {{ @PEsub Z lp:In1 lp:In2 }} :- !), + (quote.build.one {{ @PEI Z }} :- !), + (pi In1 In2\ quote.build.mul In1 In2 {{ @PEmul Z lp:In1 lp:In2 }} :- !), + (pi In1 In2\ quote.build.exp In1 In2 {{ @PEpow Z lp:In1 lp:In2 }} :- !), + (pi In\ quote.build.Z-constant In {{ @PEc Z lp:In }} :- !), + (quote.build.N-constant {{ N0 }} {{ @PEc Z Z0 }} :- !), + (pi In\ + quote.build.N-constant {{ Npos lp:In }} {{ @PEc Z (Zpos lp:In) }} :- !)] + :- !. + +pred field-env o:list prop. +field-env + [(pi In\ quote.build.variable In {{ @FEX Z lp:In }} :- !), + (quote.build.zero {{ @FEO Z }} :- !), + (pi In\ quote.build.opp In {{ @FEopp Z lp:In }} :- !), + (pi In1 In2\ quote.build.add In1 In2 {{ @FEadd Z lp:In1 lp:In2 }} :- !), + (pi In1 In2\ quote.build.sub In1 In2 {{ @FEsub Z lp:In1 lp:In2 }} :- !), + (quote.build.one {{ @FEI Z }} :- !), + (pi In1 In2\ quote.build.mul In1 In2 {{ @FEmul Z lp:In1 lp:In2 }} :- !), + (pi In1 In2\ quote.build.exp In1 In2 {{ @FEpow Z lp:In1 lp:In2 }} :- !), + (pi In\ quote.build.inv In {{ @FEinv Z lp:In }} :- !), + (pi In\ quote.build.Z-constant In {{ @FEc Z lp:In }} :- !), + (quote.build.N-constant {{ N0 }} {{ @FEc Z Z0 }} :- !), + (pi In\ + quote.build.N-constant {{ Npos lp:In }} {{ @FEc Z (Zpos lp:In) }} :- !)] + :- !. pred if-verbose i:prop. if-verbose P :- get-option "verbose" tt, !, P. if-verbose _. -pred quote-arg i:term, o:list term, i:argument, o:pair term term. -quote-arg Ring VarMap (trm Proof) +pred quote-arg i:term, i:rmorphism, o:list term, i:argument, o:pair term term. +quote-arg Ty C VM (trm Proof) (pr {{ (lp:RE1, lp:RE2, lp:PE1, lp:PE2) }} Proof) :- std.do! [ @ltacfail! 0 => std.assert-ok! - (coq.typecheck Proof {{ @eq (GRing.Ring.sort lp:Ring) lp:T1 lp:T2 }}) + (coq.typecheck Proof {{ @eq lp:Ty lp:T1 lp:T2 }}) "An argument is not a proof of equation of the expected type", - quote.ring Ring none Ring (x\ x) T1 RE1 PE1 VarMap, - quote.ring Ring none Ring (x\ x) T2 RE2 PE2 VarMap ]. + quote.ring C T1 RE1 PE1 VM, + quote.ring C T2 RE2 PE2 VM ]. pred list->conj i:list term, o:term. list->conj [] {{ I }} :- !. list->conj [P|PS] {{ conj lp:P lp:IS }} :- !, list->conj PS IS. -pred ring-reflection i:term, i:term, i:term, i:term, i:term, i:term, - i:term, i:term, i:goal, o:list sealed-goal. -ring-reflection ComRing VarMap' Lpe' RE1 RE2 PE1 PE2 LpeProofs' G GS :- - coq.ltac.call "ring_reflection" - [trm ComRing, trm VarMap', trm Lpe', trm RE1, trm RE2, trm PE1, trm PE2, - trm LpeProofs'] G GS. -ring-reflection _ _ _ _ _ _ _ _ _ _ :- - coq.ltac.fail 0 "Not a valid ring equation". +pred coq.ltac.call-with-error + i:string, i:list argument, i:string, i:goal, o:list sealed-goal. +coq.ltac.call-with-error Tac Args _ G GS :- coq.ltac.call Tac Args G GS. +coq.ltac.call-with-error _ _ Err _ _ :- coq.ltac.fail 0 Err. pred ring i:goal, o:list sealed-goal. ring (goal _ _ P _ Args as G) GS :- @@ -379,38 +164,27 @@ ring (goal _ _ P _ Args as G) GS :- @ltacfail! 0 => std.assert-ok! (coq.unify-eq P {{ @eq lp:Ty lp:T1 lp:T2 }}) "The goal is not an equation", - @ltacfail! 0 => std.assert-ok! - (coq.unify-eq Ty {{ GRing.Ring.sort lp:Ring }}) - "Cannot find a declared ringType", - @ltacfail! 0 => std.assert-ok! - (coq.unify-eq Ty {{ GRing.ComRing.sort lp:ComRing }}) - "Cannot find a declared comRingType", - std.time ( - std.unzip { std.map Args (quote-arg Ring VarMap) } Lpe LpeProofs, - quote.ring Ring none Ring (x\ x) T1 RE1 PE1 VarMap, - quote.ring Ring none Ring (x\ x) T2 RE2 PE2 VarMap + @ltacfail! 0 => mk-ring-morphism Ty C Lem ComRing Env, + Env => std.time ( + std.unzip { std.map Args (quote-arg Ty C VM) } Lpe LpeProofs, + quote.ring C T1 RE1 PE1 VM, + quote.ring C T2 RE2 PE2 VM ) ReifTime, if-verbose (coq.say "Reification:" ReifTime "sec."), - list-constant Ty VarMap VarMap', + list-constant Ty VM VM', list-constant _ Lpe Lpe', std.assert-ok! (coq.typecheck Lpe' _) "Ill-typed term", list->conj LpeProofs LpeProofs', std.assert-ok! (coq.typecheck LpeProofs' _) "Ill-typed equations", std.time ( - ring-reflection ComRing VarMap' Lpe' RE1 RE2 PE1 PE2 LpeProofs' G GS + coq.ltac.call-with-error "ring_reflection" + [trm Lem, trm ComRing, trm VM', trm Lpe', + trm RE1, trm RE2, trm PE1, trm PE2, trm LpeProofs'] + "Not a valid ring equation" G GS ) ReflTime, if-verbose (coq.say "Reflection:" ReflTime "sec."), ]. -pred field-reflection i:term, i:term, i:term, i:term, i:term, i:term, - i:term, i:term, i:goal, o:list sealed-goal. -field-reflection Field VarMap' Lpe' RE1 RE2 PE1 PE2 LpeProofs' G GS :- - coq.ltac.call "field_reflection" - [trm Field, trm VarMap', trm Lpe', trm RE1, trm RE2, trm PE1, trm PE2, - trm LpeProofs'] G GS. -field-reflection _ _ _ _ _ _ _ _ _ _ :- - coq.ltac.fail 0 "Not a valid ring equation". - pred field i:goal, o:list sealed-goal. field (goal _ _ P _ Args as G) GS :- attributes A, !, @@ -419,28 +193,25 @@ field (goal _ _ P _ Args as G) GS :- @ltacfail! 0 => std.assert-ok! (coq.unify-eq P {{ @eq lp:Ty lp:T1 lp:T2 }}) "The goal is not an equation", - @ltacfail! 0 => std.assert-ok! - (coq.unify-eq Ty {{ GRing.Ring.sort lp:Ring }}) - "Cannot find a declared ringType", - @ltacfail! 0 => std.assert-ok! - (coq.unify-eq Ty {{ GRing.Field.sort lp:Field }}) - "Cannot find a declared fieldType", - coq.unify-eq Ty {{ Num.NumField.sort lp:NField }} NFieldDiag, + @ltacfail! 0 => mk-field-morphism Ty C Lem Field REnv FEnv, std.time ( - std.unzip { std.map Args (quote-arg Ring VarMap) } Lpe LpeProofs, - field-mode => quote.ring Ring (some Field) Ring (x\ x) T1 RE1 PE1 VarMap, - field-mode => quote.ring Ring (some Field) Ring (x\ x) T2 RE2 PE2 VarMap + REnv => + std.unzip { std.map Args (quote-arg Ty { rmorphism-rm-field C } VM) } + Lpe LpeProofs, + FEnv => quote.ring C T1 RE1 PE1 VM, + FEnv => quote.ring C T2 RE2 PE2 VM ) ReifTime, if-verbose (coq.say "Reification:" ReifTime "sec."), - list-constant Ty VarMap VarMap', + list-constant Ty VM VM', list-constant _ Lpe Lpe', std.assert-ok! (coq.typecheck Lpe' _) "Ill-typed term", list->conj LpeProofs LpeProofs', std.assert-ok! (coq.typecheck LpeProofs' _) "Ill-typed equations", std.time ( - if (NFieldDiag = ok) - (field-reflection NField VarMap' Lpe' RE1 RE2 PE1 PE2 LpeProofs' G GS) - (field-reflection Field VarMap' Lpe' RE1 RE2 PE1 PE2 LpeProofs' G GS) + coq.ltac.call-with-error "field_reflection" + [trm Lem, trm Field, trm VM', trm Lpe', + trm RE1, trm RE2, trm PE1, trm PE2, trm LpeProofs'] + "Not a valid field equation" G GS ) ReflTime, if-verbose (coq.say "Reflection:" ReflTime "sec."), ]. diff --git a/theories/ring.v b/theories/ring.v index 3af72a2..afedb5c 100644 --- a/theories/ring.v +++ b/theories/ring.v @@ -1,4 +1,4 @@ -From elpi Require Export elpi. +From elpi Require Import elpi. From Coq Require Import ZArith Ring Ring_polynom Field_theory. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat choice seq. From mathcomp Require Import fintype finfun bigop order ssralg ssrnum ssrint. @@ -19,361 +19,159 @@ Local Open Scope ring_scope. Module Import Internals. -Definition quote_icstr_helper (n : int) : bool * N := - match n with - | Posz n => (true, N.of_nat n) - | Negz n => (false, N.of_nat n) - end. - -Definition quote_Z_pow_helper (n : Z) : option N := - match n with - | Zpos n => Some (Npos n) - | Z0 => Some N0 - | _ => None - end. - -Implicit Types (V : zmodType) (R : ringType) (F : fieldType). +Implicit Types (V : nmodType) (R : semiRingType) (F : fieldType). (* Pushing down morphisms in ring and field expressions by reflection *) -Inductive NExpr : Type := - | NC of large_nat - | NX of nat - | NAdd of NExpr & NExpr - | NSucc of NExpr - | NMul of NExpr & NExpr - | NExp of NExpr & large_nat. - -Fixpoint Neval (e : NExpr) : nat := - match e with - | NC n => nat_of_large_nat n - | NX x => x - | NAdd e1 e2 => Neval e1 + Neval e2 - | NSucc e => S (Neval e) - | NMul e1 e2 => Neval e1 * Neval e2 - | NExp e1 n => Neval e1 ^ nat_of_large_nat n +Fixpoint Reval_eqs C R (lpe : list (RExpr R * RExpr R * PExpr C * PExpr C)) : + Prop := + if lpe is (lhs, rhs, _, _) :: lpe then + Reval lhs = Reval rhs /\ Reval_eqs lpe else True. + +Variant target_comSemiRing := + | target_nat + | target_N + | target_other_comSemiRing of comSemiRingType. + +Local Coercion target_comSemiRingType (R : target_comSemiRing) : + comSemiRingType := + match R with + | target_nat => nat + | target_N => N + | target_other_comSemiRing R => R end. -Inductive RExpr : ringType -> Type := - | RX R : R -> RExpr R - | R0 R : RExpr R - | ROpp R : RExpr R -> RExpr R - | RZOpp : RExpr [ringType of Z] -> RExpr [ringType of Z] - | RAdd R : RExpr R -> RExpr R -> RExpr R - | RZAdd : RExpr [ringType of Z] -> RExpr [ringType of Z] -> - RExpr [ringType of Z] - | RZSub : RExpr [ringType of Z] -> RExpr [ringType of Z] -> - RExpr [ringType of Z] - | RMuln R : RExpr R -> NExpr -> RExpr R - | RMulz R : RExpr R -> RExpr [ringType of int] -> RExpr R - | R1 R : RExpr R - | RMul R : RExpr R -> RExpr R -> RExpr R - | RZMul : RExpr [ringType of Z] -> RExpr [ringType of Z] -> - RExpr [ringType of Z] - | RExpn R : RExpr R -> large_nat -> RExpr R - | RExpPosz (R : unitRingType) : RExpr R -> large_nat -> RExpr R - | RExpNegz F : RExpr F -> large_nat -> RExpr F - | RZExp : RExpr [ringType of Z] -> Z -> RExpr [ringType of Z] - | RInv F : RExpr F -> RExpr F - | RMorph R' R : {rmorphism R' -> R} -> RExpr R' -> RExpr R - | RMorph' V R : {additive V -> R} -> ZMExpr V -> RExpr R - | RPosz : NExpr -> RExpr [ringType of int] - | RNegz : NExpr -> RExpr [ringType of int] - | RZC : Z -> RExpr [ringType of Z] -with ZMExpr : zmodType -> Type := - | ZMX V : V -> ZMExpr V - | ZM0 V : ZMExpr V - | ZMOpp V : ZMExpr V -> ZMExpr V - | ZMAdd V : ZMExpr V -> ZMExpr V -> ZMExpr V - | ZMMuln V : ZMExpr V -> NExpr -> ZMExpr V - | ZMMulz V : ZMExpr V -> RExpr [ringType of int] -> ZMExpr V - | ZMMorph V' V : {additive V' -> V} -> ZMExpr V' -> ZMExpr V. - -Scheme RExpr_ind' := Induction for RExpr Sort Prop - with ZMExpr_ind' := Induction for ZMExpr Sort Prop. - -Fixpoint Reval R (e : RExpr R) : R := - match e with - | RX _ x => x - | R0 _ => 0%R - | ROpp _ e1 => - Reval e1 - | RZOpp e1 => Z.opp (Reval e1) - | RAdd _ e1 e2 => Reval e1 + Reval e2 - | RZAdd e1 e2 => Z.add (Reval e1) (Reval e2) - | RZSub e1 e2 => Z.sub (Reval e1) (Reval e2) - | RMuln _ e1 e2 => Reval e1 *+ Neval e2 - | RMulz _ e1 e2 => Reval e1 *~ Reval e2 - | R1 _ => 1%R - | RMul _ e1 e2 => Reval e1 * Reval e2 - | RZMul e1 e2 => Z.mul (Reval e1) (Reval e2) - | RExpn _ e1 n => Reval e1 ^+ nat_of_large_nat n - | RExpPosz _ e1 n => Reval e1 ^ Posz (nat_of_large_nat n) - | RExpNegz _ e1 n => Reval e1 ^ Negz (nat_of_large_nat n) - | RZExp e1 n => Z.pow (Reval e1) n - | RInv _ e1 => (Reval e1)^-1 - | RMorph _ _ f e1 => f (Reval e1) - | RMorph' _ _ f e1 => f (ZMeval e1) - | RPosz e1 => Posz (Neval e1) - | RNegz e2 => Negz (Neval e2) - | RZC x => x - end -with ZMeval V (e : ZMExpr V) : V := - match e with - | ZMX _ x => x - | ZM0 _ => 0%R - | ZMOpp _ e1 => - ZMeval e1 - | ZMAdd _ e1 e2 => ZMeval e1 + ZMeval e2 - | ZMMuln _ e1 e2 => ZMeval e1 *+ Neval e2 - | ZMMulz _ e1 e2 => ZMeval e1 *~ Reval e2 - | ZMMorph _ _ f e1 => f (ZMeval e1) +Definition target_comSemiRingMorph (R : target_comSemiRing) : R -> R := + match R with + | target_nat => GRing.natmul 1 + | target_N => fun n => (N.to_nat n)%:R + | target_other_comSemiRing _ => id end. -Fixpoint interp_RElist - R (lpe : list (RExpr R * RExpr R * PExpr Z * PExpr Z)) : Prop := - if lpe is (lhs, rhs, _, _) :: lpe then - Reval lhs = Reval rhs /\ interp_RElist lpe else True. +Variant target_comRing := + | target_int + | target_Z + | target_other_comRing of comRingType. -Section Rnorm. +Local Coercion target_comRingType (R : target_comRing) : comRingType := + match R with + | target_int => int + | target_Z => Z + | target_other_comRing R => R + end. -Variables (R' : ringType). -Variables (R_of_Z : Z -> R') (R_of_ZE : R_of_Z = (fun n => (int_of_Z n)%:~R)). -Variables (zero : R') (zeroE : zero = 0%R) (opp : R' -> R') (oppE : opp = -%R). -Variables (add : R' -> R' -> R') (addE : add = +%R). -Variables (sub : R' -> R' -> R') (subE : sub = (fun x y => x - y)). -Variables (one : R') (oneE : one = 1%R). -Variables (mul : R' -> R' -> R') (mulE : mul = *%R). -Variables (exp : R' -> N -> R') (expE : exp = (fun x n => x ^+ nat_of_N n)). - -Fixpoint Nnorm (e : NExpr) : R' := - match e with - | NC n => R_of_Z (Z_of_large_nat n) - | NX x => x%:~R - | NAdd e1 e2 => add (Nnorm e1) (Nnorm e2) - | NSucc e1 => add one (Nnorm e1) - | NMul e1 e2 => mul (Nnorm e1) (Nnorm e2) - | NExp e1 n => exp (Nnorm e1) (N_of_large_nat n) +Definition target_comRingMorph (R : target_comRing) : R -> R := + match R with + | target_int => intr + | target_Z => fun n => (int_of_Z n)%:~R + | target_other_comRing _ => id end. -Lemma Nnorm_correct (e : NExpr) : (Neval e)%:R = Nnorm e. -Proof. -elim: e => //=. -- by move=> n; rewrite R_of_ZE large_nat_Z_int. -- by move=> e1 IHe1 e2 IHe2; rewrite addE natrD IHe1 IHe2. -- by move=> e IHe; rewrite addE oneE mulrS IHe. -- by move=> e1 IHe1 e2 IHe2; rewrite mulE natrM IHe1 IHe2. -- by move=> e1 IHe1 e2; rewrite expE natrX IHe1 large_nat_N_nat. -Qed. +Section Snorm. -Fixpoint Rnorm R (f : R -> R') (e : RExpr R) : R' := - match e in RExpr R return (R -> R') -> R' with - | RX _ x => fun f => f x - | R0 _ => fun => zero - | ROpp _ e1 => fun f => opp (Rnorm f e1) - | RZOpp e1 => fun f => opp (Rnorm f e1) - | RAdd _ e1 e2 => fun f => add (Rnorm f e1) (Rnorm f e2) - | RZAdd e1 e2 => fun f => add (Rnorm f e1) (Rnorm f e2) - | RZSub e1 e2 => fun f => sub (Rnorm f e1) (Rnorm f e2) - | RMuln _ e1 e2 => fun f => mul (Rnorm f e1) (Nnorm e2) - | RMulz _ e1 e2 => fun f => mul (Rnorm f e1) (Rnorm intr e2) - | R1 _ => fun => one - | RMul _ e1 e2 => fun f => mul (Rnorm f e1) (Rnorm f e2) - | RZMul e1 e2 => fun f => mul (Rnorm f e1) (Rnorm f e2) - | RExpn _ e1 n => fun f => exp (Rnorm f e1) (N_of_large_nat n) - | RExpPosz _ e1 n => fun f => exp (Rnorm f e1) (N_of_large_nat n) - | RExpNegz _ _ _ => fun _ => f (Reval e) - | RZExp e1 (Z.neg _) => fun f => zero - | RZExp e1 n => fun f => exp (Rnorm f e1) (Z.to_N n) - | RInv _ _ => fun _ => f (Reval e) - | RMorph _ _ g e1 => fun f => Rnorm (fun x => f (g x)) e1 - | RMorph' _ _ g e1 => fun f => RZMnorm (fun x => f (g x)) e1 - | RPosz e1 => fun => Nnorm e1 - | RNegz e1 => fun => opp (add one (Nnorm e1)) - | RZC x => fun => R_of_Z x - end f -with RZMnorm V (f : V -> R') (e : ZMExpr V) : R' := - match e in ZMExpr V return (V -> R') -> R' with - | ZMX _ x => fun f => f x - | ZM0 _ => fun => zero - | ZMOpp _ e1 => fun f => opp (RZMnorm f e1) - | ZMAdd _ e1 e2 => fun f => add (RZMnorm f e1) (RZMnorm f e2) - | ZMMuln _ e1 e2 => fun f => mul (RZMnorm f e1) (Nnorm e2) - | ZMMulz _ e1 e2 => fun f => mul (RZMnorm f e1) (Rnorm intr e2) - | ZMMorph _ _ g e1 => fun f => RZMnorm (fun x => f (g x)) e1 - end f. - -Fixpoint norm_RElist - (lpe : list (RExpr R' * RExpr R' * PExpr Z * PExpr Z)) : seq R' := +Variables (R' : semiRingType) (R_of_N : N -> R'). +Variables (zero : R') (add : R' -> R' -> R'). +Variables (one : R') (mul : R' -> R' -> R') (exp : R' -> N -> R'). + +Local Notation Snorm := (SemiRing.Rnorm R_of_N zero add one mul exp). + +Fixpoint Snorm_list + (lpe : list (RExpr R' * RExpr R' * PExpr N * PExpr N)) : seq R' := if lpe is (lhs, rhs, _, _) :: lpe then - Rnorm id lhs :: Rnorm id rhs :: norm_RElist lpe + Snorm id lhs :: Snorm id rhs :: Snorm_list lpe else [::]. -Lemma Rnorm_correct_rec R (f : {rmorphism R -> R'}) (e : RExpr R) : - f (Reval e) = Rnorm f e. -Proof. -pose P R e := forall (f : {rmorphism R -> R'}), f (Reval e) = Rnorm f e. -pose P0 V e := forall (f : {additive V -> R'}), f (ZMeval e) = RZMnorm f e. -move: f; elim e using (@RExpr_ind' P P0); rewrite {R e}/P {}/P0 //=. -- by move=> R f; rewrite rmorph0 zeroE. -- by move=> R e1 IHe1 f; rewrite rmorphN IHe1 oppE. -- by move=> e1 IHe1 f; rewrite rmorphN IHe1 oppE. -- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2 addE. -- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2 addE. -- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphB IHe1 IHe2 subE. -- by move=> R e1 IHe1 e2 f; rewrite rmorphMn IHe1 -mulr_natr Nnorm_correct mulE. -- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphMz IHe1 -mulrzr IHe2 mulE. -- by move=> R f; rewrite rmorph1 oneE. -- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2 mulE. -- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2 mulE. -- by move=> R e1 IHe1 e2 f; rewrite rmorphX IHe1 expE large_nat_N_nat. -- by move=> R e1 IHe1 e2 f; rewrite rmorphX IHe1 expE large_nat_N_nat. -- move=> e1 IHe1 [|n|n] f; rewrite !(zeroE, expE, rmorph0, rmorph1) //=. - rewrite -IHe1 -rmorphX; congr (f _); lia. -- by move=> R S g e1 IHe1 f; rewrite -/(comp f g) -IHe1. -- by move=> V R g e1 IHe1 f; rewrite -/(comp f g) -IHe1. -- by move=> e f; rewrite -[Posz _]intz rmorph_int [LHS]Nnorm_correct. -- move=> e f; rewrite -[Negz _]intz rmorph_int /intmul mulrS Nnorm_correct. - by rewrite oppE addE oneE. -- by move=> x f; rewrite R_of_ZE -(rmorph_int f); congr (f _); lia. -- by move=> V f; rewrite raddf0 zeroE. -- by move=> V e1 IHe1 f; rewrite raddfN IHe1 oppE. -- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfD IHe1 IHe2 addE. -- move=> V e1 IHe1 e2 f. - by rewrite raddfMn IHe1 -mulr_natr Nnorm_correct mulE. -- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfMz IHe1 -mulrzr IHe2 mulE. -- by move=> V V' g e1 IHe1 f; rewrite -/(comp f g) -IHe1. -Qed. +End Snorm. -Lemma Rnorm_correct (e : RExpr R') : Reval e = Rnorm id e. -Proof. exact: Rnorm_correct_rec [rmorphism of idfun] _. Qed. +Section Rnorm. -End Rnorm. +Variables (R' : ringType) (R_of_Z : Z -> R'). +Variables (zero : R') (add : R' -> R' -> R'). +Variables (opp : R' -> R') (sub : R' -> R' -> R'). +Variables (one : R') (mul : R' -> R' -> R') (exp : R' -> N -> R'). -Section Fnorm. - -Variables (F : fieldType). -Variables (F_of_Z : Z -> F) (F_of_ZE : F_of_Z = (fun n => (int_of_Z n)%:~R)). -Variables (zero : F) (zeroE : zero = 0%R) (opp : F -> F) (oppE : opp = -%R). -Variables (add : F -> F -> F) (addE : add = +%R). -Variables (sub : F -> F -> F) (subE : sub = (fun x y => x - y)). -Variables (one : F) (oneE : one = 1%R) (mul : F -> F -> F) (mulE : mul = *%R). -Variables (exp : F -> N -> F) (expE : exp = (fun x n => x ^+ nat_of_N n)). -Variables (inv : F -> F) (invE : inv = GRing.inv). - -Notation Nnorm := (Nnorm F_of_Z add one mul exp). -Let Nnorm_correct := (Nnorm_correct F_of_ZE addE oneE mulE expE). - -Fixpoint Fnorm R (f : R -> F) (e : RExpr R) : F := - match e in RExpr R return (R -> F) -> F with - | RX _ x => fun f => f x - | R0 _ => fun => zero - | ROpp _ e1 => fun f => opp (Fnorm f e1) - | RZOpp e1 => fun f => opp (Fnorm f e1) - | RAdd _ e1 e2 => fun f => add (Fnorm f e1) (Fnorm f e2) - | RZAdd e1 e2 => fun f => add (Fnorm f e1) (Fnorm f e2) - | RZSub e1 e2 => fun f => sub (Fnorm f e1) (Fnorm f e2) - | RMuln _ e1 e2 => fun f => mul (Fnorm f e1) (Nnorm e2) - | RMulz _ e1 e2 => fun f => mul (Fnorm f e1) (Fnorm intr e2) - | R1 _ => fun => one - | RMul _ e1 e2 => fun f => mul (Fnorm f e1) (Fnorm f e2) - | RZMul e1 e2 => fun f => mul (Fnorm f e1) (Fnorm f e2) - | RExpn _ e1 n => fun f => exp (Fnorm f e1) (N_of_large_nat n) - | RExpPosz _ e1 n => fun f => exp (Fnorm f e1) (N_of_large_nat n) - | RExpNegz _ e1 n => fun f => - inv (exp (Fnorm f e1) (N.succ (N_of_large_nat n))) - | RZExp e1 (Z.neg _) => fun f => zero - | RZExp e1 n => fun f => exp (Fnorm f e1) (Z.to_N n) - | RInv _ e1 => fun f => inv (Fnorm f e1) - | RMorph _ _ g e1 => fun f => Fnorm (fun x => f (g x)) e1 - | RMorph' _ _ g e1 => fun f => FZMnorm (fun x => f (g x)) e1 - | RPosz e1 => fun => Nnorm e1 - | RNegz e1 => fun => opp (add one (Nnorm e1)) - | RZC x => fun => F_of_Z x - end f -with FZMnorm V (f : V -> F) (e : ZMExpr V) : F := - match e in ZMExpr V return (V -> F) -> F with - | ZMX _ x => fun f => f x - | ZM0 _ => fun => zero - | ZMOpp _ e1 => fun f => opp (FZMnorm f e1) - | ZMAdd _ e1 e2 => fun f => add (FZMnorm f e1) (FZMnorm f e2) - | ZMMuln _ e1 e2 => fun f => mul (FZMnorm f e1) (Nnorm e2) - | ZMMulz _ e1 e2 => fun f => mul (FZMnorm f e1) (Fnorm intr e2) - | ZMMorph _ _ g e1 => fun f => FZMnorm (fun x => f (g x)) e1 - end f. - -Lemma Fnorm_correct_rec R (f : {rmorphism R -> F}) (e : RExpr R) : - f (Reval e) = Fnorm f e. -Proof. -pose P R e := forall (f : {rmorphism R -> F}), f (Reval e) = Fnorm f e. -pose P0 V e := forall (f : {additive V -> F}), f (ZMeval e) = FZMnorm f e. -move: f; elim e using (@RExpr_ind' P P0); rewrite {R e}/P {}/P0 //=. -- by move=> R f; rewrite rmorph0 zeroE. -- by move=> R e1 IHe1 f; rewrite rmorphN IHe1 oppE. -- by move=> e1 IHe1 f; rewrite rmorphN IHe1 oppE. -- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2 addE. -- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphD IHe1 IHe2 addE. -- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphB IHe1 IHe2 subE. -- move=> R e1 IHe1 e2 f. - by rewrite rmorphMn IHe1 -mulr_natr Nnorm_correct mulE. -- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphMz IHe1 -mulrzr IHe2 mulE. -- by move=> R f; rewrite rmorph1 oneE. -- by move=> R e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2 mulE. -- by move=> e1 IHe1 e2 IHe2 f; rewrite rmorphM IHe1 IHe2 mulE. -- by move=> R e1 IHe1 e2 f; rewrite rmorphX IHe1 expE large_nat_N_nat. -- by move=> R e1 IHe1 n f; rewrite rmorphX IHe1 expE large_nat_N_nat. -- move=> R e1 IHe1 n f; rewrite fmorphV rmorphX IHe1 invE expE. - by rewrite Nnat.N2Nat.inj_succ large_nat_N_nat. -- move=> e1 IHe1 [|n|n] f; rewrite ?(zeroE, oneE, expE, rmorph0, rmorph1) //=. - rewrite -IHe1 -rmorphX; congr (f _); lia. -- by move=> F' e1 IHe1 f; rewrite fmorphV IHe1 invE. -- by move=> R R' g e1 IHe1 f; rewrite -/(comp f g) -IHe1. -- by move=> V R g e1 IHe1 f; rewrite -/(comp f g) -IHe1. -- by move=> e f; rewrite -[Posz _]intz rmorph_int [LHS]Nnorm_correct. -- move=> e f; rewrite -[Negz _]intz rmorph_int /intmul mulrS Nnorm_correct. - by rewrite oppE addE oneE. -- by move=> x f; rewrite F_of_ZE -(rmorph_int f); congr (f _); lia. -- by move=> V f; rewrite raddf0 zeroE. -- by move=> V e1 IHe1 f; rewrite raddfN IHe1 oppE. -- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfD IHe1 IHe2 addE. -- by move=> V e1 IHe1 e2 f; rewrite raddfMn IHe1 -mulr_natr Nnorm_correct mulE. -- by move=> V e1 IHe1 e2 IHe2 f; rewrite raddfMz IHe1 -mulrzr IHe2 mulE. -- by move=> V V' g e1 IHe1 f; rewrite -/(comp f g) -IHe1. -Qed. +Local Notation Rnorm := (Ring.Rnorm R_of_Z zero add opp sub one mul exp). -Lemma Fnorm_correct (e : RExpr F) : Reval e = Fnorm id e. -Proof. exact: Fnorm_correct_rec [rmorphism of idfun] _. Qed. +Fixpoint Rnorm_list + (lpe : list (RExpr R' * RExpr R' * PExpr Z * PExpr Z)) : seq R' := + if lpe is (lhs, rhs, _, _) :: lpe then + Rnorm id lhs :: Rnorm id rhs :: Rnorm_list lpe + else + [::]. -End Fnorm. +End Rnorm. (* Normalizing ring and field expressions to the Horner form by reflection *) -Fixpoint interp_PElist - R R_of_Z zero opp add sub one mul exp - (l : seq R) (lpe : list (RExpr R * RExpr R * PExpr Z * PExpr Z)) : seq R := +Fixpoint PEeval_list + C R (R_of_C : C -> R) zero opp add sub one mul exp + (l : seq R) (lpe : list (RExpr R * RExpr R * PExpr C * PExpr C)) : seq R := if lpe is (_, _, lhs, rhs) :: lpe then - PEeval zero one add mul sub opp R_of_Z id exp l lhs :: - PEeval zero one add mul sub opp R_of_Z id exp l rhs :: - interp_PElist R_of_Z zero opp add sub one mul exp l lpe + PEeval zero one add mul sub opp R_of_C id exp l lhs :: + PEeval zero one add mul sub opp R_of_C id exp l rhs :: + PEeval_list R_of_C zero opp add sub one mul exp l lpe else [::]. +Definition Scorrect (R : comSemiRingType) := + let RE := Eq_ext +%R *%R id in + let RN := SRmorph_Rmorph (Eqsth R) (RN R) in + ring_correct (Eqsth R) RE (SRth_ARth (Eqsth R) (RS R)) RN (PN R) + (triv_div_th (Eqsth R) RE (SRth_ARth (Eqsth R) (RS R)) RN). + +Lemma semiring_correct + (R : target_comSemiRing) (n : nat) (l : seq R) + (lpe : seq (RExpr R * RExpr R * PExpr N * PExpr N)) + (re1 re2 : RExpr R) (pe1 pe2 : PExpr N) : + Reval_eqs lpe -> + (forall R_of_N zero add one mul exp, + SemiRing.Rnorm R_of_N zero add one mul exp + (@target_comSemiRingMorph R) re1 :: + SemiRing.Rnorm R_of_N zero add one mul exp + (@target_comSemiRingMorph R) re2 :: + Snorm_list R_of_N zero add one mul exp lpe = + PEeval zero one add mul add id R_of_N id exp l pe1 :: + PEeval zero one add mul add id R_of_N id exp l pe2 :: + PEeval_list R_of_N zero id add add one mul exp l lpe) -> + (let norm_subst' := + norm_subst 0 1 N.add N.mul N.add id N.eqb (triv_div 0 1 N.eqb) n + (mk_monpol_list + 0 1 N.add N.mul N.add id N.eqb (triv_div 0 1 N.eqb) + (map (fun '(_, _, lhs, rhs) => (lhs, rhs)) lpe)) + in + Peq N.eqb (norm_subst' pe1) (norm_subst' pe2)) -> + Reval re1 = Reval re2. +Proof. +move=> Hlpe' /(_ (fun n => (nat_of_N n)%:R) 0%R +%R). +move=> /(_ 1%R *%R (fun x n => x ^+ nat_of_N n)) /=. +have /SemiRing.eq_Rnorm Hnorm: @target_comSemiRingMorph R =1 id. + by case R => //= ?; lia. +rewrite !{}Hnorm -!SemiRing.Rnorm_correct => -[-> -> Hlpe]; apply: Scorrect. +elim: lpe Hlpe Hlpe' => [|[[[{}re1 {}re2] {}pe1] {}pe2] lpe IHlpe] //=. +rewrite /= -!SemiRing.Rnorm_correct //. +by move=> [-> ->] Hlpe [Hpe /(IHlpe Hlpe)] {IHlpe Hlpe} /=; case: lpe. +Qed. + Definition Rcorrect (R : comRingType) := let RE := Eq_ext +%R *%R -%R in ring_correct (Eqsth R) RE (Rth_ARth (Eqsth R) RE (RR R)) (RZ R) (PN R) (triv_div_th (Eqsth R) RE (Rth_ARth (Eqsth R) RE (RR R)) (RZ R)). -Lemma ring_correct (R : comRingType) (n : nat) (l : seq R) +Lemma ring_correct (R : target_comRing) (n : nat) (l : seq R) (lpe : seq (RExpr R * RExpr R * PExpr Z * PExpr Z)) (re1 re2 : RExpr R) (pe1 pe2 : PExpr Z) : - interp_RElist lpe -> + Reval_eqs lpe -> (forall R_of_Z zero opp add sub one mul exp, - Rnorm R_of_Z zero opp add sub one mul exp id re1 :: - Rnorm R_of_Z zero opp add sub one mul exp id re2 :: - norm_RElist R_of_Z zero opp add sub one mul exp lpe = + Ring.Rnorm R_of_Z zero add opp sub one mul exp + (@target_comRingMorph R) re1 :: + Ring.Rnorm R_of_Z zero add opp sub one mul exp + (@target_comRingMorph R) re2 :: + Rnorm_list R_of_Z zero add opp sub one mul exp lpe = PEeval zero one add mul sub opp R_of_Z id exp l pe1 :: PEeval zero one add mul sub opp R_of_Z id exp l pe2 :: - interp_PElist R_of_Z zero opp add sub one mul exp l lpe) -> + PEeval_list R_of_Z zero opp add sub one mul exp l lpe) -> (let norm_subst' := norm_subst 0 1 Z.add Z.mul Z.sub Z.opp Z.eqb (triv_div 0 1 Z.eqb) n (mk_monpol_list @@ -385,9 +183,10 @@ Lemma ring_correct (R : comRingType) (n : nat) (l : seq R) Proof. move=> Hlpe' /(_ (fun n => (int_of_Z n)%:~R) 0%R -%R +%R (fun x y => x - y)). move=> /(_ 1%R *%R (fun x n => x ^+ nat_of_N n)) /=. -rewrite -!Rnorm_correct // => -[-> -> Hlpe]; apply: Rcorrect. +have /Ring.eq_Rnorm Hnorm: @target_comRingMorph R =1 id by case R => //= ?; lia. +rewrite !Hnorm -!Ring.Rnorm_correct => -[-> -> Hlpe]; apply: Rcorrect. elim: lpe Hlpe Hlpe' => [|[[[{}re1 {}re2] {}pe1] {}pe2] lpe IHlpe] //=. -rewrite /= -!Rnorm_correct //. +rewrite /= -!Ring.Rnorm_correct //. by move=> [-> ->] Hlpe [Hpe /(IHlpe Hlpe)] {IHlpe Hlpe} /=; case: lpe. Qed. @@ -454,14 +253,14 @@ Definition Fcorrect F := Lemma field_correct (F : fieldType) (n : nat) (l : seq F) (lpe : seq (RExpr F * RExpr F * PExpr Z * PExpr Z)) (re1 re2 : RExpr F) (fe1 fe2 : FExpr Z) : - interp_RElist lpe -> + Reval_eqs lpe -> (forall R_of_Z zero opp add sub one mul exp div inv, - Fnorm R_of_Z zero opp add sub one mul exp inv id re1 :: - Fnorm R_of_Z zero opp add sub one mul exp inv id re2 :: - norm_RElist R_of_Z zero opp add sub one mul exp lpe = + Field.Rnorm R_of_Z zero add opp sub one mul exp inv id re1 :: + Field.Rnorm R_of_Z zero add opp sub one mul exp inv id re2 :: + Rnorm_list R_of_Z zero add opp sub one mul exp lpe = FEeval zero one add mul sub opp div inv R_of_Z id exp l fe1 :: FEeval zero one add mul sub opp div inv R_of_Z id exp l fe2 :: - interp_PElist R_of_Z zero opp add sub one mul exp l lpe) -> + PEeval_list R_of_Z zero opp add sub one mul exp l lpe) -> (forall is_true_ negb_ andb_ zero one add mul sub opp Feqb F_of_nat exp l', is_true_ = is_true -> negb_ = negb -> andb_ = andb -> zero = 0 -> one = 1 -> add = +%R -> mul = *%R -> @@ -492,12 +291,12 @@ Lemma field_correct (F : fieldType) (n : nat) (l : seq F) Proof. move=> Hlpe' /(_ (fun n => (int_of_Z n)%:~R) 0%R -%R +%R (fun x y => x - y)). move=> /(_ 1%R *%R (fun x n => x ^+ nat_of_N n) (fun x y => x / y) GRing.inv). -rewrite -!Fnorm_correct // => -[-> -> Hlpe]. +rewrite -!Field.Rnorm_correct => -[-> -> Hlpe]. move=> /(_ _ _ _ _ _ _ _ _ _ _ _ _ _ erefl erefl erefl erefl erefl erefl erefl). move=> /(_ _ _ _ _ _ _ erefl erefl erefl erefl erefl erefl) [Heq Hcond]. apply: (Fcorrect _ erefl erefl erefl Heq). - elim: {Heq Hcond}lpe Hlpe Hlpe' => //. - move=> [[[{}re1 {}re2] {}pe1] {}pe2] lpe IHlpe; rewrite /= -!Rnorm_correct //. + elim: {Heq Hcond}lpe Hlpe Hlpe' => // -[[[{}re1 {}re2] {}pe1] {}pe2]. + move=> lpe IHlpe /=; rewrite -!Ring.Rnorm_correct. by move=> [-> ->] Hlpe [Hpe /(IHlpe Hlpe)] {IHlpe Hlpe} /=; case: lpe. by apply: Pcond_simpl_gen; [ exact: Eq_ext | exact/F2AF/RF/Eq_ext | exact: RZ | exact: PN | @@ -508,14 +307,14 @@ Qed. Lemma numField_correct (F : numFieldType) (n : nat) (l : seq F) (lpe : seq (RExpr F * RExpr F * PExpr Z * PExpr Z)) (re1 re2 : RExpr F) (fe1 fe2 : FExpr Z) : - interp_RElist lpe -> + Reval_eqs lpe -> (forall R_of_Z zero opp add sub one mul exp div inv, - Fnorm R_of_Z zero opp add sub one mul exp inv id re1 :: - Fnorm R_of_Z zero opp add sub one mul exp inv id re2 :: - norm_RElist R_of_Z zero opp add sub one mul exp lpe = + Field.Rnorm R_of_Z zero add opp sub one mul exp inv id re1 :: + Field.Rnorm R_of_Z zero add opp sub one mul exp inv id re2 :: + Rnorm_list R_of_Z zero add opp sub one mul exp lpe = FEeval zero one add mul sub opp div inv R_of_Z id exp l fe1 :: FEeval zero one add mul sub opp div inv R_of_Z id exp l fe2 :: - interp_PElist R_of_Z zero opp add sub one mul exp l lpe) -> + PEeval_list R_of_Z zero opp add sub one mul exp l lpe) -> (forall is_true_ negb_ andb_ zero one add mul sub opp Feqb F_of_nat exp l', is_true_ = is_true -> negb_ = negb -> andb_ = andb -> zero = 0 -> one = 1 -> add = +%R -> mul = *%R -> @@ -546,12 +345,12 @@ Lemma numField_correct (F : numFieldType) (n : nat) (l : seq F) Proof. move=> Hlpe' /(_ (fun n => (int_of_Z n)%:~R) 0%R -%R +%R (fun x y => x - y)). move=> /(_ 1%R *%R (fun x n => x ^+ nat_of_N n) (fun x y => x / y) GRing.inv). -rewrite -!Fnorm_correct // => -[-> -> Hlpe]. +rewrite -!Field.Rnorm_correct => -[-> -> Hlpe]. move=> /(_ _ _ _ _ _ _ _ _ _ _ _ _ _ erefl erefl erefl erefl erefl erefl erefl). move=> /(_ _ _ _ _ _ _ erefl erefl erefl erefl erefl erefl) [Heq Hcond]. apply: (Fcorrect _ erefl erefl erefl Heq). - elim: {Heq Hcond}lpe Hlpe Hlpe' => //. - move=> [[[{}re1 {}re2] {}pe1] {}pe2] lpe IHlpe; rewrite /= -!Rnorm_correct //. + elim: {Heq Hcond}lpe Hlpe Hlpe' => // -[[[{}re1 {}re2] {}pe1] {}pe2]. + move=> lpe IHlpe /=; rewrite -!Ring.Rnorm_correct. by move=> [-> ->] Hlpe [Hpe /(IHlpe Hlpe)] {IHlpe Hlpe} /=; case: lpe. apply: Pcond_simpl_complete; [ exact: Eq_ext | exact/F2AF/RF/Eq_ext | exact: RZ | exact: PN | @@ -603,38 +402,28 @@ End Internals. (* Auxiliary Ltac code which will be invoked from Elpi *) -Ltac ring_reflection_check R VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs := - refine (@ring_correct R 100%N VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs - (fun _ _ _ _ _ _ _ _ => erefl) _); +Ltac ring_reflection_check Lem R VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs := + refine (Lem R 100%N VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs + (fun _ _ _ _ _ _ _ _ => erefl) _); [ vm_compute; reflexivity ]. -Ltac ring_reflection_no_check R VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs := - exact_no_check (@ring_correct +Ltac ring_reflection_no_check Lem R VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs := + exact_no_check (Lem R 100%N VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs (fun _ _ _ _ _ _ _ _ => ltac:(reflexivity_no_check)) ltac:(vm_compute; reflexivity)). Ltac ring_reflection := ring_reflection_check. -Ltac field_reflection_check F VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs := - let refl_lemma := - match type of F with - numFieldType => constr:(@numField_correct) | _ => constr:(@field_correct) - end - in - refine (refl_lemma F 100%N VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs - (fun _ _ _ _ _ _ _ _ _ _ => erefl) _); +Ltac field_reflection_check Lem F VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs := + refine (Lem F 100%N VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs + (fun _ _ _ _ _ _ _ _ _ _ => erefl) _); field_normalization. -Ltac field_reflection_no_check F VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs := - let refl_lemma := - match type of F with - numFieldType => constr:(@numField_correct) | _ => constr:(@field_correct) - end - in +Ltac field_reflection_no_check Lem F VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs := let obligation := fresh in eassert (obligation : _); - [ | exact_no_check (refl_lemma + [ | exact_no_check (Lem F 100%N VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs (fun _ _ _ _ _ _ _ _ _ _ => ltac:(reflexivity_no_check)) ltac:(field_normalization; exact obligation)) ]. @@ -642,13 +431,14 @@ Ltac field_reflection_no_check F VarMap Lpe RE1 RE2 PE1 PE2 LpeProofs := Ltac field_reflection := field_reflection_check. Strategy expand [addn_expand nat_of_pos_rec_expand nat_of_pos_expand]. -Strategy expand [nat_of_N_expand int_of_Z_expand Z_of_N_expand]. +Strategy expand [nat_of_N_expand]. Strategy expand [nat_of_large_nat N_of_large_nat Z_of_large_nat]. -Strategy expand [int_of_large_int Z_of_large_int]. -Strategy expand [Neval Reval Nnorm Rnorm Fnorm PEeval FEeval]. +Strategy expand [Reval Meval SemiRing.Rnorm SemiRing.Mnorm]. +Strategy expand [Ring.Rnorm Ring.Mnorm Field.Rnorm Field.Mnorm PEeval FEeval]. Elpi Tactic ring. +Elpi Accumulate Db canonicals.db. Elpi Accumulate File common ring ring_tac. Elpi Typecheck. @@ -659,6 +449,7 @@ Tactic Notation "#[" attributes(A) "]" "ring" ":" ne_constr_list(L) := ltac_attributes:(A) elpi ring ltac_term_list:(L). Elpi Tactic field. +Elpi Accumulate Db canonicals.db. Elpi Accumulate File common ring field_tac. Elpi Typecheck. @@ -668,3 +459,5 @@ Tactic Notation "#[" attributes(A) "]" "field" := ltac_attributes:(A) elpi field. Tactic Notation "#[" attributes(A) "]" "field" ":" ne_constr_list(L) := ltac_attributes:(A) elpi field ltac_term_list:(L). + +Elpi Query lp:{{ canonical-init library "canonicals.db" }}.