diff --git a/_CoqProject b/_CoqProject index 1caabc13..ca5b1801 100644 --- a/_CoqProject +++ b/_CoqProject @@ -4,12 +4,10 @@ -arg -w -arg -ambiguous-paths -arg -w -arg -notation-incompatible-format -lib/ssrZ.v -lib/ssrR.v +lib/coqRE.v lib/realType_ext.v -lib/Reals_ext.v -lib/logb.v -lib/Ranalysis_ext.v +lib/realType_ln.v +lib/derive_ext.v lib/ssr_ext.v lib/f2.v lib/ssralg_ext.v @@ -31,7 +29,6 @@ probability/convex_stone.v probability/jfdist_cond.v probability/graphoid.v probability/jensen.v -probability/ln_facts.v probability/divergence.v probability/variation_dist.v probability/log_sum.v diff --git a/changelog.txt b/changelog.txt index ea75f1c2..24c7660d 100644 --- a/changelog.txt +++ b/changelog.txt @@ -1,3 +1,24 @@ +-------------------- +from 0.7.7 to master +-------------------- + +* changed: + almost no stdlib R anymore + +* added: +- in bigop_ext.v + + lemmas morphs_oppr, morph_mulRDr, bigmax_le_seq, bigmax_leP_seq, + bigmax_gt0P_seq, big_union_nondisj +- in derive_ext.v + + lemmas open_norm_subball, + near_eq_derive, near_eq_derivable, near_eq_is_derive +- in realType_ext.v + + lemmas wpmulr_lgt0, wpmulr_rgt0 +- in ssr_ext.v + + lemma eqW + + setY* (symmetric difference for finite sets), notation: "A :*: B" + + ------------------- from 0.7.6 to 0.7.7 ------------------- @@ -25,6 +46,16 @@ from 0.7.3 to 0.7.4 ------------------- from 0.7.2 to 0.7.3 ------------------- +* added: +- in ssralg_ext.v + + lemmas mulr_regl, mulr_regr +- in realType_ext.v + + lemmas x_x2_eq, x_x2_max, x_x2_pos, x_x2_nneg, expR1_gt2 +- new file derive_ext.v + + lemmas differentiable_{ln, Log} + + lemmas is_derive{D, B, N, M, V, Z, X, _sum}_eq + + lemmas is_derive1_{lnf, lnf_eq, Logf, Logf_eq, LogfM, LogfM_eq, LogfV, LogfV_eq} + + lemmas derivable1_mono, derivable1_homo - lemma `conv_pt_cset_is_convex` changed into a `Let` diff --git a/ecc_classic/bch.v b/ecc_classic/bch.v index cb19e791..09d25c18 100644 --- a/ecc_classic/bch.v +++ b/ecc_classic/bch.v @@ -43,9 +43,7 @@ Unset Printing Implicit Defensive. Import GRing.Theory. Local Open Scope ring_scope. - Local Open Scope vec_ext_scope. - Local Open Scope dft_scope. Module BCH. @@ -114,7 +112,7 @@ have j2t : (j.-1)./2 < t.*2. destruct j => //. by rewrite /= (ltn_trans i1) // ltnS muln2 -[in X in _ <= X]addnn leq_addl. move/(_ j2t)/(congr1 (fun x => x ^+ 2)). -rewrite expr0n /= sum_char2 ?char_GFqm // => H'. +rewrite expr0n /= sum_sqr ?char_GFqm // => H'. rewrite -[RHS]H'; apply eq_bigr => k _. rewrite exprMn_comm; last by rewrite /GRing.comm mulrC. congr (_ * _); last first. @@ -140,31 +138,27 @@ apply/idP/idP. apply BCH_PCM_altP1 => i. move/eqP/rowP : H => /(_ i). rewrite !mxE => H; rewrite -[RHS]H. - apply eq_bigr => /= k _; by rewrite !mxE /= mulrC. + by apply eq_bigr => /= k _; rewrite !mxE /= mulrC. - rewrite /BCH.PCM_alt /BCH.PCM /syndrome => H. apply/eqP/rowP => i. have @j : 'I_t.*2. - refine (@Ordinal _ i.*2 _); by rewrite -!muln2 ltn_pmul2r. + by refine (@Ordinal _ i.*2 _); rewrite -!muln2 ltn_pmul2r. move/eqP : H => /matrixP/(_ ord0 j). rewrite !mxE => {2}<-. - apply eq_bigr => k _. - by rewrite !mxE. + by apply eq_bigr => k _; rewrite !mxE. Qed. End BCH_PCM_alt. Section BCH_def. - Variables (n : nat) (m : nat). -Definition code (a : 'rV_n) t := - Rcode.t (@GF2_of_F2 m) (kernel (PCM a t)). +Definition code (a : 'rV_n) t := Rcode.t (@GF2_of_F2 m) (kernel (PCM a t)). End BCH_def. Section BCH_syndromep. - -Variables (n' : nat). +Variable n' : nat. Let n := n'.+1. Variable (m : nat). Let F : fieldType := GF2 m. @@ -181,8 +175,7 @@ Notation "'\BCHsynp_(' a , e , t )" := (BCH.syndromep a e t) : bch_scope. Local Open Scope bch_scope. Section BCH_is_GRS. - -Variable (m : nat). +Variable m : nat. Let F := GF2 m. Variable (n' : nat). Let n := n'.+1. @@ -206,7 +199,7 @@ Lemma BCH_syndromep_is_GRS_syndromep y : GRS.syndromep (rVexp a n) (rVexp a n) t.*2 (F2_to_GF2 m y). Proof. apply/polyP => i. -rewrite !coef_poly; case: ifPn => // it; by rewrite fdcoor_syndrome_coord. +by rewrite !coef_poly; case: ifPn => // it; rewrite fdcoor_syndrome_coord. Qed. End BCH_is_GRS. @@ -252,7 +245,7 @@ apply/idP/idP. rewrite -(@ltn_pmul2r 2) // !muln2 -(ltn_add2r 1) !addn1. move/leq_trans; apply. move: tn. - rewrite -divn2 leq_divRL // muln2 => /leq_ltn_trans; exact. + by rewrite -divn2 leq_divRL // muln2 => /leq_ltn_trans; exact. Qed. End BCH_PCM_checksum. @@ -328,7 +321,7 @@ transitivity (\det (\matrix_(i, j) (h i j * g j))). apply/matrixP => i j. by rewrite !mxE /h /g /BCH.PCM_alt !mxE -!exprD /= -exprM mul1n addn1. rewrite det_mlinear; congr (_ * _). -congr (\det _); apply/matrixP => i j; by rewrite !mxE /h -exprM. +by congr (\det _); apply/matrixP => i j; rewrite !mxE /h -exprM. Qed. Hypothesis a_neq0 : distinct_non_zero a. @@ -401,7 +394,7 @@ have Hf : \sum_(i < (wH x).-1.+1) case: ifPn => [_|]; first by rewrite!mxE mulrC. rewrite negb_and negbK. case/orP => [/eqP ->|abs']; first by rewrite rmorph0 scale0r mxE. - case/boolP : (x ``_ (f j) == 0) => [/eqP ->|abs'']. + have [->|abs''] := eqVneq (x ``_ (f j)) 0. by rewrite rmorph0 scale0r mxE. exfalso. move/eqP: abs'; apply. @@ -419,7 +412,7 @@ have {}Hf : \sum_(i < r'.+1) GF2_of_F2 x ``_ (f i) *: move/colP : Hf => /(_ (widen_ord (ltnW Hr') j)). rewrite !mxE summxE => Hf. rewrite -[RHS]Hf. - apply eq_bigr => /= i _; by rewrite !mxE. + by apply eq_bigr => /= i _; rewrite !mxE. have /negP := det_B_neq0 Hr' Hinj. rewrite -det_tr; apply. apply/det0P; exists (\row_i GF2_of_F2 x ``_ (f i)). @@ -437,13 +430,12 @@ apply/det0P; exists (\row_i GF2_of_F2 x ``_ (f i)). apply/rowP => i; rewrite !mxE. move/colP : Hf => /(_ i). rewrite !mxE => Hf; rewrite -[RHS]Hf. -rewrite summxE; apply eq_bigr=> k _; by rewrite !mxE. +by rewrite summxE; apply eq_bigr=> k _; rewrite !mxE. Qed. End BCH_minimum_distance_lb. Section BCH_erreval. - Variables (F : fieldType) (n : nat) (a : 'rV[F]_n). Definition BCH_erreval := erreval (const_mx 1) a. @@ -453,7 +445,6 @@ End BCH_erreval. Notation "'\BCHomega_(' a , e )" := (BCH_erreval a e) : bch_scope. Section BCH_key_equation_old. - Variables (F : fieldType) (n' : nat). Let n := n'.+1. Variable a : F. @@ -471,7 +462,7 @@ under eq_bigr. rewrite (_ : \sigma_(rVexp a n, y) = \sigma_(rVexp a n, y, i) * (1 - ((rVexp a n) ``_ i) *: 'X)); last first. rewrite /errloc (bigD1 i) //= mulrC; congr (_ * _). - apply eq_bigl => ij; by rewrite in_setD1 andbC. + by apply eq_bigl => ij; rewrite in_setD1 andbC. over. transitivity (\sum_(i in supp y) y ``_ i *: (\sigma_(rVexp a n, y, i) * (1 - a ^+ (i * n) *: 'X^n))). @@ -496,7 +487,6 @@ Qed. End BCH_key_equation_old. Section decoding_using_euclid. - Variables (n' : nat) (m : nat). Let n := n'.+1. Let F := GF2 m. @@ -650,10 +640,8 @@ Qed. End decoding_using_euclid. Section BCH_cyclic. - -Variables (n' : nat) (m : nat). +Variables (n' m : nat). Let n := n'.+1. -(*Hypothesis nm : (n %| (2 ^ m.-1))%N.*) Let F := GF2 m. Variable a : F. Variable t : nat. @@ -676,9 +664,9 @@ have [M HM] : exists M, `[ 'X * rVpoly x' ]_ n = 'X * rVpoly x' + M * ('X^n - 1) rewrite HM /fdcoor poly_rV_K //; last first. rewrite -HM. move: (ltn_modp ('X * rVpoly x') ('X^n - 1)). - rewrite size_Xn_sub_1 // ltnS => ->. - by rewrite monic_neq0 // monic_Xn_sub_1. -rewrite !(hornerE,hornerXn(*TODO(rei): not necessary since mc1.16.0*)). + rewrite size_XnsubC // ltnS => ->. + by rewrite monic_neq0 // monicXnsubC. +rewrite !(hornerE,hornerXn). move: (Hx i); rewrite /fdcoor => /eqP ->; rewrite mulr0 add0r. by rewrite mxE exprAC a1 expr1n subrr mulr0. Qed. diff --git a/ecc_classic/cyclic_code.v b/ecc_classic/cyclic_code.v index 69716df8..f2452028 100644 --- a/ecc_classic/cyclic_code.v +++ b/ecc_classic/cyclic_code.v @@ -67,7 +67,7 @@ case: ifPn => [/eqP ->|x0]. exfalso; move: (ltn_ord y). rewrite ltnNge => /negP; apply. rewrite [in X in X < _]n0y /= inordK //; first by rewrite prednK // lt0n. - apply: ltn_trans (ltn_ord y); by rewrite prednK // lt0n. + by apply: ltn_trans (ltn_ord y); rewrite prednK // lt0n. case: ifPn => [/eqP -> //|y0 /eqP]. move/eqP; rewrite -val_eqE /= => /eqP n0x. exfalso; move: (ltn_ord x). @@ -75,11 +75,11 @@ case: ifPn => [/eqP -> //|y0 /eqP]. rewrite -[in X in X < _]n0x /= inordK //; first by rewrite prednK // lt0n. apply: ltn_trans (ltn_ord x); by rewrite prednK // lt0n. rewrite -val_eqE /= inordK; last first. - apply: (ltn_trans _ (ltn_ord x)); by rewrite prednK // lt0n. + by rewrite (ltn_trans _ (ltn_ord x))// prednK// lt0n. rewrite inordK; last first. - apply: (ltn_trans _ (ltn_ord y)); by rewrite prednK // lt0n. + by rewrite (ltn_trans _ (ltn_ord y))// prednK // lt0n. move/eqP/(congr1 S). -by rewrite prednK ?lt0n // prednK ?lt0n // => ?; apply val_inj. +by rewrite prednK ?lt0n // prednK ?lt0n // => ?; exact: val_inj. Defined. Definition rcs_perm n : {perm 'I_n} := @@ -89,7 +89,7 @@ Definition rcs (R : idomainType) n (x : 'rV[R]_n) := col_perm (rcs_perm n) x. Lemma size_rcs (R : idomainType) n (x : 'rV[R]_n.+1) : size (rVpoly (rcs x)) < size ('X^n.+1 - 1%:P : {poly R}). -Proof. by rewrite size_Xn_sub_1 // ltnS /rVpoly size_poly. Qed. +Proof. by rewrite size_XnsubC // ltnS /rVpoly size_poly. Qed. Lemma map_mx_rcs (R0 R1 : idomainType) n (x : 'rV[R0]_n.+1) (f : R0 -> R1) : map_mx f (rcs x) = rcs (map_mx f x). @@ -142,7 +142,7 @@ case: ifPn => [/eqP ->|i0]; last rewrite subr0. case: insubP => //= j _ j0. rewrite mxE unlock ffunE /= -val_eqE j0 /= j0 eqxx; congr (- x _ _). by apply val_inj => /=; rewrite inordK. -case/boolP : (i == n.+1) => [/eqP ->|in0]. +have [->|in0] := eqVneq i n.+1. rewrite mulr1 2!coef_rVpoly /=. case: insubP => /= [j _ j0|]; last by rewrite ltnS leqnn. case: insubP => /= [?|_]; first by rewrite ltnn. @@ -151,7 +151,7 @@ rewrite mulr0 2!coef_rVpoly; case: insubP => /= [j|]. rewrite ltnS => in0' ji; case: insubP => /= [k _ ki|]. apply/eqP; rewrite subr_eq0; apply/eqP. rewrite mxE unlock ffunE -val_eqE /= ki (negPf i0) -ji; congr (x _ _). - apply/val_inj => /=; by rewrite inordK. + by apply/val_inj => /=; rewrite inordK. rewrite ltnS -ltnNge => n0i; exfalso. rewrite -ltnS prednK // in in0'; last by rewrite lt0n. by move/negP : in0; apply; rewrite eq_sym eqn_leq {}n0i. @@ -168,14 +168,15 @@ Proof. move=> n0. rewrite /rcs_poly. set xn1 := _ - _. -apply (@leq_trans (size xn1).-1); last by rewrite /xn1 size_Xn_sub_1. -rewrite -ltnS prednK; last by rewrite size_Xn_sub_1. -have : xn1 != 0 by apply/monic_neq0/monic_Xn_sub_1. -by move/ltn_modpN0; apply. +apply (@leq_trans (size xn1).-1); last by rewrite /xn1 size_XnsubC. +rewrite -ltnS prednK; last by rewrite size_XnsubC. +have : xn1 != 0 by apply/monic_neq0/monicXnsubC. +by move/ltn_modpN0; exact. Qed. (* TODO: not used? *) -Lemma size_rcs_poly_old (R : idomainType) n (x : 'rV[R]_n) : size (rcs_poly (rVpoly x) n) <= n. +Lemma size_rcs_poly_old (R : idomainType) n (x : 'rV[R]_n) : + size (rcs_poly (rVpoly x) n) <= n. Proof. destruct n as [|n']. rewrite /rcs_poly subrr modp0. @@ -184,7 +185,8 @@ destruct n as [|n']. by rewrite size_rcs_poly // size_poly. Qed. -Lemma rcs_rcs_poly (F : fieldType) n0 (x : 'rV[F]_n0) : rcs x = poly_rV (rcs_poly (rVpoly x) n0). +Lemma rcs_rcs_poly (F : fieldType) n0 (x : 'rV[F]_n0) : + rcs x = poly_rV (rcs_poly (rVpoly x) n0). Proof. destruct n0 as [|n0]. rewrite /rcs_poly (_ : 'X^0 = 1); last first. @@ -203,7 +205,9 @@ Qed. Lemma rcs_poly_rcs (F : fieldType) n0 (x : {poly F}) (xn0 : size x <= n0.+1) : rcs_poly x n0.+1 = rVpoly (@rcs _ n0.+1 (poly_rV x)). -Proof. rewrite rcs_rcs_poly poly_rV_K // poly_rV_K //; by apply size_rcs_poly. Qed. +Proof. +by rewrite rcs_rcs_poly poly_rV_K // poly_rV_K // size_rcs_poly. +Qed. Definition rcsP (F: finFieldType) n (C : {set 'rV[F]_n}) := forall x, x \in C -> rcs x \in C. @@ -230,7 +234,7 @@ rewrite (eq_bigr (fun i1 : 'I_ _ => (rVpoly x)`_i1 * a ^+ i ^+ i1.+1)); last fir move=> i1 _; rewrite mulrC -mulrA; congr (_ * _). by rewrite mxE -!exprM -exprD mulnS addnC. move=> x_RS. -rewrite (@horner_coef_wide _ n); last by move: (size_rcs x); rewrite size_Xn_sub_1. +rewrite (@horner_coef_wide _ n); last by move: (size_rcs x); rewrite size_XnsubC. rewrite -{}[RHS]x_RS rcs_rcs_poly; apply/esym. rewrite (reindex_onto (@rcs_perm n) (perm_inv (@rcs_perm n))) /=; last first. move=> i1 _; by rewrite permKV. @@ -252,10 +256,10 @@ case: insubP => /= [j|]. rewrite coef_rVpoly_ord mxE unlock ffunE -val_eqE [val k]/= ki1 val_eqE (negPf i10). rewrite inordK; last by rewrite ltnW // ltnS prednK // lt0n. rewrite prednK // ?lt0n //; congr (x _ _ * _). - by apply/val_inj. + exact/val_inj. by rewrite mxE. - rewrite ltnS => /negP abs; exfalso; apply: abs; by rewrite -ltnS. -move=> /negP abs i10; exfalso; apply abs; by rewrite ltnS inordK. + by rewrite ltnS => /negP abs; exfalso; apply: abs; rewrite -ltnS. +by move=> /negP abs i10; exfalso; apply abs; rewrite ltnS inordK. Qed. Lemma fdcoor_rcs (i : 'I_n) x : a ^+ n = 1 -> @@ -363,12 +367,12 @@ Lemma shift_codeword (c : {poly F}) (cn : size c <= n) : poly_rV c \in C -> forall k, poly_rV (`[ 'X^k * c ]_n) \in C. Proof. move=> gC; elim=> [| k ih] /=. -- by rewrite (_ : 'X^0 = 1) // mul1r modp_small // (leq_ltn_trans cn) // size_Xn_sub_1. +- by rewrite (_ : 'X^0 = 1) // mul1r modp_small // (leq_ltn_trans cn) // size_XnsubC. - have {}ih : poly_rV `[ 'X^k * c ]_ n \in [set cs in C] by rewrite inE. move: (Ccode.P ih); rewrite rcs_rcs_poly poly_rV_K; last first. - rewrite -ltnS -(_ : size (('X^n : {poly F}) - 1) = n.+1); last by rewrite size_Xn_sub_1. - by apply/ltn_modpN0/monic_neq0/monic_Xn_sub_1. - rewrite /rcs_poly modp_mul mulrA exprS inE; by apply. + rewrite -ltnS -(_ : size (('X^n : {poly F}) - 1) = n.+1); last by rewrite size_XnsubC. + exact/ltn_modpN0/monic_neq0/monicXnsubC. + by rewrite /rcs_poly modp_mul mulrA exprS inE; exact. Qed. Lemma shift_linearity_codeword (c : {poly F}) (cn : size c <= n) : @@ -384,9 +388,9 @@ have -> : `[ \sum_(i < size p) (p`_i *: ('X^i * c)) ]_n = by rewrite (big_morph (id1 := 0) _ (@morph_modp _ _)) // mod0p. have -> : \sum_(i < size p) `[ p`_i *: ('X^i * c) ]_n = \sum_(i < size p) (p`_i *: `[ 'X^i * c ]_ n ). - apply eq_bigr => k _; by rewrite modpZl. + by apply eq_bigr => k _; rewrite modpZl. apply Lcode0.mem_poly_rV => j. -rewrite linearZ /= Lcode0.sclosed //; by apply shift_codeword. +by rewrite linearZ /= Lcode0.sclosed // shift_codeword. Qed. Lemma remainder_in_code (c : {poly F}) (cn : size c <= n) : @@ -397,14 +401,12 @@ Lemma remainder_in_code (c : {poly F}) (cn : size c <= n) : Proof. move=> cC p /= r p_in_C Hdivp_g Hsize_rem. have -> : r = `[ r ]_n. - symmetry; rewrite modp_small //. - apply (@ltn_trans (size c)) => //. - by rewrite size_Xn_sub_1 // ltnS. + by symmetry; rewrite modp_small// (@ltn_trans (size c))// size_XnsubC // ltnS. rewrite (_ : r = rVpoly p - rVpoly p %/ c * c); last first. by rewrite {1}Hdivp_g addrAC subrr add0r. rewrite modpD linearD /=. have -> : `[ rVpoly p ]_n = rVpoly p. - by rewrite modp_small // size_Xn_sub_1 // ltnS size_poly. + by rewrite modp_small // size_XnsubC // ltnS size_poly. rewrite rVpolyK; apply Lcode0.aclosed => //. by rewrite -mulNr shift_linearity_codeword. Qed. @@ -414,16 +416,16 @@ Lemma scale_cgen (g' : 'rV[F]_n) (HC : not_trivial C) : Proof. move=> Hg'. set g := canonical_cgen HC. -case/boolP : (g == g') => [/eqP ->|gg']. - exists 1; by rewrite scale1r oner_neq0 eqxx. +have [->|gg'] := eqVneq g g'. + by exists 1; rewrite scale1r oner_neq0 eqxx. have size_g := canonical_cgen_lowest_size HC. rewrite -/g in size_g. pose k := lead_coef (rVpoly g') / lead_coef (rVpoly g). pose g'' : {poly F} := rVpoly g' - k *: rVpoly g. have size_g' : size (rVpoly g') = size (rVpoly g) by rewrite size_g; apply size_lowest. -case/boolP : (k == 0) => k0. +have [k0|k0] := eqVneq k 0. exfalso. - move: k0. + move/eqP: k0. rewrite /k mulf_eq0 invr_eq0 2!lead_coef_eq0. case/orP; rewrite rVpoly0; apply/negP. by case/and3P : Hg'. @@ -432,10 +434,11 @@ have size_g'' : size g'' < size (rVpoly g). rewrite /g'' -size_g'; apply size_sub => //. apply/eqP; rewrite rVpoly0; by case/and3P : Hg'. rewrite lreg_size ?size_g' //; by apply/GRing.lregP. - rewrite lead_coefZ /k -mulrA mulVr ?mulr1 // unitfE lead_coef_eq0 rVpoly0; by case/and3P : (canonical_cgenP HC). + rewrite lead_coefZ /k -mulrA mulVr ?mulr1 // unitfE lead_coef_eq0 rVpoly0. + by case/and3P : (canonical_cgenP HC). have g''C : poly_rV g'' \in C. rewrite /g'' linearD /= linearN /= linearZ /= (proj2 (Lcode0.aclosed C)) // ?rVpolyK; first by case/and3P : Hg'. - rewrite Lcode0.oclosed // Lcode0.sclosed //; by case/and3P : (canonical_cgenP HC). + by rewrite Lcode0.oclosed // Lcode0.sclosed //; case/and3P : (canonical_cgenP HC). have g''0 : g'' = 0. apply/eqP/negPn/negP => abs. case/and3P: (canonical_cgenP HC) => _ _ /forallP/(_ (poly_rV g'')). @@ -465,15 +468,14 @@ Lemma divide_codeword (p : {poly F}) : poly_rV (`[ p ]_n) \in C -> forall g, g \in 'cgen[C] -> rVpoly g %| p. Proof. move=> pC g Hg. -case/boolP : (p == 0) => [/eqP -> | p0]. - by rewrite dvdp0. +have [->|p0] := eqVneq p 0; first by rewrite dvdp0. move/eqP: (divp_eq p (rVpoly g)); rewrite addrC -subr_eq => /eqP. move/(congr1 (fun x => `[ x ]_n))/esym. have size_rem : size (p %% rVpoly g) < size (rVpoly g). rewrite ltn_modpN0 //; case/and3P : Hg => _ ? _; by rewrite rVpoly0. have rem_n : size (p %% rVpoly g) <= n. by rewrite ltnW //; apply/(leq_trans size_rem)/(size_is_cgen Hg). -rewrite modp_small; last by rewrite size_Xn_sub_1. +rewrite modp_small; last by rewrite size_XnsubC. rewrite modpD modpN => pmodg. have rem_in_C : poly_rV (p %% rVpoly g) \in C. rewrite pmodg linearD /= (proj2 (Lcode0.aclosed C)) // linearN /= Lcode0.oclosed //. @@ -530,15 +532,15 @@ Lemma cgen_is_pgen g : g \in 'cgen[C] -> rVpoly g \in 'pgen[[set cw in C]]. Proof. move=> Hg; apply/forallP => p; apply/eqP; apply/idP/idP => [p_in_C | g_generated]. - have H : poly_rV (`[ rVpoly p ]_n) = p. - by rewrite modp_small // ?rVpolyK // size_Xn_sub_1 // ltnS size_poly. + by rewrite modp_small // ?rVpolyK // size_XnsubC // ltnS size_poly. rewrite -{}H in p_in_C. apply divide_codeword => //; by rewrite inE in p_in_C. - case/dvdpP: g_generated => /= i p_i_g. rewrite -(rVpolyK p). have <- : `[ rVpoly p ]_n = rVpoly p. - rewrite modp_small // size_Xn_sub_1 // ltnS; by apply size_poly. + by rewrite modp_small // size_XnsubC // ltnS size_poly. rewrite p_i_g inE shift_linearity_codeword //. - by apply (size_is_cgen Hg). + exact (size_is_cgen Hg). by rewrite rVpolyK //; case/and3P : Hg. Qed. @@ -559,7 +561,7 @@ rewrite is_cgenE; apply/and3P => [:H1]; split. - apply/forallP => /= x; apply/implyP => /and3P[K1 K2 K3]. have gn : size (rVpoly g) <= n by rewrite size_poly. rewrite (divides_lowest_size C_not_trivial gn Hg). - by apply size_lowestP. + exact: size_lowestP. Qed. Lemma pgen_cgen (C_not_trivial : not_trivial C) (g : 'rV_n) : @@ -583,7 +585,7 @@ case/dvdpP => /= i ig. split. by rewrite inE linear0 dvdp0. move=> k a b; rewrite !inE => ga gb. -case/boolP : (k == 0) => [/eqP ->|k0]; first by rewrite scale0r add0r. +have [->|k0] := eqVneq k 0; first by rewrite scale0r add0r. by rewrite linearD linearZ /= dvdp_addr // dvdpZr. Qed. @@ -593,8 +595,8 @@ Proof. move=> gXn x. rewrite !inE => /dvdpP[/= i xig]. rewrite rcs_rcs_poly poly_rV_K; last first. - rewrite /rcs_poly -ltnS -(@size_Xn_sub_1 F n erefl). - by rewrite ltn_modpN0 // -size_poly_eq0 size_Xn_sub_1. + rewrite /rcs_poly -ltnS -(@size_XnsubC F n 1)//. + by rewrite ltn_modpN0 // -size_poly_eq0 size_XnsubC. by rewrite /rcs_poly -dvdp_mod // xig mulrA dvdp_mull // modpp. Qed. diff --git a/ecc_classic/decoding.v b/ecc_classic/decoding.v index 67d498b3..d17bac1c 100644 --- a/ecc_classic/decoding.v +++ b/ecc_classic/decoding.v @@ -2,11 +2,8 @@ (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum fingroup finalg perm. From mathcomp Require Import zmodp matrix vector order. -From mathcomp Require Import lra mathcomp_extra Rstruct reals. -From mathcomp Require ssrnum. -Require Import Reals. -Require Import ssrR realType_ext Reals_ext ssr_ext ssralg_ext f2 fdist. -Require Import proba. +From mathcomp Require Import lra ring mathcomp_extra Rstruct reals. +Require Import realType_ext ssr_ext ssralg_ext f2 bigop_ext fdist proba. Require Import channel_code channel binary_symmetric_channel hamming pproba. (******************************************************************************) @@ -33,7 +30,6 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Close Scope R_scope. Import GRing.Theory Num.Theory Order.Theory. Local Open Scope ring_scope. @@ -51,6 +47,109 @@ Lemma vspace_not_empty (F : finFieldType) n (C : {vspace 'rV[F]_n}) : (0 < #| [set cw in C] |)%nat. Proof. apply/card_gt0P; exists 0; by rewrite inE mem0v. Qed. +(* TODO: move elsewhere *) +Reserved Notation "\min^ b '_(' a 'in' A ) F" (at level 41, + F at level 41, a, A at level 50, + format "'[' \min^ b '_(' a 'in' A ) '/ ' F ']'"). + +Notation "\min^ b '_(' a 'in' A ) F" := + ((fun a => F) (arg_min b (fun x => x \in A) (fun a => F))) : min_scope. + +Notation "\rmax_ ( i 'in' A ) F" := (\big[Order.max/GRing.zero]_(i in A) F) + (at level 41, F at level 41, i, A at level 50, + format "'[' \rmax_ ( i 'in' A ) '/ ' F ']'"). + +Notation "\rmax_ ( i <- r ) F" := (\big[Order.max/GRing.zero]_(i <- r) F) + (at level 41, F at level 41, i, r at level 50, + format "'[' \rmax_ ( i <- r ) '/ ' F ']'"). + +Local Open Scope min_scope. + +Lemma bigmaxR_seq_eq {R : realType} (A : finType) (f : A -> R) (s : seq A) a : + a \in s -> + (forall a0, 0 <= f a0) -> + (forall a0, a0 \in s -> f a0 <= f a) -> + f a = \big[Order.max/GRing.zero]_(a0 <- s) f a0. +Proof. +elim: s a => // hd tl IH a; rewrite in_cons; case/orP. +- move/eqP => -> Hhpos Hh. + rewrite big_cons. + apply/esym/max_idPl. + rewrite big_seq. + apply/bigmax_le => // i itl. + by rewrite Hh// inE itl orbT. +- move=> atl Hhpos Hh. + rewrite big_cons. + transitivity (\rmax_(j <- tl) f j). + apply: IH => // i itl. + by rewrite Hh// inE itl orbT. + apply/esym/max_idPr. + rewrite -(IH a)//. + apply: Hh. + by rewrite mem_head. + move=> c0 Hc0. + apply Hh. + by rewrite in_cons Hc0 orbC. +Qed. + +Lemma bigmaxR_eq {R : realType} (A : finType) (C : {set A}) a (f : A -> R): + a \in C -> + (forall a0, 0 <= f a0) -> + (forall c, c \in C -> f c <= f a) -> + f a = \rmax_(c in C) f c. +Proof. +move=> aC f0 Hf. +rewrite -big_filter. +apply bigmaxR_seq_eq => //. +- by rewrite mem_filter aC /= mem_index_enum. +- by move=> a0; rewrite mem_filter mem_index_enum andbT => /Hf. +Qed. + +Lemma leq_bigmin (A : finType) (C : {set A}) (cnot0 : {c0 | c0 \in C}) + a (Ha : a \in C) (h : A -> nat) : + (\min^ (sval cnot0) _(c in C) h c <= h a)%nat. +Proof. by case: arg_minnP; [case: cnot0|move=> a0 a0C; exact]. Qed. + +Lemma bigmaxR_bigmin_vec_helper {R : realType} (A : finType) n (g : nat -> R) : + (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) -> + (forall r, 0 <= g r) -> + forall (C : {set 'rV[A]_n}) c (_ : c \in C) (d : 'rV[A]_n -> nat) + (_ : forall c, c \in C -> (d c <= n)%nat) + (cnot0 : {c0 | c0 \in C}), + d c = \min^ (sval cnot0) _(c in C) d c -> + g (d c) = \rmax_(c in C) g (d c). +Proof. +move=> Hdecr Hr C c cC d Hd cnot0 H. +apply (@bigmaxR_eq _ _ C c (fun a => g (d a))) => //. +move=> /= c0 c0C. +apply/Hdecr/andP; split; [|exact: Hd]. +rewrite H. +exact: leq_bigmin. +Qed. + +Lemma bigmaxR_distrr {R : realType} I a (a0 : 0 <= a) r (P : pred I) F : + (a * \big[Order.max/GRing.zero]_(i <- r | P i) F i) = + \big[Order.max/GRing.zero]_(i <- r | P i) (a * F i) :> R. +Proof. +elim: r => [| h t IH]. + by rewrite 2!big_nil mulr0. +rewrite 2!big_cons. +case: ifP => Qh //. + rewrite -IH. +by rewrite maxr_pMr//. +Qed. + +Lemma bigmaxR_distrl {R : realType} I a (a0 : 0 <= a) r (P : pred I) F : + (\big[Order.max/GRing.zero]_(i <- r | P i) F i) * a = + \big[Order.max/GRing.zero]_(i <- r | P i) (F i * a) :> R. +Proof. +by rewrite mulrC bigmaxR_distrr //; apply congr_big => // ?; rewrite mulrC. +Qed. + +Local Close Scope min_scope. + +(* /TODO: move elsewhere *) + Section minimum_distance_decoding. Variables (F : finFieldType) (n : nat) (C : {set 'rV[F]_n}). @@ -127,6 +226,7 @@ Definition ML_decoding := End maximum_likelihood_decoding. Section maximum_likelihood_decoding_prop. +Let R := Rdefinitions.R. Variables (A : finFieldType) (B : finType) (W : `Ch(A, B)). Variables (n : nat) (C : {vspace 'rV[A]_n}). @@ -140,7 +240,7 @@ Lemma ML_err_rate x1 x2 y : repair y = Some x1 -> x2 \in C -> W ``(y | x2) <= W ``(y | x1). Proof. move=> Hx1 Hx2. -case/boolP : (W ``(y | x2) == 0) => [/eqP -> //| Hcase]. +have [->//|Hcase] := eqVneq (W ``(y | x2)) 0. have PWy : receivable_prop P W y. apply/existsP; exists x2. by rewrite Hcase andbT fdist_uniform_supp_neq0 inE. @@ -162,8 +262,9 @@ Import ssrnum.Num.Theory. Lemma ML_smallest_err_rate phi : echa(W, mkCode enc dec) <= echa(W, mkCode enc phi). Proof. -apply/RleP/leR_wpmul2l; first by apply/mulR_ge0 => //; exact/invR_ge0/ltR0n. -rewrite /ErrRateCond /=; apply/RleP. +rewrite ler_wpM2l//=. + by rewrite invr_ge0. +rewrite /ErrRateCond /=. rewrite [leRHS](eq_bigr (fun m => 1 - Pr (W ``(|enc m)) [set tb | phi tb == Some m])); last first. move=> m _; rewrite Pr_to_cplt; congr (_ - Pr _ _). @@ -174,13 +275,13 @@ rewrite [leLHS](eq_bigr rewrite [in LHS]Pr_to_cplt; congr (_ - Pr _ _). apply/setP => t; by rewrite !inE negbK. rewrite 2!big_split /=; apply: lerD => //. -rewrite -2!big_morph_oppR lerNr opprK /Pr (exchange_big_dep xpredT) //=. +rewrite -2!big_morph_oppr lerNr opprK /Pr (exchange_big_dep xpredT) //=. rewrite [leRHS](exchange_big_dep xpredT) //=. apply ler_sum => /= tb _. rewrite (eq_bigl (fun m => phi tb == Some m)); last by move=> m; rewrite inE. rewrite [leRHS](eq_bigl (fun m => dec tb == Some m)); last by move=> m; rewrite inE. (* show that phi_ML succeeds more often than phi *) -have [dectb_None|dectb_Some] := boolP (dec tb == None). +have [dectb_None|dectb_Some] := eqVneq (dec tb) None. case/boolP : (receivable_prop P W tb) => [Hy|Htb]. case: (ML_dec (mkReceivable Hy)) => [m' [tb_m']]. by move: dectb_None; rewrite {1}/dec {1}ffunE tb_m'. @@ -191,7 +292,7 @@ have [dectb_None|dectb_Some] := boolP (dec tb == None). move/subsetP : enc_img; apply; apply/imsetP; by exists m. rewrite (eq_bigr (fun=> 0)); last by move=> m _; rewrite W_tb. by rewrite big1 //; apply sumr_ge0. -case/boolP : (phi tb == None) => [/eqP ->|phi_tb]. +have [->|phi_tb] := eqVneq (phi tb) None. by rewrite big_pred0 //; apply sumr_ge0. have [m1 Hm1] : exists m', dec tb = Some m' by destruct (dec tb) => //; exists s. have [m2 Hm2] : exists m', phi tb = Some m' by destruct (phi tb) => //; exists s. @@ -209,6 +310,7 @@ Qed. End maximum_likelihood_decoding_prop. Section MD_ML_decoding. +Let R := Rdefinitions.R. Variable p : {prob R}. @@ -241,7 +343,7 @@ case: oc Hoc => [c|] Hc; last first. exists c; split; first by reflexivity. (* replace W ``^ n (y | f c) with a closed formula because it is a BSC *) pose dH_y c := dH y c. -pose g : nat -> R := fun d : nat => ((1 - Prob.p p) ^ (n - d) * (Prob.p p) ^ d)%R. +pose g : nat -> R := fun d : nat => ((1 - Prob.p p) ^+ (n - d) * (Prob.p p) ^+ d)%R. have -> : W ``(y | c) = g (dH_y c). move: (DMC_BSC_prop p enc (discard c) y). rewrite [X in BSC.c X _](_ : _ = card_F2) //. @@ -255,12 +357,11 @@ transitivity (\big[Order.max/0]_(c in C) (g (dH_y c))); last first. by rewrite -/W compatible. (* the function maxed over is decreasing so we may look for its minimizer, which is given by minimum distance decoding *) -rewrite (@bigmaxR_bigmin_vec_helper _ _ _ _ _ _ _ _ _ _ codebook_not_empty) //. -- by rewrite bigmaxRE; apply eq_bigl => /= i; rewrite inE. +rewrite (@bigmaxR_bigmin_vec_helper _ _ _ _ _ _ _ _ _ _ _ codebook_not_empty) //. +- apply: eq_bigl => i. + by rewrite inE. - by apply bsc_prob_prop. -- move=> r; rewrite /g !coqRE. - apply/RleP/mulr_ge0; apply/exprn_ge0; last exact/prob_ge0. - exact/onem_ge0/prob_le1. +- by move=> r; rewrite /g mulr_ge0 ?exprn_ge0 ?subr_ge0 ?inE//. - rewrite inE; move/subsetP: f_img; apply. rewrite inE; apply/existsP; by exists (receivable_rV y); apply/eqP. - by move=> ? _; rewrite /dH_y max_dH. @@ -270,7 +371,6 @@ Qed. End MD_ML_decoding. Section MAP_decoding. - Variables (A : finFieldType) (B : finType) (W : `Ch(A, B)). Variables (n : nat) (C : {vspace 'rV[A]_n}). Variable dec : decT B ('rV[A]_n) n. @@ -283,7 +383,7 @@ Definition MAP_decoding := forall y : P.-receivable W, End MAP_decoding. Section MAP_decoding_prop. - +Let R := Rdefinitions.R. Variables (A : finFieldType) (B : finType) (W : `Ch(A, B)). Variables (n : nat) (C : {vspace 'rV[A]_n}). Variable dec : decT B ('rV[A]_n) n. @@ -298,34 +398,38 @@ have Hunpos : (#| [set cw in C] |%:R)^-1 > 0 :> R. by rewrite invr_gt0 ltr0n; exact/vspace_not_empty. move: (HMAP tb) => [m [tbm]]. rewrite /fdist_post_prob. unlock. simpl. -set tmp := \rmax_(_ <- _ | _) _. -rewrite /tmp. under [in X in _ = X -> _]eq_bigr do rewrite ffunE. move=> H. evar (h : 'rV[A]_n -> R); rewrite (eq_bigr h) in H; last first. by move=> v vC; rewrite /h; reflexivity. rewrite -bigmaxR_distrl in H; last first. - by apply/RleP; rewrite invr_ge0; exact/fdist_post_prob_den_ge0. + by rewrite invr_ge0; exact/fdist_post_prob_den_ge0. rewrite {2 3}/P in H. set r := index_enum _ in H. move: H. -under [in X in _ = X -> _]eq_bigr. +under [in X in _ = X / _ -> _]eq_bigr. move=> i iC. rewrite fdist_uniform_supp_in; last by rewrite inE. over. move=> H. -rewrite -bigmaxR_distrr in H; last exact/RleP/ltW/Hunpos. +rewrite -bigmaxR_distrr in H; last exact/ltW/Hunpos. exists m; split; first exact tbm. rewrite ffunE in H. set x := (X in _ * _ / X) in H. have x0 : x^-1 <> 0 by apply/eqP/invr_neq0; rewrite -receivable_propE receivableP. -move/(eqR_mul2r x0) in H. +move: H => /(congr1 (fun z => z * x)). +rewrite -!mulrA mulVf ?mul1r//; last first. + move/eqP : x0. + by rewrite invr_eq0. +move=> H. rewrite /= fdist_uniform_supp_in ?inE // in H; last first. move/subsetP : dec_img; apply. by rewrite inE; apply/existsP; exists (receivable_rV tb); apply/eqP. -move/lt0r_neq0/eqP: Hunpos. -move/eqR_mul2l : H; move/[apply] ->. -by rewrite bigmaxRE. +move/lt0r_neq0/eqP: Hunpos => Hunpos. +move: H => /(congr1 (fun z => #|[set cw in C]|%:R * z)). +rewrite !mulrA divff ?(mul1r,mulr1)//; last first. + move/eqP : Hunpos. + by rewrite invr_eq0. Qed. End MAP_decoding_prop. diff --git a/ecc_classic/grs.v b/ecc_classic/grs.v index 76508876..780f9610 100644 --- a/ecc_classic/grs.v +++ b/ecc_classic/grs.v @@ -26,8 +26,7 @@ Module GRS. Section GRS_def. -Variables (n (*q*) : nat). -(*Hypothesis nq : n <= q.*) +Variables (n : nat). Variable (F : finFieldType). Variable a : 'rV[F]_n. Hypothesis a_inj : injective [ffun i => a``_i]. (* pairwise distinct *) @@ -211,14 +210,14 @@ Definition GRS_mod r : {poly F} := Lemma GRS_key_equation r : Sigma * GRS.syndromep a b r y = Omega + GRS_mod r * 'X^r. Proof. -case/boolP : (r == O) => r0. - rewrite (eqP r0) mulr1. +have [r0|r0] := eqVneq r 0. + rewrite r0 mulr1. rewrite /GRS.syndromep poly_def big_ord0 mulr0. apply/eqP; rewrite eq_sym addr_eq0; apply/eqP. rewrite /GRS_mod /Omega /erreval -sumrN; apply eq_bigr => j jy. rewrite expr0 mulr1 mulrN opprK [in RHS]mulrC mulrC -!scalerA. rewrite -scalerAl mulrC mul_polyC; congr (_ *: (_ *: _)). - apply eq_bigl => k; by rewrite in_setD1 andbC. + by apply eq_bigl => k; rewrite in_setD1 andbC. rewrite /GRS_mod big_distrl /= /Omega /erreval -big_split /=. rewrite GRS.syndromepE big_distrr /=. apply eq_bigr => i iy. diff --git a/ecc_classic/hamming_code.v b/ecc_classic/hamming_code.v index e5136c4b..c7f76661 100644 --- a/ecc_classic/hamming_code.v +++ b/ecc_classic/hamming_code.v @@ -1,10 +1,10 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum fingroup finalg perm zmodp. -From mathcomp Require Import matrix mxalgebra vector. +From mathcomp Require Import all_ssreflect ssralg ssrnum fingroup finalg perm. +From mathcomp Require Import zmodp matrix mxalgebra vector ring. From mathcomp Require Import Rstruct reals. -Require Import realType_ext ssr_ext ssralg_ext f2 linearcode natbin ssrR hamming. -Require Import bigop_ext fdist proba channel channel_code decoding. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext f2 linearcode natbin. +Require Import hamming fdist proba channel channel_code decoding. Require Import binary_symmetric_channel. (******************************************************************************) @@ -47,7 +47,7 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Import GRing.Theory. +Import GRing.Theory Order.POrderTheory. Local Open Scope ring_scope. Module Hamming. @@ -120,8 +120,8 @@ Proof. move=> /wH_2[i [j [Hij [Hi [Hj Hk]]]]]. rewrite /syndrome mulmx_sum_col (bigID (pred1 i)) /= big_pred1_eq /=. rewrite (bigID (pred1 j)) /= (eq_bigl (pred1 j)) /=; last first. - move=> a /=; case/boolP : (a == j) => aj; last by rewrite andbC. - rewrite andbC /= (eqP aj) eq_sym; by apply/eqP. + move=> a /=; have [aj|aj] := eqVneq a j; last by rewrite andbC. + rewrite andbC /= aj eq_sym; by apply/eqP. rewrite big_pred1_eq /= (eq_bigr (fun=> 0)) /=; last first. move=> a /andP[X1 X2]. rewrite mxE Hk ?scale0r //; (apply/eqP; by rewrite eq_sym). @@ -272,13 +272,14 @@ rewrite /alt_hamming_err. destruct (nat_of_rV _); first by rewrite wH0. clearbody n; clear. rewrite wH_sum. -case/boolP : (n0 < n)%N => n0n. - rewrite (bigD1 (Ordinal n0n)) //= mxE eqxx (eq_bigr (fun x => O)); last first. +have [n0n|n0n] := ltnP n0 n. + rewrite (bigD1 (Ordinal n0n))//= mxE eqxx (eq_bigr (fun x => O)); last first. move=> i Hi; rewrite mxE ifF //. apply: contraNF Hi => /eqP Hi; by apply/eqP/val_inj. by rewrite big_const iter_addn mul0n. rewrite (eq_bigr (fun x => O)); first by rewrite big_const iter_addn. -move=> i _; rewrite mxE ifF //=; by apply: contraNF n0n => /eqP ->. +move=> i _; rewrite mxE ifF //=. +by apply/negbTE; rewrite gtn_eqF// (leq_trans (ltn_ord i)). Qed. Lemma syndrome_hamming_err y : @@ -286,7 +287,7 @@ Lemma syndrome_hamming_err y : Proof. rewrite /hamming_err. move Hs : (syndrome (Hamming.PCM m) y) => s. -case/boolP : (s == 0) => [/eqP ->|s0]. +have [->|s0] := eqVneq s 0. by rewrite nat_of_rV_0 syndrome0. have [k ks] : exists k : 'I_n, nat_of_rV s = k.+1. move: s0; rewrite -nat_of_rV_eq0 -lt0n => s0. @@ -571,7 +572,7 @@ Lemma PCM_A_1 : PCM = castmx (erefl, subnK (Hamming.dim_len m')) (row_mx CSM 1). Proof. apply/matrixP => i j. rewrite mxE castmxE /=. -case/boolP : (j < n - m)%N => Hcond. +have [Hcond|Hcond] := ltnP j (n - m)%N. have -> : cast_ord (esym (subnK (Hamming.dim_len m'))) j = lshift m (Ordinal Hcond) by apply val_inj. rewrite row_mxEl [in X in _ = X]mxE. @@ -582,13 +583,13 @@ case/boolP : (j < n - m)%N => Hcond. rewrite [in X in _ = X]mxE. move: (splitP (cast_ord (esym (subnK (Hamming.dim_len m'))) j)) => [k Hk|k Hk]. have jk : j = k :> nat by []. - by rewrite jk (ltn_ord k) in Hcond. + by rewrite leqNgt jk (ltn_ord k) in Hcond. rewrite permE /perm_ids. move Hj : (ord_split j) => l. move: (splitP l) => [p Hp|p Hlp]. exfalso. move/negP : Hcond; apply. - suff -> : nat_of_ord j = nat_of_ord p by apply ltn_ord. + suff -> : nat_of_ord j = nat_of_ord p by apply/negP; rewrite -ltnNge ltn_ord. by rewrite -Hp -Hj. destruct ids1 as [x e] => /=. move/matrixP/(_ i 0) : e. @@ -958,10 +959,8 @@ End hamming_code_error_distance. Local Open Scope channel_code_scope. (* to get e(W,c), echa(W,c) notations *) -Require Import Reals Reals_ext. - Section hamming_code_error_rate. - +Let R := Rdefinitions.R. Variable M : finType. Hypothesis M_not_0 : (0 < #|M|)%nat. Variable p : {prob R}. @@ -973,18 +972,16 @@ Let m := m'.+2. Let n := Hamming.len m'. Let hamming_channel_code : code _ _ _ n := Hamming'.channel_code m'. -Local Open Scope R_scope. - Lemma e_hamming m0 : e(W, hamming_channel_code) m0 = \sum_(e0 in [set e0 : 'rV['F_2]_n | (2 <= wH e0)%nat]) - (1 - Prob.p p) ^ (n - wH e0) * (Prob.p p) ^ wH e0. + (1 - Prob.p p) ^+ (n - wH e0) * (Prob.p p) ^+ wH e0 :> R. Proof. rewrite /ErrRateCond /Pr /=. transitivity ( \sum_(a | a \in preimC (dec hamming_channel_code) m0) let d := dH ((enc hamming_channel_code) m0) a in - (1 - Prob.p p) ^ (n - d) * (Prob.p p) ^ d). + (1 - Prob.p p) ^+ (n - d) * (Prob.p p) ^+ d). apply eq_bigr => t Ht. rewrite dH_sym. rewrite -(DMC_BSC_prop p (enc hamming_channel_code) m0 t). @@ -994,19 +991,17 @@ transitivity ( m1 != m0 else true]) (let d := dH ((enc hamming_channel_code) m0) a in - (1 - Prob.p p) ^ (n - d) * (Prob.p p) ^ d)). + (1 - Prob.p p) ^+ (n - d) * (Prob.p p) ^+ d)). apply eq_bigl => t /=. rewrite !inE. case_eq (dec hamming_channel_code t) => [m1 Hm1|]; last first. by move=> ->. by case: ((dec hamming_channel_code) t). set y0 := (enc hamming_channel_code) m0. -Local Close Scope R_scope. -set f := fun y => (y0 + y). -Local Open Scope R_scope. +set f : 'rV__ -> 'rV__ := fun y => (y0 + y). transitivity ( \sum_(y | f y \in [set e1 | (1 < wH e1)%nat]) - (1 - Prob.p p) ^ (n - wH (f y)) * (Prob.p p) ^ wH (f y)). + (1 - Prob.p p) ^+ (n - wH (f y)) * (Prob.p p) ^+ wH (f y)). apply eq_big. move=> y. simpl in y, f, m0. @@ -1044,7 +1039,7 @@ Qed. Lemma hamming_error_rate : Prob.p p < 1/2 -> echa(W, hamming_channel_code) = - 1 - ((1 - Prob.p p) ^ n) - n%:R * (Prob.p p) * ((1 - Prob.p p) ^ (n - 1)). + 1 - ((1 - Prob.p p) ^+ n) - n%:R * (Prob.p p) * ((1 - Prob.p p) ^+ (n - 1)). Proof. move=> p05. rewrite /CodeErrRate. @@ -1053,19 +1048,27 @@ eapply eq_trans. apply eq_bigr => i _; exact: e_hamming. eapply eq_trans. apply f_equal. - by rewrite big_const /= iter_addR. -rewrite mulRA /=. -set den := INR _. -have -> : 1 / den * den = 1. - by rewrite div1R mulVR // ?INR_eq0' card_mx /= mul1n expn_eq0 negb_and card_F2. -rewrite mul1R. -have toleft A B C D : A + C + D = B -> A = B - C - D by move => <-; ring. + by rewrite big_const /= iter_addr addr0. +rewrite /=. +rewrite -[in X in _ * X = _]mulr_natl. +rewrite mulrA /=. +set den := _%:R. +rewrite mulVf; last first. + rewrite /den card_mx/= mul1n. + rewrite Num.Theory.pnatr_eq0. + rewrite expn_eq0. + by rewrite negb_and card_F2. +rewrite mul1r. +have toleft (A B C D : R) : A + C + D = B -> A = B - C - D. + move => <-. + by rewrite addrAC addrK addrK. apply toleft. -rewrite -addRA -(hamming_01 n (Prob.p p)) //. -rewrite -big_union //. +rewrite -addrA. +rewrite -(hamming_01 n (Prob.p p)). +rewrite -big_union //=. rewrite (_ : _ :|: _ = [set: 'rV_n]). - by apply binomial_theorem. - apply/setP => /= x; by rewrite !inE leqNgt orNb. + by rewrite binomial_theorem//. + by apply/setP => /= x; by rewrite !inE leqNgt orNb. rewrite -setI_eq0. apply/eqP/setP => /= x; by rewrite !inE leqNgt andNb. Qed. diff --git a/ecc_classic/linearcode.v b/ecc_classic/linearcode.v index f5692e5b..46857b91 100644 --- a/ecc_classic/linearcode.v +++ b/ecc_classic/linearcode.v @@ -267,7 +267,7 @@ move=> xC x0. rewrite /lowest_size. case: exists_non0_codeword_lowest_deg => g /= /and3P[H1 H2 /forallP]. move/(_ x); rewrite xC x0 /= andbT. -case/boolP : (x == g) => [/eqP -> //| xg]. +have [->//|xg] := eqVneq x g. by rewrite implyTb. Qed. @@ -277,7 +277,7 @@ Proof. case/and3P => gC g0 Hg. rewrite /lowest_size. case: exists_non0_codeword_lowest_deg => g' /= /and3P[g'C g'0 Hg']. -case/boolP: (g == g') => [/eqP -> // | gg']. +have [->//|gg'] := eqVneq g g'. apply/eqP; rewrite eqn_leq. move: Hg => /forallP/(_ g'). rewrite g'C /= g'0 andbT eq_sym gg' implyTb => ->. @@ -512,11 +512,10 @@ have gk : size (rVpoly g) <= size (rVpoly k). - rewrite /k; move: abs; apply contra; by rewrite subr_eq0. suff kg : size (rVpoly k) < size (rVpoly g). by move: (leq_ltn_trans gk kg); rewrite ltnn. -rewrite /k linearB /=; case/boolP: (1 < size (rVpoly g)) => size_1g. +rewrite /k linearB /=; have [size_1g|size_1g] := ltnP 1 (size (rVpoly g)). - apply: size_sub => //=; last by apply lead_coef_F2. - apply/eqP; apply: contra g0; by rewrite rVpoly0. -- rewrite -leqNgt in size_1g. - (* this means that g is constant *) + by apply/eqP; apply: contra g0; rewrite rVpoly0. +- (* this means that g is constant *) have sz_g1 : size (rVpoly g) = 1%N. have : size (rVpoly g) != O by rewrite size_poly_eq0 rVpoly0. by case: (size _) size_1g => //; case. @@ -720,11 +719,11 @@ transitivity (\sum_(i < r.+1) #| [set y | dH x y == i] |)%N. apply: trivIimset. - move=> i j _ _ ji; rewrite -setI_eq0; apply/eqP/setP => /= y. rewrite !inE. - case/boolP : (dH x y == i) => //= /eqP ->. - apply/negbTE; by rewrite eq_sym. + have [->/=|//] := eqVneq (dH x y) i. + by apply/negbTE; rewrite eq_sym. - apply/negP; case/imsetP => /= i _ => /esym. apply/eqP/sphere_not_empty. - rewrite (leq_trans _ rn) //; move: (ltn_ord i); by rewrite ltnS. + by rewrite (leq_trans _ rn) //; move: (ltn_ord i); rewrite ltnS. have partD : partition (f @: enum 'I_r.+1) D. apply/and3P; split. - rewrite cover_imset //; apply/eqP/eq_bigl => i; by rewrite mem_enum. @@ -767,11 +766,11 @@ have /card_partition : partition P (\bigcup_(c in C) ball c t). move/setP/(_ x); by rewrite !inE dHE subrr wH0 leq0n. rewrite big_imset /=; last first. move=> c1 c2 c1C c2C. - case/boolP : (c1 == c2) => [/eqP //|c1c2 abs]. + have [//|c1c2 abs] := eqVneq c1 c2. move: (H _ _ c1C c2C c1c2). rewrite abs setIid => /setP/(_ c2). by rewrite !inE dHE subrr wH0 leq0n. -move=> <-; apply subset_leq_card; apply/subsetP => x; by rewrite inE. +by move=> <-; apply subset_leq_card; apply/subsetP => x; rewrite inE. Qed. Definition perfect n q (C : Lcode0.t 'F_q n) diff --git a/ecc_classic/poly_decoding.v b/ecc_classic/poly_decoding.v index 206ee184..539d5fe5 100644 --- a/ecc_classic/poly_decoding.v +++ b/ecc_classic/poly_decoding.v @@ -147,7 +147,7 @@ apply (@leq_trans (#|E|.*2.+1 - #|E|)); last first. rewrite leq_sub // ltnS. apply (@leq_trans (\sum_(i in E) 2)); last by rewrite big_const iter_addn_0 mul2n. apply leq_sum => /= i iE. -case/boolP : (a ``_ i == 0) => [/eqP ->|ai0]. +have [->|ai0] := eqVneq (a ``_ i) 0. by rewrite scale0r subr0 size_poly1. by rewrite size_one_minus_X. Qed. @@ -393,7 +393,7 @@ Qed. Lemma size_syndromep y : size (syndromep u y t) <= t. Proof. rewrite /syndromep poly_def (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP => i _. -case/boolP : (fdcoor u y (inord i.+1) == 0) => [/eqP -> | ?]. +have [->|?] := eqVneq (fdcoor u y (inord i.+1)) 0. - by rewrite scale0r size_poly0. - by rewrite size_scale // size_polyXn. Qed. @@ -447,7 +447,7 @@ Hypothesis tn : t < n. Lemma dft_syndromep (v : 'rV[F]_n) : rVpoly (dft (rVexp a n) t (twisted a v)) = syndromep (rVexp a n) v t. Proof. -case/boolP : (a == 0) => [/eqP -> | a0]. +have [->|a0] := eqVneq a 0. apply/polyP => i. rewrite !coef_poly. case: ifPn => // it. diff --git a/ecc_classic/reed_solomon.v b/ecc_classic/reed_solomon.v index 7807fd0d..e01f03a7 100644 --- a/ecc_classic/reed_solomon.v +++ b/ecc_classic/reed_solomon.v @@ -45,6 +45,7 @@ Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory. + Local Open Scope ring_scope. Local Open Scope dft_scope. @@ -114,7 +115,7 @@ Qed. Lemma deg_lb c : c \in codebook -> (c == 0) || (d.+1 <= size (rVpoly c)). Proof. move=> H. -case/boolP : (c == 0) => //=. +have [//=|] := eqVneq c 0. rewrite -rVpoly0 => c0. move: (uniq_roots_exp); rewrite uniq_rootsE. move/(max_poly_roots c0 (all_root_codeword H)). @@ -136,7 +137,7 @@ Qed. Lemma addr_closed : addr_closed codebook. Proof. split; [exact: O_in_codebook | move=> x y]. -have [xy|xy] := boolP (x + y == 0); first by rewrite /= (eqP xy) O_in_codebook. +have [/= ->|xy] := eqVneq (x + y) 0; first by rewrite O_in_codebook. rewrite inE => /forallP H1; rewrite inE => /forallP H2. rewrite inE; apply/forallP => i; apply/implyP => i0. rewrite fdcoorD. @@ -414,7 +415,7 @@ Lemma RS_message_size (p : 'rV_n) x : rVpoly p = x * \gen_(a, d) -> (size x).-1 <= n - d.+1. Proof. move=> Hx. -case/boolP : (x == 0) => [/eqP ->|x0]; first by rewrite size_poly0. +have [->|x0] := eqVneq x 0; first by rewrite size_poly0. have : size (rVpoly p) <= n by rewrite size_poly. rewrite Hx size_mul // ?gen_neq0 // => H. rewrite -(leq_add2r d.+1) (subnK dn) (leq_trans _ H) //. @@ -515,15 +516,16 @@ split => [c_in_RS| [m [H0 H1]] ]; last first. rewrite -(rVpolyK c) H1 fdcoor_codeword //. rewrite Hn0 /= (leq_trans (ltn_ord n0)) //. by rewrite -H1 size_poly. -case/boolP : (c == 0) => [/eqP ->|Hc]. - exists 0; by rewrite size_poly0 -subn1 sub0n leq0n mul0r linear0. +have [->|Hc] := eqVneq c 0. + by exists 0; rewrite size_poly0 -subn1 sub0n leq0n mul0r linear0. have Hc' : 0 < size (rVpoly c) by rewrite size_poly_gt0 rVpoly0. -have H1 : forall i, 1 <= i < d.+1 -> (rVpoly c).[a ^+ i] = 0. - move=> i /andP[i0 id]. - move: c_in_RS; rewrite inE => /forallP/(_ (Ordinal id)); rewrite i0 implyTb /fdcoor // => /eqP. +have H1 i : 1 <= i < d.+1 -> (rVpoly c).[a ^+ i] = 0. + move=> /andP[i0 id]. + move: c_in_RS; rewrite inE => /forallP/(_ (Ordinal id)). + rewrite i0 implyTb /fdcoor // => /eqP. by rewrite mxE /= inordK // (leq_trans id). -have H2 : forall n0, 1 <= n0 < d.+1 -> 'X - (a ^+ n0)%:P %| rVpoly c. - move=> n0 /H1 /eqP /factor_theorem [x ->]. +have H2 n0 : 1 <= n0 < d.+1 -> 'X - (a ^+ n0)%:P %| rVpoly c. + move=> /H1 /eqP /factor_theorem [x ->]. by rewrite dvdp_mull. pose rs := [seq (a ^+ i) | i <- iota 1 d]. have K1 : all (root (rVpoly c)) rs by apply RS.all_root_codeword. @@ -564,7 +566,6 @@ Qed. End RS_generator_prop. Section RS_decoding_using_euclid0. - Variables (F : finFieldType) (a : F) (n' : nat). Let n := n'.+1. Variable d : nat. @@ -619,7 +620,6 @@ Qed. End RS_decoding_using_euclid0. Section RS_decoding_using_euclid. - Variables q m' : nat. Hypothesis primeq : prime q. Let F := GF m' primeq. @@ -696,7 +696,6 @@ End RS_decoding_using_euclid. Module RS_encoder. Section RS_encoder_sect. - Variable (F : finFieldType) (a : F). Variables (d : nat) (n' : nat). Let n := n'.+1. @@ -768,9 +767,9 @@ rewrite -(@rreg_div0 _ _ _ 'X^d). apply/andP; split; rewrite (leq_trans (size_add _ _)) // geq_max size_opp H /=. by rewrite (leq_trans _ dn) // ltnW. by rewrite (leq_trans _ dn) // ltnW. -- rewrite lead_coefXn; exact: GRing.rreg1. +- by rewrite lead_coefXn; exact: GRing.rreg1. - rewrite size_polyXn ltnS (leq_trans (size_add _ _)) //. - rewrite geq_max size_opp /=; apply/andP; split; by rewrite -ltnS. + by rewrite geq_max size_opp /=; apply/andP; split; rewrite -ltnS. Qed. Hypothesis a_neq0 : a != 0. diff --git a/ecc_modern/checksum.v b/ecc_modern/checksum.v index bf408140..acb40e60 100644 --- a/ecc_modern/checksum.v +++ b/ecc_modern/checksum.v @@ -2,9 +2,8 @@ (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum fingroup finalg perm zmodp. From mathcomp Require Import matrix vector. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssralg_ext ssrR Reals_ext f2 fdist channel tanner linearcode. +From mathcomp Require Import Rstruct reals. +Require Import ssralg_ext f2 fdist channel tanner linearcode. Require Import pproba. (******************************************************************************) @@ -65,19 +64,19 @@ End checksubsum_parity. Local Open Scope channel_scope. Section post_proba_checksubsum. - +Let R := Rdefinitions.R. Variables (B : finType) (W : `Ch('F_2, B)). Variables (m n : nat) (H : 'M['F_2]_(m, n)). Local Notation "''V'" := (Vnext H). Lemma kernel_checksubsum1 (x : 'rV['F_2]_n) : x \in kernel H -> - (1 = (\prod_m0 \delta ('V m0) x)%:R)%R. + (1 = (\prod_m0 \delta ('V m0) x)%:R :> R)%R. Proof. move=> x_in_C. -rewrite {1}(_ : (1 = (\prod_(m0 < m) 1)%:R)%R); [congr INR | +rewrite {1}(_ : (1 = (\prod_(m0 < m) 1)%:R)%R); [congr _%:R | by rewrite big_const iter_muln_1 exp1n]. apply eq_bigr => m0 _. -rewrite /C mem_kernel_syndrome0 /syndrome in x_in_C. +rewrite mem_kernel_syndrome0 /syndrome in x_in_C. move/eqP in x_in_C. have {}x_in_C : forall m0, \sum_i (H m0 i) * (x ``_ i) = 0. move=> m1. @@ -108,10 +107,10 @@ by rewrite /checksubsum (x_in_C m0) eqxx. Qed. Lemma kernel_checksubsum0 (x : 'rV['F_2]_n) : x \notin kernel H -> - ((\prod_m0 checksubsum ('V m0) x)%:R = 0)%R. + ((\prod_m0 checksubsum ('V m0) x)%:R = 0 :> R)%R. Proof. move=> x_notin_C. -rewrite /C mem_kernel_syndrome0 /syndrome in x_notin_C. +rewrite mem_kernel_syndrome0 /syndrome in x_notin_C. have {}x_notin_C : [exists m0, \sum_i (H m0 i) * (x ``_ i) != 0]. rewrite -negb_forall; apply: contra x_notin_C => /forallP x_notin_C. apply/eqP/rowP => a; rewrite !mxE /= -[RHS](eqP (x_notin_C a)). @@ -147,30 +146,28 @@ Proof. apply/idP/idP; last first. apply: contraTT => /kernel_checksubsum0. rewrite -(@big_morph _ _ nat_of_bool true muln true andb) //. - rewrite -eqb0 /= (_ : 0 = 0%:R)%R //; by move/INR_eq/eqP. - move=> ? ? /=; by rewrite mulnb. + rewrite -eqb0 /= (_ : 0 = 0%:R)%R // => /eqP. + by rewrite Num.Theory.eqr_nat. + by move=> ? ? /=; rewrite mulnb. move/kernel_checksubsum1. rewrite -(@big_morph _ _ nat_of_bool true muln true andb) //; last first. move=> ? ? /=; by rewrite mulnb. -rewrite (_ : 1 = true%:R)%R // => /INR_eq/esym. +rewrite (_ : 1 = true%:R)%R // => /eqP. +rewrite Num.Theory.eqr_nat. by case: (\big[andb/true]_(_ < _) _). Qed. -Local Open Scope R_scope. - Lemma checksubsum_in_kernel (x : 'rV['F_2]_n) : - (\prod_(i < m) (\delta ('V i) x)%:R = (x \in kernel H)%:R)%R. + (\prod_(i < m) (\delta ('V i) x)%:R = (x \in kernel H)%:R :> R)%R. Proof. rewrite kernel_checksubsum. -transitivity ((\prod_m1 (\delta ('V m1) x))%:R)%R. - by rewrite -big_morph_natRM. +transitivity ((\prod_m1 (\delta ('V m1) x))%:R :> R)%R. + by rewrite -natr_prod. congr (_%:R). erewrite (@big_morph _ _ nat_of_bool true) => //. move=> ? ? /=; by rewrite mulnb. Qed. -Local Close Scope R_scope. - Let C := kernel H. Hypothesis HC : (0 < #| [set cw in C] |)%nat. @@ -183,7 +180,7 @@ Lemma post_prob_uniform_checksubsum (x : 'rV['F_2]_n) : (\prod_m0 (\delta ('V m0) x))%:R * W ``(y | x))%R. Proof. rewrite post_prob_uniform_kernel; congr (_ * _ * _)%R. -by rewrite big_morph_natRM checksubsum_in_kernel inE mem_kernel_syndrome0. +by rewrite natr_prod checksubsum_in_kernel inE mem_kernel_syndrome0. Qed. End post_proba_checksubsum. diff --git a/ecc_modern/degree_profile.v b/ecc_modern/degree_profile.v index c3aa6791..523e1c15 100644 --- a/ecc_modern/degree_profile.v +++ b/ecc_modern/degree_profile.v @@ -41,7 +41,6 @@ End SumCoef. Module DegreeDistribution. Section Lambda_definition. - Variable K : numDomainType. (* type for Lambda and Rho *) @@ -65,10 +64,9 @@ have p0pos : 0 <= sum_coef p by apply sumr_ge0. rewrite -sum_coef_horner lt0r /= p0pos andbT. apply: contra psize => /eqP sum0. rewrite size_poly_eq0 -lead_coef_eq0 /lead_coef. -case/boolP : ((size p).-1 < size p)%nat => [H|]. +have [H|H] := ltnP (size p).-1 (size p). apply/eqP; apply: (@psumr_eq0P K _ xpredT _ _ sum0 (Ordinal H) erefl) => ? _. by apply p0. -rewrite -leqNgt => ?. by rewrite nth_default. Qed. @@ -469,7 +467,7 @@ move=> p0. rewrite size_poly_eq0 => /eqP Hip. have : (integ p)`_(size p).-1 == 0 by rewrite Hip coef0. rewrite /integ coef_poly. -case/boolP : (size p > 0)%nat => [Hp|]. +have [Hp|] := ltnP 0 (size p). rewrite prednK // leqnn. case/boolP : (p`_(size p).-1 > 0) => [Hp'|]. move: Hp. @@ -477,7 +475,7 @@ case/boolP : (size p > 0)%nat => [Hp|]. by rewrite H2 ltxx in H1. rewrite lt_def p0 andbT negbK lead_coef_eq0 => /eqP ->. by rewrite size_poly0. -by rewrite lt0n negbK. +by rewrite leqn0. Qed. Definition integ_deg (p : DegreeDistribution.Lambda K) : @@ -3398,18 +3396,18 @@ apply (@leq_trans (len + size (enum (border (nodes c))) * maxdeg)). apply leq_add => //. rewrite /step_dist_it -Heqb /= in Hr. set cr' := step_dist _ _ _ _ _ in Hr. - case/boolP: (cr'.2 == 0) => Hr'. + have [Hr'|Hr'] := eqVneq cr'.2 0. rewrite -(enum_step_border (esym Heqb) Hi) in Hr. move: (step_dist_it_const lam cr'.1 cr'.2 t'). rewrite {1}/step_dist_it -surjective_pairing => Hc. move: Hr. - rewrite Hc (eqP Hr'). + rewrite Hc Hr'. destruct step_dist_it => /=. by rewrite mul0r eqxx. rewrite /= in Hr'. - case/boolP: (dest_dist lam c i.2 == 0) => Hdi. - by rewrite (eqP Hdi) mulr0 mul0r eqxx in Hr'. - by apply (cards_conode_out Hlam Hdi). + have [Hdi|Hdi] := eqVneq (dest_dist lam c i.2) 0. + by rewrite Hdi mulr0 mul0r eqxx in Hr'. + exact: (cards_conode_out Hlam Hdi). by rewrite leq_add2l leq_mul2r Hp orbT. Qed. @@ -3466,21 +3464,19 @@ transitivity (\sum_(t in dest_ports c #|border (nodes c)|) apply eq_bigr => /= t Ht. rewrite tuple_to_partial_enumK. rewrite (surjective_pairing (step_dist_it _ _ _ _)) step_dist_it_1. - case/boolP: ((step_dist_it lam c r t).2 == 0) => Hr. - rewrite (eqP Hr). + have [->|Hr] := eqVneq (step_dist_it lam c r t).2 0. rewrite /weighted_count big_map /= big1 //. move=> i _; rewrite switch_step_dist_it_const. by destruct switch_step_dist_it; rewrite mul0r. rewrite (IHl (len * maxdeg.+1)%nat) //. rewrite /switch /=. - by apply (ports_conodes_step_it Ht Hr Hlam). + exact: (ports_conodes_step_it Ht Hr Hlam). rewrite /switch /=. rewrite /known_coports. rewrite /ports part_nodes_step_it. rewrite mulnS. - by apply (leq_trans Hp), leq_addr. - rewrite /switch /=. - by apply border_nodes_step_it. + by rewrite (leq_trans Hp)// leq_addr. + exact: border_nodes_step_it. rewrite (leq_ltn_trans _ Hl) //. rewrite /tree_max [in X in (_ <= X)%nat]sum_expr_S mulnDr mulnA. by apply leq_addl. @@ -3559,8 +3555,7 @@ apply (@Order.POrderTheory.le_trans _ _ (\sum_(i in dest_ports c #|border (nodes move=> P; apply eq_bigr => i /andP [Hi _]; rewrite /F. rewrite tuple_to_partial_enumK. rewrite (surjective_pairing (step_dist_it _ _ _ _)) /=. - case/boolP: ((step_dist_it lam c r i).2 == 0) => Hi2. - rewrite (eqP Hi2). + have [->|Hi2] := eqVneq (step_dist_it lam c r i).2 0. rewrite /weighted_count big_map /= big1 //. move=> ? _; rewrite switch_step_dist_it_const. by destruct switch_step_dist_it; rewrite mul0r. @@ -3819,8 +3814,7 @@ Proof. move=> Hep Hen. rewrite (big_pred1 en) //= => en'. rewrite pred1E. -case/boolP: (en == en') => Henn'. - by rewrite -(eqP Henn') Hep Hen. +have [<-|Henn'] := eqVneq en en'; first by rewrite Hep Hen. case Hen': (en' \in h) => //=. apply/negP => Hep'. move/trivIsetP/(_ en en' Hen Hen' Henn'): (part_p h). diff --git a/ecc_modern/ldpc.v b/ecc_modern/ldpc.v index 63e45401..3f7d5f14 100644 --- a/ecc_modern/ldpc.v +++ b/ecc_modern/ldpc.v @@ -1,10 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg fingroup finalg perm zmodp. -From mathcomp Require Import matrix vector ssrnum. -Require Import Reals Lra. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext realType_ext ssr_ext ssralg_ext num_occ bigop_ext. +From mathcomp Require Import matrix vector ssrnum lra ring. +From mathcomp Require Import Rstruct reals. +Require Import realType_ext ssr_ext ssralg_ext num_occ bigop_ext. Require Import fdist channel pproba f2 linearcode subgraph_partition tanner. Require Import tanner_partition hamming binary_symmetric_channel decoding. Require Import channel_code summary checksum summary_tanner. @@ -37,10 +36,10 @@ Import GRing.Theory Num.Theory. Local Open Scope num_occ_scope. Local Open Scope channel_scope. -Local Open Scope R_scope. +Local Open Scope ring_scope. Section regular_ldpc. - +Let R := Rdefinitions.R. Variables (m n : nat). Definition Hreg_ldpc (H : 'M['F_2]_(m, n)) (lambda rho : nat) := @@ -52,13 +51,13 @@ Record reg_ldpc := { regrho : nat ; Hreg : Hreg_ldpc regH reglambda regrho }. -Definition reg_rate C := 1 - (reglambda C)%:R / (regrho C)%:R. +Definition reg_rate C : R := 1 - (reglambda C)%:R / (regrho C)%:R. End regular_ldpc. -Lemma reg_ldpc_prop m n : forall (C : reg_ldpc m n), +Lemma reg_ldpc_prop {R : realType} m n : forall (C : reg_ldpc m n), n <> O -> regrho C <> O -> - m%:R / n%:R = (reglambda C)%:R / (regrho C)%:R. + m%:R / n%:R = (reglambda C)%:R / (regrho C)%:R :> R. Proof. case => /= H lam rho [] Hlam Hrho Hm0 Hrho0. have : (\sum_(m0 : 'I_m) wH (row m0 H) = rho * m)%nat. @@ -71,12 +70,16 @@ have {}Htmp : (lam * n = rho * m)%nat. transitivity (\sum_(n0 < n) lam)%nat. by rewrite big_const iter_addn addn0 card_ord. apply eq_bigr => i _; exact/esym/Hlam. -rewrite -(@eqR_mul2l n%:R); last exact/INR_eq0. -rewrite mulRCA mulRV ?INR_eq0' ?mulR1; last exact/eqP. -rewrite -(@eqR_mul2l rho%:R); last exact/INR_eq0. -rewrite mulRA [in X in _ = X](mulRC rho%:R). -rewrite -mulRA (mulRCA rho%:R) mulRV ?INR_eq0' ?mulR1; last exact/eqP. -by rewrite -natRM -Htmp natRM mulRC. +apply: (@mulfI _ n%:R). + by rewrite (_ : 0 = 0%:R)// eqr_nat; exact/eqP. +rewrite mulrCA divff ?mulr1//; last first. + by rewrite (_ : 0 = 0%:R)// eqr_nat; exact/eqP. +apply: (@mulfI _ rho%:R). + by rewrite (_ : 0 = 0%:R)// eqr_nat; exact/eqP. +rewrite mulrA [in X in _ = X](mulrC rho%:R). +rewrite -mulrA (mulrCA rho%:R) mulfV ?mulr1; last first. + by rewrite (_ : 0 = 0%:R)// eqr_nat; exact/eqP. +by rewrite -natrM -Htmp natrM mulrC. Qed. Local Open Scope ring_scope. @@ -117,7 +120,7 @@ transitivity (\prod_(A in [set 'V(m0, n0) :\ n0 | m0 in 'F n0 & ('V(m0, n0) :\ n move=> i /andP [] Hi1 /eqP ->. rewrite big1 // => j. by rewrite inE. - rewrite mul1R. + rewrite mul1r. apply eq_bigl => i. move Hrhs : (_ \in _) => [|] /=. case/imsetP : Hrhs => /= m1 Hm1 Hi. @@ -145,14 +148,14 @@ rewrite big_imset; last first. apply/esym. (* specialize the bigop for non-empty `V(i,n0):\n0 only *) rewrite /= (bigID [pred x | 'V(x, n0) :\ n0 == set0 ]) /=. -rewrite [X in (X * _)%R = _](_ : _ = R1); last first. +rewrite [X in (X * _)%R = _](_ : _ = 1); last first. rewrite big1 // => i /andP [] Hi1 /eqP Hi2. rewrite Hi2 DMCE. rewrite big1 //= => j. exfalso. rewrite cards0 /= in j. by case: j. -rewrite mul1R. +rewrite mul1r. apply eq_big. move=> i /=; by rewrite !inE. move=> i /andP [] Hi1 Hi2. @@ -259,8 +262,7 @@ transitivity (\sum_(x = d [~'V(m0, n0) :\ n0]) case/boolP : (k \in 'V(m0, n0) :\ n0) => K. by rewrite !dproj_in. do 2 rewrite dproj_out //. - case/boolP : (k == n0) => kn0. - by rewrite (eqP kn0). + have [->//|kn0] := eqVneq k n0. rewrite in_setD1 kn0 /= in K. exfalso. move/negP : K; apply. @@ -331,7 +333,7 @@ transitivity (\sum_(x = d [~'V(m1, n0) :\ n0]) case/boolP : (k \in 'V( m1, n0) :\ n0) => K. by do 2 rewrite dproj_in //. do 2 rewrite dproj_out //. - case/boolP : (k == n0) => [/eqP -> // |kn0]. + have [->//|kn0] := eqVneq k n0. rewrite in_setD1 kn0 /= in K. exfalso. move/negP : K; apply. @@ -424,22 +426,22 @@ Lemma estimation_correctness (d : 'rV_n) n0 : W `(y ``_ n0 | b) * \prod_(m0 in 'F n0) alpha m0 n0 d. Proof. move=> b P. -rewrite fdist_marginal_post_probE -2!mulRA; congr (_ * _). +rewrite fdist_marginal_post_probE -2!mulrA; congr (_ * _). transitivity (post_prob_uniform_cst [set cw in C] y * (\sum_(x = d [~ setT :\ n0]) W ``(y | x) * \prod_(m0 < m) (\delta ('V m0) x)%:R))%R. rewrite [RHS]big_distrr [in RHS]/=. apply eq_big => t; first by rewrite -freeon_all. rewrite inE andTb => td_n0. - rewrite post_prob_uniform_kernel -mulRA; congr (_ * _)%R. - rewrite mulRC; congr (_ * _)%R. + rewrite post_prob_uniform_kernel -mulrA; congr (_ * _)%R. + rewrite mulrC; congr (_ * _)%R. by rewrite checksubsum_in_kernel inE mem_kernel_syndrome0. congr (_ * _)%R. transitivity (W `(y ``_ n0 | b) * (\sum_(x = d [~ setT :\ n0]) W ``(y \# ~: [set n0] | x \# ~: [set n0]) * \prod_(m0 < m) (\delta ('V m0) x)%:R)). rewrite big_distrr /=; apply eq_bigr => t Ht. - rewrite mulRA; congr (_ * _)%R. + rewrite mulrA; congr (_ * _)%R. rewrite /b (freeon_notin Ht); last by rewrite !inE eqxx. rewrite DMCE (bigD1 n0) //=; congr (_ * _). rewrite DMCE rprod_sub_vec; apply eq_big => i //=. @@ -464,24 +466,24 @@ move=> /= m1 m0 t m1m0n0 tn0dn0; by rewrite checksubsum_dprojs_V. Qed. (* TODO: rename. move? *) -Definition K949 (n0 : 'I_n) df := / +Definition K949 (n0 : 'I_n) df := ((W Zp0 (y ``_ n0) * \prod_(m1 in 'F n0) alpha m1 n0 (df `[ n0 := Zp0 ])) + - W Zp1 (y ``_ n0) * \prod_(m1 in 'F n0) alpha m1 n0 (df `[ n0 := Zp1 ])). + W Zp1 (y ``_ n0) * \prod_(m1 in 'F n0) alpha m1 n0 (df `[ n0 := Zp1 ]))^-1. + +Let R := Rdefinitions.R. Lemma K949_lemma df n0 : K949 n0 df = marginal_post_prob_den y * post_prob_uniform_cst [set cw in C] y. Proof. -rewrite /K949 /marginal_post_prob_den /post_prob_uniform_cst -invRM; last 2 first. -- by rewrite FDist.f1; apply: lt0r_neq0. -- by rewrite -not_receivable_prop_uniform receivableP. -congr (/ _). +rewrite /K949 /marginal_post_prob_den /post_prob_uniform_cst -invfM. +congr (_^-1). transitivity (\sum_(t in 'rV['F_2]_n) if t \in kernel H then W ``(y | t) else 0); last first. rewrite big_distrl /=. apply eq_bigr => /= t Ht. case: ifP => HtH. rewrite fdist_post_probE fdist_uniform_supp_in ?inE //. - have HH : (#|[set cw in kernel H]|%:R)%mcR != 0. + have HH : (#|[set cw in kernel H]|%:R)%mcR != 0 :> R. (* the following three lines amount to INR_eq0 *) have->: 0 = GRing.natmul 1 0 by []. apply/eqP => /mulrIn /eqP. @@ -489,7 +491,7 @@ transitivity (\sum_(t in 'rV['F_2]_n) rewrite cards_eq0. by apply/set0Pn; exists t; rewrite inE. rewrite -(mulrC (W ``(y | t))) -[X in X = _]mulr1. - rewrite !coqRE -!mulrA. + rewrite -!mulrA. congr (_ * _). rewrite fdist_uniform_supp_restrict /= fdist_uniform_supp_distrr /=; last first. rewrite invrM; last 2 first. @@ -499,7 +501,7 @@ transitivity (\sum_(t in 'rV['F_2]_n) rewrite invrK [X in _ = _ * X]mulrAC mulVr ?mul1r ?coqRE ?mulVr //. by rewrite unitfE -not_receivable_prop_uniform receivableP. rewrite fdist_post_probE fdist_uniform_supp_notin; last by rewrite inE; exact/negbT. - by rewrite !coqRE !mul0r. + by rewrite !mul0r. rewrite -big_mkcond /=. rewrite /alpha. transitivity (W Zp0 (y ``_ n0) * @@ -538,9 +540,9 @@ transitivity (\sum_(ta : 'rV_n) W (ta ``_ n0) (y ``_ n0) * (\prod_(m1 in 'F n0) W ``(y \# 'V(m1, n0) :\ n0 | ta \# 'V(m1, n0) :\ n0)) * (\prod_(m1 in 'F n0) (\prod_(m2 in 'F(m1, n0)) (\delta ('V m2) ta)%:R))). apply eq_bigr => ta _. - rewrite -mulRA. + rewrite -mulrA. congr (_ * _). - by apply big_split. + by rewrite big_split. transitivity (\sum_(ta : 'rV_n) (\prod_(k < n) W (ta ``_ k) (y ``_ k)) * (\prod_(m1 in 'F n0) \prod_(m2 in 'F(m1, n0)) (\delta ('V m2) ta)%:R)). @@ -559,11 +561,11 @@ transitivity (\sum_(ta : 'rV_n) (\prod_(k < n) (W ta ``_ k) y ``_ k) * by rewrite -(rprod_Fgraph_part_fnode (Tanner.connected tanner) (Tanner.acyclic tanner) (fun m0 => (\delta ('V m0) t)%:R)). rewrite [in X in X = _](bigID [pred x | x \in kernel H]) /=. -rewrite addRC (eq_bigr (fun=> 0)); last first. - by move=> ta /negbTE Hta; rewrite checksubsum_in_kernel Hta mulR0. -rewrite big_const iter_addR mulR0 add0R. +rewrite addrC (eq_bigr (fun=> 0)); last first. + by move=> ta /negbTE Hta; rewrite checksubsum_in_kernel Hta mulr0. +rewrite big_const iter_addr mul0rn !add0r. apply eq_bigr => ta Ha. -by rewrite checksubsum_in_kernel Ha mulR1 -DMCE. +by rewrite checksubsum_in_kernel Ha mulr1 -DMCE. Qed. Local Notation "'beta'" := (beta H W y). @@ -575,10 +577,10 @@ Lemma filter_out_set0 m0 t (g : 'I_m -> 'rV['F_2]_n -> R) (s : {set 'I_n}) : | n1 in [set n1 in s | 'F n1 :\ m0 != set0]]) \prod_(x in A) (g x t). Proof. -rewrite (bigID [pred x | x == set0]) /= big1 ?mul1R; last first. +rewrite (bigID [pred x | x == set0]) /= big1 ?mul1r; last first. move=> ms. case/andP => _ /eqP ->; by rewrite big_set0. -apply eq_bigl => /= ms. +apply: eq_bigl => /= ms. apply/esym/imsetP. case: ifPn. case/andP => /imsetP[n1 Hn1 Hms Hms']. @@ -694,11 +696,11 @@ transitivity (\sum_(x = d [~'V(m0, n0) :\ n0]) (* get W(tb|t) out of beta *) rewrite /alpha. apply eq_bigr => /= t Ht. - rewrite -[in X in _ = X]mulRA -[in X in _ = X]mulRC -[in X in _ = X]mulRA. + rewrite -[in X in _ = X]mulrA -[in X in _ = X]mulrC -[in X in _ = X]mulrA. congr (_ * _)%R. rewrite (bigD1 m0) /=; last by apply Fgraph_m0. - rewrite mulRC; congr (_ * _)%R. - transitivity (\prod_(i in 'F(m0, n0) :\ m0) (\delta ('V i) t)%:R). + rewrite mulrC; congr (_ * _)%R. + transitivity (\prod_(i in 'F(m0, n0) :\ m0) (\delta ('V i) t)%:R : R). apply eq_bigl => /= m1. by rewrite 2![in X in _ = X]inE andbC. rewrite -(cover_Fgraph_part_Fgraph (Tanner.acyclic tanner)) //. @@ -713,8 +715,8 @@ transitivity (\sum_(x = d [~'V(m0, n0) :\ n0]) by apply: (another_Fgraph_injective (Tanner.acyclic tanner) Hn1 Hn2 H1). transitivity (\prod_(n1 < n | (n1 \in 'V m0 :\ n0) && ('F n1 :\ m0 != set0)) \prod_(m1 in 'F n1 :\ m0) - \prod_(m2 in 'F(m1, n1)) (\delta ('V m2) t)%:R); last first. - rewrite [in RHS](bigID [pred x | 'F x :\ m0 == set0]) /= [in RHS]big1 ?mul1R //. + \prod_(m2 in 'F(m1, n1)) (\delta ('V m2) t)%:R :> R); last first. + rewrite [in RHS](bigID [pred x | 'F x :\ m0 == set0]) /= [in RHS]big1 ?mul1r //. move=> n1 /andP [] H1 /eqP ->; by rewrite !big_set0. apply eq_big => /= n1; first by rewrite !inE. move=> Hn1. @@ -729,10 +731,10 @@ transitivity (\sum_(x = d [~'V(m0, n0) :\ n0]) ((W ``(y \# 'V(m1, n1) :\ n1 | x \# 'V(m1, n1) :\ n1)) * \prod_(m2 in 'F(m1, n1)) (\delta ('V m2) x)%:R))). apply eq_bigr => /= t Ht. - rewrite -mulRA; congr (_ * _). + rewrite -mulrA; congr (_ * _). rewrite DMC_sub_vec_Vgraph // -big_split /=. apply eq_bigr => /= n1 _. - by rewrite -mulRA big_split. + by rewrite -mulrA big_split. transitivity (\sum_(x = d [~('V m0) :\ n0]) \sum_(x' = d [~'V(m0, n0) :\ n0] | [pred x' | dproj d ('V m0 :\ n0) x' == x]) (\delta ('V m0) x')%:R * @@ -763,7 +765,7 @@ Lemma beta_one_successor n1 m1 d : 'F n1 = [set m1] -> beta n1 m1 d = W (d ``_ n1) (y ``_ n1). Proof. move=> Fn1. -rewrite /beta -[X in _ = X]mulR1. +rewrite /beta -[X in _ = X]mulr1. congr (_ * _). set g := BIG_F. transitivity (\prod_(i in set0) g i). @@ -782,7 +784,7 @@ rewrite recursive_computation; last first. rewrite Vm1. rewrite -{1}(setU0 [set n1]) setU1K; last by rewrite in_set0. rewrite rsum_freeon0. -rewrite -[X in _ = X]mulR1 checksubsum_set1; congr (_ * _). +rewrite -[X in _ = X]mulr1 checksubsum_set1; congr (_ * _). rewrite big_pred0 // => /= n2. by rewrite in_setD1 in_set1 andNb. Qed. @@ -796,17 +798,16 @@ rewrite Hm1 (_ : [set n1; n2] :\ n1 = [set n2]); last by rewrite setU1K // in_se rewrite rsum_freeon1 2!big_set1. do 2 rewrite checksubsum_set2 //. rewrite [in X in X%:R]/row_set !mxE (negbTE n1n2) eqxx. -case/boolP : (d ``_ n1 == Zp0). - move/eqP => dn1. - by rewrite dn1 mul1R /= mul0R addR0. -rewrite mul0R add0R -F2_eq1 => /eqP ->. -by rewrite eqxx mul1R. +have [->|] := eqVneq (d ``_ n1) Zp0. + by rewrite mul1r /= mul0r addr0. +rewrite mul0r add0r -F2_eq1 => /eqP ->. +by rewrite eqxx mul1r. Qed. End sum_prod_correctness. Section ldpc_approx_algo. - +Let R := Rdefinitions.R. Variables (m n : nat) (H : 'M['F_2]_(m, n)). Variables (B : finType) (W : `Ch('F_2, B)). Variable y : n.-tuple B. @@ -837,13 +838,13 @@ Fixpoint sumproduct_loop (lmax : nat) (beta0 beta1 : 'M_(m, n)) : option ('rV['F | O => None (* Symbol "?" *) | lmax'.+1 => let nalpha m0 n0 x := - let K := / (alpha_fun m0 n0 (beta0, beta1) 0 + alpha_fun m0 n0 (beta0, beta1) 1) in + let K := (alpha_fun m0 n0 (beta0, beta1) 0 + alpha_fun m0 n0 (beta0, beta1) 1)^-1 in (K * alpha_fun m0 n0 (beta0, beta1) x)%R in let alpha0 : 'M_(m, n) := \matrix_(m0 < m, n0 < n) nalpha m0 n0 0 in let alpha1 : 'M_(m, n) := \matrix_(m0 < m, n0 < n) nalpha m0 n0 1 in let nbeta m0 n0 x alpha := - let K := / (beta_fun m0 n0 Zp0 alpha + beta_fun m0 n0 Zp1 alpha) in + let K := (beta_fun m0 n0 Zp0 alpha + beta_fun m0 n0 Zp1 alpha)^-1 in (K * beta_fun m0 n0 x alpha)%R in let beta0 := \matrix_(m0 < m, n0 < n) nbeta m0 n0 0 alpha0 in let beta1 := \matrix_(m0 < m, n0 < n) nbeta m0 n0 1 alpha1 in diff --git a/ecc_modern/ldpc_algo.v b/ecc_modern/ldpc_algo.v index 65a37c29..c65a7389 100644 --- a/ecc_modern/ldpc_algo.v +++ b/ecc_modern/ldpc_algo.v @@ -1,10 +1,10 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From HB Require Import structures. -Require Import Init.Wf Recdef Reals. +Require Import Init.Wf Recdef. From mathcomp Require Import all_ssreflect perm zmodp matrix ssralg ssrnum. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext f2 subgraph_partition tanner. +From mathcomp Require Import Rstruct reals ring lra. +Require Import f2 subgraph_partition tanner. Require Import fdist channel pproba linearcode ssralg_ext. Require Import tanner_partition summary ldpc checksum. @@ -34,8 +34,10 @@ Import Prenex Implicits. Local Open Scope seq_scope. Local Open Scope vec_ext_scope. + Section Tree. Variable id : Type. +Let R := Rdefinitions.R. Definition R2 := (R * R)%type. Inductive kind : Set := kf | kv. @@ -64,9 +66,7 @@ Arguments node_id {id k U D} t. Arguments up {id k U D} t. Section Algo. - -Open Scope R_scope. - +Local Open Scope ring_scope. Variable id : Type. Let tn_tree' := tn_tree id. @@ -86,7 +86,7 @@ Proof. by move=> -[a0 a1] [b0 b1] [c0 c1] /=; f_equal; ring. Qed. Lemma alphaC : commutative alpha_op. Proof. by move=> -[a0 a1] [b0 b1]/=; f_equal; ring. Qed. -Lemma alpha0x : left_id (R1, R0) alpha_op. +Lemma alpha0x : left_id (1, 0)%R alpha_op. Proof. by move=> -[a0 a1] /=; f_equal; ring. Qed. HB.instance Definition _ := @Monoid.isComLaw.Build _ _ _ alphaA alphaC alpha0x. @@ -114,7 +114,7 @@ Proof. by move=> -[a0 a1] [b0 b1] [c0 c1] /=; f_equal; ring. Qed. Lemma betaC : commutative beta_op. Proof. by move=> -[a0 a1] [b0 b1]/=; f_equal; ring. Qed. -Lemma beta0x : left_id (R1, R1) beta_op. +Lemma beta0x : left_id (1, 1)%R beta_op. Proof. by move=> -[a0 a1] /=; f_equal; ring. Qed. HB.instance Definition _ := @Monoid.isComLaw.Build _ _ _ betaA betaC beta0x. @@ -150,9 +150,11 @@ Fixpoint seqs_but1 (a b : seq R2) := Definition apply_seq {A B : Type} (l1 : seq (A -> B)) (l2 : seq A) : seq B := map (fun (p : (A -> B) * A) => (fst p) (snd p)) (zip l1 l2). +Let R := Rdefinitions.R. + (** Get input from above *) Definition push_init down := - if down is Some p then ([::p], p) else ([::], (1,1)). + if down is Some p then ([::p], p) else ([::], ((1:R),(1:R))). (** Propagate from root to leaves *) Fixpoint sumprod_down {k} (n : tn_tree' k R2 unit) (from_above : option R2) @@ -189,20 +191,20 @@ Extract Inductive bool => "bool" [ "true" "false" ]. Extract Inductive seq => "list" [ "[]" "(::)" ]. Extract Inductive prod => "(*)" [ "(,)" ]. Extract Inductive option => "option" ["Some" "None"]. -Extract Inlined Constant R => "float". -Extract Inlined Constant R0 => "0.". -Extract Inlined Constant R1 => "1.". -Extract Constant RbaseSymbolsImpl.R => "float". -Extract Constant RbaseSymbolsImpl.R0 => "0.". -Extract Constant RbaseSymbolsImpl.R1 => "1.". +Extract Inlined Constant Rdefinitions.R => "float". +Extract Inlined Constant Rdefinitions.R0 => "0.". +Extract Inlined Constant Rdefinitions.R1 => "1.". +Extract Constant Rdefinitions.RbaseSymbolsImpl.R => "float". +Extract Constant Rdefinitions.RbaseSymbolsImpl.R0 => "0.". +Extract Constant Rdefinitions.RbaseSymbolsImpl.R1 => "1.". Extract Inductive ConstructiveCauchyReals.CReal => "float" ["assert false"]. Extract Constant ClassicalDedekindReals.DReal => "float". Extract Constant ClassicalDedekindReals.DRealRepr => "(fun x -> x)". Extract Constant ClassicalDedekindReals.DRealAbstr => "(fun x -> x)". -Extract Constant Rmult => "( *.)". -Extract Constant Rplus => "(+.)". -Extract Constant Rinv => "fun x -> 1. /. x". -Extract Constant Ropp => "(~-.)". +Extract Constant Rdefinitions.Rmult => "( *.)". +Extract Constant Rdefinitions.Rplus => "(+.)". +Extract Constant Rdefinitions.Rinv => "fun x -> 1. /. x". +Extract Constant Rdefinitions.Ropp => "(~-.)". Extraction "extraction/sumprod.ml" sumprod estimation. Section ToGraph. @@ -331,7 +333,7 @@ Definition msg_spec (i j : sumbool_ord m n) : R2 := match i, j with | inl m0, inr n0 => p01 (alpha' m0 n0) n0 | inr n0, inl m0 => p01 (beta' n0 m0) n0 - | _, _ => (R0,R0) + | _, _ => (0,0) end. Definition prec_node (s : seq (sumbool_ord m n)) := @@ -358,7 +360,7 @@ Fixpoint build_computed_tree h s k i : tn_tree (sumbool_ord m n) k R2 R2 := [seq msg_spec x a | x in finset (tanner_rel H a) :\: finset (mem_seq (prec_node s))]) match s with - | [::] => (R1,R1) + | [::] => (1,1) | b :: _ => alpha_beta (tag_of_id rW b) [seq msg_spec x b | x in finset (tanner_rel H b) :\ a] diff --git a/ecc_modern/ldpc_algo_proof.v b/ecc_modern/ldpc_algo_proof.v index b480871a..c4437e03 100644 --- a/ecc_modern/ldpc_algo_proof.v +++ b/ecc_modern/ldpc_algo_proof.v @@ -1,10 +1,10 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From HB Require Import structures. -Require Import Wf_nat Init.Wf Recdef Reals. +Require Import Wf_nat Init.Wf Recdef. From mathcomp Require Import all_ssreflect perm zmodp matrix ssralg ssrnum. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext ssr_ext ssralg_ext bigop_ext f2. +From mathcomp Require Import Rstruct reals ring lra. +Require Import ssr_ext ssralg_ext bigop_ext f2. Require Import fdist channel pproba linearcode subgraph_partition tanner. Require Import tanner_partition summary ldpc checksum ldpc_algo. @@ -29,6 +29,8 @@ Unset Strict Implicit. Import Prenex Implicits. Open Scope seq_scope. +Local Open Scope ring_scope. +Import GRing.Theory. Section TnTreeEq. @@ -90,7 +92,7 @@ Lemma tn_tree_eqP k : Equality.axiom (@tn_tree_eq_bool k). Proof. move=> x. pose d := depth x. -have Hd: depth x <= d by []. +have Hd: (depth x <= d)%N by []. clearbody d. elim: d k x Hd => [|d IHd] k x Hd y. by destruct x; rewrite ltn0 in Hd. @@ -137,9 +139,6 @@ Variables (m n : nat) (H : 'M['F_2]_(m, n.+1)). Hypothesis tanner_acyclic : acyclic' (tanner_rel H). Hypothesis tanner_connected : forall a b, connect (tanner_rel H) a b. -Import GRing.Theory. -Local Open Scope ring_scope. - Variable rW : 'I_n.+1 -> R2. Lemma select_children_spec s k i j : @@ -588,17 +587,16 @@ Qed. End BuildTreeOk. Section BuildTreeTest. -Let m := 2. -Let n := 3. +Let R := Rdefinitions.R. +Let m := 2%N. +Let n := 3%N. Let id' := sumbool_ord m n. -Import GRing.Theory. -Local Open Scope ring_scope. Let F (i : 'I_m) (j : 'I_n) := (j == widen_ord (leqnSn 2) i) || (j == lift 0 i). Let H := \matrix_(i<2,j<3) (F i j : 'F_2). -Let rW (i : 'I_n) := (R0,R1). +Let rW (i : 'I_n) : R*R := (0,1)%R. (* How can we make this to compute? *) (* Eval compute in @build_tree 3 2 H f0 0. *) @@ -652,11 +650,11 @@ elim: h a => [|h Hh] a. move: (ltn_ord a). by rewrite ltn0. rewrite /= in_cons. -case/boolP : (_ == _) => //= a_not_h. +have [//=|a_not_h] := eqVneq a (Ordinal (ltnSn h)). suff a_ltn_h : (a < h)%N. apply/mapP. exists (Ordinal a_ltn_h) => //. - by apply val_inj. + exact/val_inj. by rewrite ltn_neqAle a_not_h /= -ltnS. Qed. @@ -755,12 +753,8 @@ Variable vb : (`U C_not_empty).-receivable W. Local Notation "''V'" := (Vnext H). Local Notation "''F'" := (Fnext H). -Local Open Scope ring_scope. - Let rW n0 := (W 0 (vb ``_ n0), W 1 (vb ``_ n0)). -Close Scope ring_scope. - Let id' := sumbool_ord m n. Let tn_tree' k := tn_tree id' k R2 R2. @@ -792,7 +786,7 @@ Lemma children_ind {i U V : eqType} Proof. move=> HP k t. set h := depth t. -have : depth t <= h by []. +have : (depth t <= h)%N by []. clearbody h. move: k t. elim: h => [|h IH] k t Hh. @@ -849,7 +843,7 @@ exact: (negbFE Hi2l). Qed. Corollary msg_nonnil (i1 i2 : id') i {k} t : - size (@msg _ _ i1 i2 i k t) > 0 -> + (size (@msg _ _ i1 i2 i k t) > 0)%N -> i1 \in i ++ labels t /\ i2 \in i ++ labels t. Proof. move=> Hsz. @@ -911,7 +905,7 @@ have {}IHc: size (flatten [seq msg i1 i2 None i | i <- l]) = case Ha: (graph a i1 i2). have Hsz:= f_equal nat_of_bool Ha. rewrite -(IH _ _ Huna) in Hsz; last by rewrite in_cons eqxx. - have Hsz': size (msg i1 i2 None a) > 0 by rewrite Hsz. + have Hsz': (size (msg i1 i2 None a) > 0)%N by rewrite Hsz. have {Hsz'}[/= Hi1' Hi2']:= msg_nonnil Hsz'. suff ->: size (flatten [seq msg i1 i2 None i | i <- l]) = 0 by rewrite addn0. rewrite size_flatten sumnE big_seq/= big1// => i. @@ -927,8 +921,6 @@ Qed. Let beta' := ldpc.beta H W vb. Let alpha' := ldpc.alpha H W vb. -Local Open Scope ring_scope. - Lemma beta_def n0 m0 (d : 'rV_n) : let d0 := d `[ n0 := 0 ] in let d1 := d `[ n0 := 1 ] in @@ -943,13 +935,11 @@ have [e He [ue Pe perme]] := big_enumP _. rewrite {3 5}/row_set !mxE !eqxx /=. move: (W 0 (vb ``_ n0)) (W 1 (vb ``_ n0)). elim: e {He ue Pe perme} => [|a l IH] p0 p1. - by rewrite /= !big_nil !mulR1. -by rewrite /= !big_cons /= IH // !mulRA. + by rewrite /= !big_nil !mulr1. +by rewrite /= !big_cons /= IH // !mulrA. Qed. -Local Open Scope R_scope. - -Lemma rmul_foldr_rsum {I A} {X : finType} (a : R) (g : I -> X -> A -> A) +Lemma rmul_foldr_rsum (R := Rdefinitions.R) {I A} {X : finType} (a : R) (g : I -> X -> A -> A) (F0 : A -> R) l d : a * foldr (fun n1 (F : A -> R) t => \sum_(x in X) F (g n1 x t)) @@ -988,26 +978,25 @@ rewrite GRing.addrC /checksubsum F2_of_bool_addr. congr (F2_of_bool ((_ + _)%R == _)). apply congr_big => // i. rewrite !inE. - case/boolP : (i == n0) => [ /eqP -> | ] /=. - by apply/negbTE. + have [->|] := eqVneq i n0; first exact/negbTE. by rewrite andbT. rewrite !inE !mxE. -case/boolP : (i == n0) => [/eqP -> | ]. +have [->|] := eqVneq i n0. by rewrite (negbTE n0_l). -case/boolP : (i == n1) => [/eqP -> | //]. +have [->|//] := eqVneq i n1. by rewrite (negbTE n1_l). Qed. -Lemma alpha_def_sub m0 n1 n0 (x y : 'F_2) (l : seq 'I_n) d : +Lemma alpha_def_sub (R := Rdefinitions.R) m0 n1 n0 (x y : 'F_2) (l : seq 'I_n) d : n1 \notin l -> uniq l -> n0 != n1 -> n0 \notin l -> n1 \in 'V m0 :\ n0 -> {subset l <= 'V m0 :\ n0} -> beta' n1 m0 (d`[n1 := x]) * foldr (fun n2 (F : 'rV_n -> R) t => \sum_(x in 'F_2) F (t`[n2 := x])) - (fun t => INR (t ``_ n0 != \delta [set x in l] t) * + (fun t => (t ``_ n0 != \delta [set x in l] t)%:R * (\prod_(n3 in [set x in l]) beta' n3 m0 t)) l (d`[n0 := x + y])%R = foldr (fun n2 (F : 'rV_n -> R) t => \sum_(x in 'F_2) F (t`[n2 := x])) - (fun t => INR (t ``_ n0 != \delta [set x in n1 :: l] t) * + (fun t => (t ``_ n0 != \delta [set x in n1 :: l] t)%:R * (\prod_(n3 in [set x in n1 :: l]) beta' n3 m0 t)) l ((d`[n0 := y])`[n1 := x]). Proof. @@ -1027,25 +1016,24 @@ elim: l' => [|hd tl IH] /= in d n1_l' n0_l' *. rewrite [X in _ = _ * X](bigD1 n1) /=; last by rewrite !inE eqxx. rewrite (@beta_inva _ _ _ _ W _ _ m0 _ ((d`[n0 := y])`[n1 := x])) //; last first. by rewrite !mxE eqxx. - rewrite mulRA mulRA [X in _ = X * _]mulRC. + rewrite mulrA mulrA [X in _ = X * _]mulrC. congr (_ * _). - congr (_ * INR _). + congr (_ * _%:R). rewrite row_setC; last by rewrite eq_sym. by rewrite !mxE eqxx (@checksubsum_add n1). apply congr_big => // i. rewrite !inE. move: n1_l. - case/boolP : (i == n1) => [/eqP -> |] /=. - by move/negbTE. + have [-> /negbTE//|] := eqVneq i n1. by rewrite andbT. rewrite inE => i_l. apply beta_inva. by move: (Hsub _ i_l); rewrite in_setD1; case/andP. rewrite !mxE. move: i_l. - case/boolP : (i == n0) => [/eqP -> |]. - by rewrite (negbTE n0_l). - case/boolP : (i == n1) => [/eqP -> |//]. + have [->|] := eqVneq i n0. + by rewrite (negbTE n0_l). + have [->|//] := eqVneq i n1. by rewrite (negbTE n1_l). apply eq_bigr => i _. rewrite row_setC; last first. @@ -1073,11 +1061,11 @@ move=> Hn0. rewrite /alpha' !recursive_computation /alpha //; first last. by apply tanner. by apply tanner. -rewrite (eq_bigr (fun t : 'rV_n => INR ((t ``_ n0) != \delta ('V m0 :\ n0) t) * +rewrite (eq_bigr (fun t : 'rV_n => ((t ``_ n0) != \delta ('V m0 :\ n0) t)%:R * (\prod_(n1 in 'V m0 :\ n0) beta' n1 m0 t))); last first. by move=> i _; rewrite (checksubsum_D1 _ Hn0) eq_sym. rewrite [in X in _ = (_, X)](eq_bigr (fun t : 'rV_n => - INR ((t ``_ n0) != \delta ('V m0 :\ n0) t) * + ((t ``_ n0) != \delta ('V m0 :\ n0) t)%:R * (\prod_(n1 in 'V m0 :\ n0) beta' n1 m0 t))); last first. move=> i _; by rewrite (checksubsum_D1 _ Hn0) eq_sym. rewrite !summary_powersetE !summary_foldE /summary_fold /=. @@ -1089,7 +1077,7 @@ have Hl : {subset enum f <= f} by move=> ?; rewrite mem_enum. elim: (enum (mem _)) (enum_uniq (mem f)) => [|a l IH] /= Hun in Hn0 Hl *. rewrite /checksubsum. rewrite !big_pred0 /=; try by move=> i /=; rewrite !inE in_nil. - by rewrite !mxE !eqxx /= !mulR1. + by rewrite !mxE !eqxx /= !mulr1. case/andP: Hun => a_l Hun. rewrite in_cons in Hn0. case/norP: Hn0 => Hn0a Hn0. @@ -1105,7 +1093,7 @@ congr pair. rewrite -[in X in _ * foldr _ _ _ X = _](GRing.add0r 0)%R. by apply alpha_def_sub. rewrite -[in X in _ * foldr _ _ _ X = _](GRing.addr0 1%R). - by rewrite alpha_def_sub // addR0. + by rewrite alpha_def_sub //= addr0. rewrite (bigD1 (0%R : 'F_2)) //=. rewrite (bigD1 (1%R : 'F_2)) //=. rewrite big_pred0; last by case/F2P. @@ -1113,7 +1101,7 @@ congr (_ + _). rewrite -[in X in _ * foldr _ _ _ X = _](GRing.add0r 1%R). by apply alpha_def_sub. rewrite -[in X in _ * foldr _ _ _ X = _](GRing.addrr_char2 (@char_Fp 2 erefl) 1%R). -by rewrite alpha_def_sub // addR0. +by rewrite alpha_def_sub // addr0. Qed. Lemma graph_sumprod_up k (t : tn_tree id' k unit unit) : @@ -1221,7 +1209,7 @@ congr (f c _ :: _). apply/esym/all_filterP/allP => i. rewrite map_cat cat_uniq /= in Hun. case/and4P : Hun => _ /norP [] Hinl _ Hcl _. - case/boolP : (node_id i == node_id c) => //= /eqP Hic. + have [Hic|//] := eqVneq (node_id i) (node_id c). rewrite mem_cat => /orP [] /(map_f node_id). - by rewrite Hic (negbTE Hinl). - by rewrite Hic (negbTE Hcl). @@ -1272,11 +1260,11 @@ by destruct (push_init dn). Qed. Lemma alpha_map {A} F (l : seq A) : - alpha (map F l) = \big[alpha_op/(R1,R0)]_(i <- l) F i. + alpha (map F l) = \big[alpha_op/(1,0)]_(i <- l) F i. Proof. by rewrite /alpha foldrE big_map. Qed. Lemma beta_map {A} F w (l : seq A) : - beta w (map F l) = beta_op w (\big[beta_op/(R1,R1)]_(i <- l) F i). + beta w (map F l) = beta_op w (\big[beta_op/(1,1)]_(i <- l) F i). Proof. by rewrite /beta foldlE /= big_cons big_map. Qed. Lemma kind_filter {A : eqType} k i (s : {set ord_of_kind m n' (negk k)}) @@ -1454,7 +1442,7 @@ Proof. by destruct s. Qed. Lemma push_init_spec s i : push_init (down_msg s i) = ((omap (msg_spec' ^~ i) (prec_node s) : seq R2), - oapp (msg_spec' ^~ i) (R1,R1) (prec_node s)). + oapp (msg_spec' ^~ i) (1,1) (prec_node s)). Proof. by destruct s. Qed. Local Notation build_computed_tree := (build_computed_tree vb d). @@ -1925,7 +1913,7 @@ rewrite -tree_ok // labels_sumprod_down labels_sumprod_up in Hn0l. by exists (inr n0). Qed. -Lemma big_beta_mul (A : finType) (F1 F2 : A -> R) (l : pred A) : +Lemma big_beta_mul (R := Rdefinitions.R) (A : finType) (F1 F2 : A -> R) (l : pred A) : \big[beta_op/(1,1)]_(i <- enum l) (F1 i, F2 i) = (\prod_(i in l) F1 i , \prod_(i in l) F2 i). Proof. @@ -1955,12 +1943,11 @@ rewrite !estimation_correctness; last 2 first. rewrite -!(K949_lemma vb tanner d n0). rewrite /K949 /normalize. rewrite beta_map big_beta_mul /=. -rewrite /Rdiv. congr pair. - rewrite mulRC /alpha' !mxE. - by rewrite eqxx mulRA. -rewrite mulRC /alpha' !mxE. -by rewrite eqxx mulRA. + rewrite mulrC /alpha' !mxE. + by rewrite eqxx mulrA. +rewrite mulrC /alpha' !mxE. +by rewrite eqxx mulrA. Qed. Lemma subseq_estimation k (t : tn_tree' k) : diff --git a/ecc_modern/ldpc_erasure.v b/ecc_modern/ldpc_erasure.v index c03525cf..7da48470 100644 --- a/ecc_modern/ldpc_erasure.v +++ b/ecc_modern/ldpc_erasure.v @@ -4,7 +4,7 @@ From HB Require Import structures. Require Program.Wf. From mathcomp Require Import all_ssreflect ssralg fingroup finalg perm zmodp. From mathcomp Require Import matrix. -Require Import ssr_ext ssralg_ext num_occ f2 ssrR hamming tanner linearcode. +Require Import ssr_ext ssralg_ext num_occ f2 hamming tanner linearcode. (******************************************************************************) (* Sum-Product Decoder over the BEC *) @@ -285,11 +285,11 @@ Lemma Prod_map_not_Star m n (A : 'M_(m, n)) n0 (s : {set 'I_m}) : exists b m1, m1 \in s /\ A m1 n0 = Bit b. Proof. rewrite Prod_StarE negb_forall => /existsP[b Hb]. -case/boolP : (N(Bit (F2_of_bool (b : bool)) | [seq A m1 n0 | m1 in s]) == O) => [H0|]. +have [H0|] := eqVneq (N(Bit (F2_of_bool (b : bool)) | [seq A m1 n0 | m1 in s])) O. have : 0 < N(Bit (F2_of_bool (~~ b)) | [seq A m1 n0 | m1 in s]). - by rewrite lt0n; apply: contra Hb => /eqP ->. + by rewrite lt0n; apply: contra Hb => /eqP ->; exact/eqP. rewrite lt0n -notin_num_occ_0 negbK => /mapP[i Hi]. - exists (F2_of_bool (~~ b)), i; by rewrite mem_enum in Hi. + by exists (F2_of_bool (~~ b)), i; rewrite mem_enum in Hi. rewrite -notin_num_occ_0 negbK => /mapP[i Hi] H1. exists (F2_of_bool b), i; by rewrite mem_enum in Hi. Qed. @@ -382,7 +382,7 @@ move=> Hle. suff : (num_stars A <= num_stars B) && ((num_stars A == num_stars B) ==> \big[andb/true]_(i < m) (row i A == row i B)). case/andP => A_le_B. - case/boolP : (_ == _) => [A_eq_B|A_not_B _] /=. + have [A_eq_B|A_not_B _] := eqVneq (num_stars A) (num_stars B). rewrite big_all => Hall. apply/orP; left. apply/eqP/row_matrixP => i. diff --git a/ecc_modern/stopping_set.v b/ecc_modern/stopping_set.v index 2dca2119..e756b7d1 100644 --- a/ecc_modern/stopping_set.v +++ b/ecc_modern/stopping_set.v @@ -717,7 +717,9 @@ Qed. Lemma starFnext_iter_mxSumProd (Hc : syndrome H c = 0) l : starFnext H y (iSP_BEC0 H y l) = erasures (Esti H y (iSP_BEC0 H y l)). -Proof. case: l => [|l]; [exact starFnext_mxStar | exact: starFnext_iter_mxSumProdS]. Qed. +Proof. +case: l => [|l]; [exact starFnext_mxStar | exact: starFnext_iter_mxSumProdS]. +Qed. End starFnext_prop. @@ -848,7 +850,7 @@ have [H1 H2] : (forall m1, m1 \in `F n1 :\ m0 -> iSP_BEC0 H y l m1 n1 = Star) /\ rewrite inE H2 eqxx /=. apply/forallP => m2. apply/implyP => Hm2. -case/boolP : (m2 == m0) => [/eqP ?|m2m0]. +have [?|m2m0] := eqVneq m2 m0. subst m2. suff : (iSP_BEC0 H y l) m0 n1 = Star. by rewrite -{1}Hstable /= => ->. diff --git a/ecc_modern/summary.v b/ecc_modern/summary.v index 197cc138..45543a92 100644 --- a/ecc_modern/summary.v +++ b/ecc_modern/summary.v @@ -1,9 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg fingroup finalg zmodp matrix. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssr_ext ssralg_ext ssrR f2. +From mathcomp Require Import Rstruct reals. +Require Import ssr_ext ssralg_ext f2. (******************************************************************************) (* The Summary Operator *) @@ -75,7 +74,7 @@ Qed. Lemma freeon_row_set n0 (d : 'rV[A]_n) x : freeon [set n0] d (d `[ n0 := x ]). Proof. apply/forallP => /= i; rewrite !inE !mxE. -case/boolP : (i == n0) => //; by rewrite implyTb. +by have [//|] := eqVneq i n0; rewrite implyTb. Qed. End free_on. @@ -98,19 +97,16 @@ move: (X b) => /implyP; apply. by rewrite in_set1. Qed. -Local Open Scope R_scope. - (** sum over vectors t whose V projection is free and its complemented fixed by d *) Notation "\sum_ ( x '=' d [~ s ] ) F" := (\sum_( x | freeon s d x ) F) : summary_scope. Notation "\sum_ ( x '=' d [~ s ] '|' P ) F" := (\sum_( x | freeon s d x && P x) F) : summary_scope. -Local Close Scope R_scope. Local Open Scope summary_scope. Section rsum_freeon. - +Let R := Rdefinitions.R. Variable n : nat. Lemma rsum_freeon0 (d : 'rV['F_2]_n) (F : 'rV_n -> R) : @@ -131,20 +127,18 @@ rewrite big_imset /=; last by exact: inj_row_set. rewrite (bigID (pred1 Zp0)) /= (big_pred1 Zp0) //. rewrite (bigID (pred1 Zp1)) /= (big_pred1 Zp1); last by case/F2P. rewrite big_pred0; last by case/F2P. -by rewrite addR0. +by rewrite GRing.addr0. Qed. End rsum_freeon. Section alternative_definitions_of_summary. - +Let R := Rdefinitions.R. Variables n : nat. -Local Open Scope R_scope. Definition summary_powerset (X : {set 'I_n}) (d : 'rV['F_2]_n) (e : 'rV_n -> R) := let bvect s := \row_(i < n) if i \in X then F2_of_bool (i \in s) else d ``_ i in \sum_(s in powerset X) e (bvect s). -Local Close Scope R_scope. Local Open Scope tuple_ext_scope. @@ -258,13 +252,9 @@ Qed. Local Close Scope tuple_ext_scope. -Local Open Scope R_scope. - -Definition summary_fold (X : {set 'I_n}) d e := +Definition summary_fold (X : {set 'I_n}) d e : R := foldr (fun i F t => \sum_(b in 'F_2) F (t `[ i := b ])) e (enum X) d. -Local Close Scope R_scope. - Lemma set_mem {T : finType} (s : {set T}) : s = finset (ssrbool.mem (enum s)). Proof. apply/setP=> i. by rewrite !inE mem_enum. Qed. @@ -299,13 +289,14 @@ apply eq_big=> j; last first. move=> Hi. congr e. apply/rowP => k; rewrite !mxE !inE /=. - case/boolP : (k == n1) => Hkn1 /=. - rewrite (eqP Hkn1) (negbTE Hn1). + have [Hkn1|Hkn1] := eqVneq k n1. + rewrite Hkn1 (negbTE Hn1). case: ifP Hi => [? Hi|? /=]. by rewrite in_setU1 eqxx. by move=> -/andP[/andP[_ /eqP -> _ //]]. - case: ifP => //; case: ifP => //. - by rewrite in_setU1 (negbTE Hkn1) orFb. + case: ifP => //; case: ifPn => //=. + by rewrite /= in_setU1 (negbTE Hkn1) orFb => _ ->. + by move=> _ ->. case: ifP => [Hi|Hi]. - rewrite /powerset !inE eqxx andbT /=. case/boolP : (j \subset [set i in s]) => Hj. @@ -333,15 +324,17 @@ case: ifP => [Hi|Hi]. rewrite eqxx andbT. have -> : j :\ n1 = j. apply/setP => k; rewrite !inE. - case/boolP : (k == n1) => //= /eqP ->; by rewrite (negbTE Hn1j). + have [->/=|//] := eqVneq k n1. + exact/esym/negbTE. rewrite eqxx andbT. apply/subsetP=> k Hk. move/subsetP/(_ _ Hk): Hj. - rewrite !inE => ->; by rewrite orbT. + by rewrite !inE => ->; rewrite orbT. case/boolP : (n1 \in j) => Hn1j; first by rewrite /= andbF. have -> : j :\ n1 = j. apply/setP => k; rewrite !inE. - case/boolP : (k == n1) => //= /eqP ->; by rewrite (negbTE Hn1j). + have [/= ->|//] := eqVneq k n1. + exact/esym/negbTE. rewrite !eqxx !andbT. apply/subsetP => Hjs. move/subsetP: Hj; apply => k Hk. diff --git a/ecc_modern/summary_tanner.v b/ecc_modern/summary_tanner.v index 42465fb5..484025bd 100644 --- a/ecc_modern/summary_tanner.v +++ b/ecc_modern/summary_tanner.v @@ -1,9 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum fingroup finalg zmodp matrix. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssr_ext ssralg_ext ssrR Reals_ext f2 summary. +From mathcomp Require Import all_ssreflect ssralg ssrnum fingroup finalg zmodp. +From mathcomp Require Import matrix lra ring. +From mathcomp Require Import Rstruct reals. +Require Import ssr_ext ssralg_ext f2 summary. Require Import subgraph_partition tanner tanner_partition fdist channel. Require Import checksum. @@ -288,9 +288,8 @@ by move/freeon_notin => ->. Qed. Local Open Scope summary_scope. -Local Open Scope R_scope. -Lemma rmul_rsum_commute0 d n0 (B : finType) (t : 'rV[B]_n) +Lemma rmul_rsum_commute0 (R := Rdefinitions.R) d n0 (B : finType) (t : 'rV[B]_n) (W : forall m, 'rV_m -> 'rV_m -> R) (* channel *) (F : 'I_m -> 'rV_n -> R) (HF : forall m1 m0 (t' : 'rV_n), m1 \in 'F(m0, n0) -> t' ``_ n0 = d ``_ n0 -> F m1 ((dprojs_V H d n0 t') m0) = F m1 t') : @@ -720,13 +719,13 @@ Lemma rprod_rsum_commute d (B : finType) (x : 'rV_n) (W: `Ch('F_2, B)) m0 n0 (m0 W (t ``_ n1) (x ``_ n1) * \prod_(m1 in `F n1 :\ m0) (W ``(x \# `V(m1, n1) :\ n1 | ((dprojs_V H d n1 t) m1) \# `V(m1, n1) :\ n1) * - \prod_(m2 in `F(m1, n1)) INR (\delta ('V m2) ((dprojs_V H d n1 t) m1)))) = + \prod_(m2 in `F(m1, n1)) (\delta ('V m2) ((dprojs_V H d n1 t) m1))%:R)) = \sum_(t | (g t \in pfamily d ('V m0 :\ n0) pr) && (g' (g t) == t)) \prod_(n1 in 'V m0 :\ n0) (W ((g t n1) ``_ n1) (x ``_ n1) * \prod_(m1 in `F n1 :\ m0) (W ``(x \# `V(m1, n1) :\ n1 | ((dprojs_V H d n1 (g t n1)) m1) \# `V(m1, n1) :\ n1) * - \prod_(m2 in `F(m1, n1)) INR (\delta ('V m2) ((dprojs_V H d n1 (g t n1)) m1)))))%R. + \prod_(m2 in `F(m1, n1)) (\delta ('V m2) ((dprojs_V H d n1 (g t n1)) m1))%:R)))%R. Proof. move=> pr g g'. rewrite (big_distr_big_dep d) /=. diff --git a/information_theory/aep.v b/information_theory/aep.v index cfa6708a..f20caa12 100644 --- a/information_theory/aep.v +++ b/information_theory/aep.v @@ -2,9 +2,8 @@ (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. From mathcomp Require boolp. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext realType_ext ssr_ext bigop_ext ssralg_ext logb. +From mathcomp Require Import reals exp Rstruct. +Require Import realType_ext ssr_ext bigop_ext ssralg_ext realType_ln. Require Import fdist proba entropy. (******************************************************************************) @@ -26,62 +25,64 @@ Local Open Scope entropy_scope. Local Open Scope ring_scope. Local Open Scope vec_ext_scope. +Import Order.POrderTheory GRing.Theory Num.Theory. + Section mlog_prop. -Variables (A : finType) (P : {fdist A}). -Local Open Scope R_scope. +Context {R : realType}. +Variables (A : finType) (P : R.-fdist A). -Definition aep_sigma2 := `E ((`-- (`log P)) `^2) - (`H P)^2. +Definition aep_sigma2 : R := `E ((`-- (`log P)) `^2) - (`H P)^+2. -Lemma aep_sigma2E : aep_sigma2 = \sum_(a in A) P a * (log (P a))^2 - (`H P)^2. +Lemma aep_sigma2E : aep_sigma2 = \sum_(a in A) P a * (log (P a))^+2 - (`H P)^+2. Proof. rewrite /aep_sigma2 /Ex [in LHS]/log_RV /sq_RV /comp_RV. -by under eq_bigr do rewrite mulRC /ambient_dist -mulRR Rmult_opp_opp mulRR. +by under eq_bigr do rewrite mulrC /ambient_dist expr2 mulrNN -expr2. Qed. Lemma V_mlog : `V (`-- (`log P)) = aep_sigma2. Proof. rewrite aep_sigma2E /Var E_trans_RV_id_rem -entropy_Ex. transitivity - (\sum_(a in A) ((- log (P a))^2 * P a - 2 * `H P * - log (P a) * P a + - `H P ^ 2 * P a))%R. + (\sum_(a in A) ((- log (P a))^+2 * P a - 2 * `H P * - log (P a) * P a + + `H P ^+ 2 * P a))%R. apply eq_bigr => a _. rewrite /scalel_RV /log_RV /neg_RV /trans_add_RV /sq_RV /comp_RV /= /sub_RV. - by rewrite /ambient_dist; field. -rewrite big_split /= big_split /= -big_distrr /= (FDist.f1 P) mulR1. -rewrite (_ : \sum_(a in A) - _ = - (2 * `H P ^ 2))%R; last first. - rewrite -{1}big_morph_oppR; congr (- _)%R. + by rewrite /ambient_dist -!mulrBl -mulrDl. +rewrite big_split /= big_split /= -big_distrr /= (FDist.f1 P) mulr1. +rewrite (_ : \sum_(a in A) - _ = - (2 * `H P ^+ 2))%R; last first. + rewrite -{1}big_morph_oppr; congr (- _)%R. rewrite [X in X = _](_ : _ = \sum_(a in A) (2 * `H P) * (- (P a * log (P a))))%R; last first. - by apply eq_bigr => a _; rewrite -!mulRA (mulRC (P a)) mulNR. - rewrite -big_distrr [in LHS]/= -{1}big_morph_oppR. - by rewrite -/(entropy P) -mulRA /= mulR1. + by apply eq_bigr => a _; rewrite (mulrC (P a)) -[in RHS]mulNr mulrA. + rewrite -big_distrr [in LHS]/= -{1}big_morph_oppr. + by rewrite -/(entropy P) expr2 mulrA. set s := ((\sum_(a in A ) _)%R in LHS). -rewrite (_ : \sum_(a in A) _ = s)%R; last by apply eq_bigr => a _; field. -rewrite RpowE GRing.expr2 -!RmultE mulR1. -field. +rewrite (_ : \sum_(a in A) _ = s)%R; last first. + by apply eq_bigr => a _; rewrite sqrrN mulrC. +by rewrite (mulr_natl _ 2) mulr2n opprD addrA subrK. Qed. Lemma aep_sigma2_ge0 : 0 <= aep_sigma2. -Proof. rewrite -V_mlog /Var; apply Ex_ge0 => ?; exact: pow_even_ge0. Qed. - +Proof. by rewrite -V_mlog /Var; apply: Ex_ge0 => ?; exact: sq_RV_ge0. Qed. End mlog_prop. -Definition sum_mlog_prod (A : finType) (P : {fdist A}) n : {RV (P `^ n) -> R} := - (fun t => \sum_(i < n) - log (P t ``_ i))%R. +Definition sum_mlog_prod {R : realType} (A : finType) (P : R.-fdist A) n : + {RV ((P `^ n)%fdist)-> R} := + (fun t => \sum_(i < n) - log (P (t ``_ i)))%R. -Arguments sum_mlog_prod {A} _ _. +Arguments sum_mlog_prod {R} {A} _ _. -Lemma sum_mlog_prod_sum_map_mlog (A : finType) (P : {fdist A}) n : +Lemma sum_mlog_prod_sum_map_mlog {R : realType} (A : finType) (P : R.-fdist A) n : sum_mlog_prod P n.+1 \=sum (\row_(i < n.+1) `-- (`log P)). Proof. elim : n => [|n IH]. -- move: (@sum_n_1 A P (\row_i `-- (`log P))). +- move: (@sum_n_1 _ A P (\row_i `-- (`log P))). set mlogP := cast_fun_rV10 _. move => HmlogP. - set mlogprodP := @sum_mlog_prod _ _ 1. + set mlogprodP := @sum_mlog_prod _ _ _ 1. suff -> : mlogprodP = mlogP by []. rewrite /mlogprodP /mlogP /sum_mlog_prod /cast_fun_rV10 /= mxE /=. - by rewrite boolp.funeqE => ta; rewrite big_ord_recl big_ord0 addR0. + by rewrite boolp.funeqE => ta; rewrite big_ord_recl big_ord0 addr0. - rewrite [X in _ \=sum X](_ : _ = row_mx (\row_(i < 1) (`-- (`log P))) (\row_(i < n.+1) `-- (`log P))); last first. apply/rowP => b; rewrite !mxE; case: splitP. @@ -93,55 +94,55 @@ elim : n => [|n IH]. Qed. Section aep_k0_constant. -Local Open Scope R_scope. -Variables (A : finType) (P : {fdist A}). +Context {R : realType}. +Variables (A : finType) (P : R.-fdist A). -Definition aep_bound epsilon := (aep_sigma2 P / epsilon ^ 3)%R. +Definition aep_bound epsilon : R := (aep_sigma2 P / epsilon ^+ 3)%R. Lemma aep_bound_ge0 e (_ : 0 < e) : 0 <= aep_bound e. -Proof. apply divR_ge0; [exact: aep_sigma2_ge0 | exact/pow_lt]. Qed. +Proof. by apply divr_ge0; [exact: aep_sigma2_ge0 | apply/exprn_ge0/ltW]. Qed. Lemma aep_bound_decreasing e e' : 0 < e' <= e -> aep_bound e <= aep_bound e'. Proof. -case=> Oe' e'e. -apply leR_wpmul2l; first exact: aep_sigma2_ge0. -apply leR_inv => //; first exact/pow_lt. -apply pow_incr => //; split; [exact/ltRW | exact/e'e ]. +case/andP=> Oe' e'e. +apply ler_wpM2l; first exact: aep_sigma2_ge0. +rewrite lef_pV2 ?posrE; [|apply/exprn_gt0..] => //; last first. + by rewrite (lt_le_trans _ e'e). +by rewrite lerXn2r// ?nnegrE ltW// (lt_le_trans _ e'e). Qed. End aep_k0_constant. - Section AEP. -Local Open Scope R_scope. -Variables (A : finType) (P : {fdist A}) (n : nat) (epsilon : R). +Context {R : realType}. +Variables (A : finType) (P : R.-fdist A) (n : nat) (epsilon : R). Hypothesis Hepsilon : 0 < epsilon. Lemma aep : aep_bound P epsilon <= n.+1%:R -> - Pr (P `^ n.+1) [set t | (0 < P `^ n.+1 t)%mcR && - (`| (`-- (`log (P `^ n.+1)) `/ n.+1) t - `H P | >= epsilon)%mcR ] <= epsilon. + Pr (P `^ n.+1)%fdist [set t | (0 < (P `^ n.+1)%fdist t) && + (`| (`-- (`log (P `^ n.+1)%fdist) `/ n.+1) t - `H P | >= epsilon)%mcR ] <= epsilon. Proof. move=> Hbound. -apply (@leR_trans (aep_sigma2 P / (n.+1%:R * epsilon ^ 2))); last first. +apply (@le_trans _ _ (aep_sigma2 P / (n.+1%:R * epsilon ^+ 2))); last first. rewrite /aep_bound in Hbound. - apply (@leR_wpmul2r (epsilon / n.+1%:R)) in Hbound; last first. - apply divR_ge0; [exact/ltRW/Hepsilon | exact/ltR0n]. - rewrite [in X in _ <= X]mulRCA mulRV ?INR_eq0' // ?mulR1 in Hbound. - apply/(leR_trans _ Hbound)/Req_le; field. - by split; [by rewrite INR_eq0 | exact/eqP/gtR_eqF]. + apply (@ler_wpM2r _ (epsilon / n.+1%:R)) in Hbound; last first. + by rewrite divr_ge0// ltW. + rewrite [in X in _ <= X]mulrCA mulfV ?pnatr_eq0// ?mulr1 in Hbound. + apply/(le_trans _ Hbound). + rewrite [in leRHS]mulrA [in leRHS]exprSr [in leRHS]invfM. + rewrite -3![in leRHS]mulrA (mulrA epsilon^-1) mulVf ?gt_eqF// mul1r. + by rewrite (mulrC (n.+1%:R)) invfM. have Hsum := sum_mlog_prod_sum_map_mlog P n. have H1 k i : `E ((\row_(i < k.+1) `-- (`log P)) ``_ i) = `H P. by rewrite mxE entropy_Ex. have H2 k i : `V ((\row_(i < k.+1) `-- (`log P)) ``_ i) = aep_sigma2 P. by rewrite mxE V_mlog. have {H1 H2} := (wlln (H1 n) (H2 n) Hsum Hepsilon). -move/(leR_trans _); apply. +move/(le_trans _); apply. apply/subset_Pr/subsetP => ta; rewrite 2!inE => /andP[H1]. -rewrite /sum_mlog_prod [`-- (`log _)]lock /= -lock /= /scalel_RV /log_RV /neg_RV. -rewrite fdist_rVE. -rewrite log_prodR_sumR_mlog //. -move=> i; apply/RltP. -move: i; apply/prod_gt0_inv. +rewrite /sum_mlog_prod [`-- (`log _)]lock /= -lock /scalel_RV /log_RV /neg_RV/=. +rewrite fdist_rVE log_prodr_sumr_mlog //. +apply/prod_gt0_inv. by move=> x; exact: FDist.ge0. by move: H1; rewrite fdist_rVE. Qed. diff --git a/information_theory/binary_symmetric_channel.v b/information_theory/binary_symmetric_channel.v index 29637710..d0af73b9 100644 --- a/information_theory/binary_symmetric_channel.v +++ b/information_theory/binary_symmetric_channel.v @@ -2,10 +2,9 @@ (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum zmodp matrix lra. From mathcomp Require Import mathcomp_extra classical_sets Rstruct reals. -Require Import Reals Lra. -Require Import ssrR Reals_ext realType_ext logb ssr_ext ssralg_ext bigop_ext. -Require Import fdist entropy binary_entropy_function channel hamming channel_code. -Require Import pproba. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln. +Require Import fdist entropy binary_entropy_function channel hamming. +Require Import channel_code pproba. (******************************************************************************) (* Capacity of the binary symmetric channel *) @@ -22,13 +21,13 @@ Import Prenex Implicits. Local Open Scope fdist_scope. Local Open Scope channel_scope. -Local Open Scope R_scope. +Local Open Scope ring_scope. Module BSC. Section BSC_sect. Variable A : finType. -Hypothesis card_A : #|A| = 2%nat. -Variable p : {prob R}. +Hypothesis card_A : #|A| = 2%N. +Variable p : {prob Rdefinitions.R}. Definition c : `Ch(A, A) := fdist_binary card_A p. @@ -41,67 +40,57 @@ Import Order.TTheory GRing.Theory Num.Def Num.Theory. Section bsc_capacity_proof. Variable A : finType. -Hypothesis card_A : #|A| = 2%nat. -Variables (P : {fdist A}) (p : R). -Hypothesis p_01' : (0 < p < 1)%mcR. +Hypothesis card_A : #|A| = 2%N. +Variables (P : {fdist A}) (p : Rdefinitions.R). +Hypothesis p_01' : 0 < p < 1. -Let p_01'_ : (0 <= p <= 1)%mcR. +Let p_01'_ : 0 <= p <= 1. by move: p_01' => /andP[/ltW -> /ltW ->]. Qed. -Let p_01 : {prob R} := Eval hnf in Prob.mk_ p_01'_. +Let p_01 : {prob Rdefinitions.R} := Eval hnf in Prob.mk_ p_01'_. Lemma HP_HPW : `H P - `H(P, BSC.c card_A p_01) = - H2 p. Proof. rewrite {2}/entropy /=. rewrite (eq_bigr (fun a => ((P `X (BSC.c card_A p_01))) (a.1, a.2) * - log (((P `X (BSC.c card_A p_01))) (a.1, a.2)))); last by case. + log (((P `X (BSC.c card_A p_01))) (a.1, a.2)))); last first. + case=> //=. rewrite -(pair_big xpredT xpredT (fun a b => (P `X (BSC.c card_A p_01)) (a, b) * log ((P `X (BSC.c card_A p_01)) (a, b)))) /=. rewrite {1}/entropy . set a := \sum_(_ in _) _. set b := \sum_(_ <- _) _. -apply trans_eq with (- (a + (-1) * b)); first by field. +apply trans_eq with (- (a + (-1) * b)); first by rewrite mulN1r opprB opprK addrC. rewrite /b {b} big_distrr /= /a {a} -big_split /=. rewrite !Set2sumE /= !fdist_prodE /BSC.c !fdist_binaryxx !fdist_binaryE/=. rewrite eq_sym !(negbTE (Set2.a_neq_b card_A)) /H2 (* TODO *). set a := Set2.a _. set b := Set2.b _. -case: (Req_EM_T (P a) 0) => H1. - rewrite H1 !(mul0R, mulR0, addR0, add0R). +have [H1|H1] := eqVneq (P a) 0. + rewrite H1 !(mul0r, mulr0, addr0, add0r). move: (FDist.f1 P); rewrite Set2sumE /= -/a -/b. rewrite H1 add0r => ->. - rewrite /log Log_1 -!RmultE !(mul0R, mulR0, addR0, add0R, mul1R, mulR1). - rewrite /onem -RminusE (_ : 1%mcR = 1)//. - field. -rewrite /log LogM; last 2 first. - move/eqP in H1. - have [+ _] := fdist_gt0 P a. - by move/(_ H1) => /RltP. - by case/andP: p_01' => ? ?; exact/RltP/onem_gt0. -rewrite /log LogM; last 2 first. - move/eqP in H1. - have [+ _] := fdist_gt0 P a. - by move/(_ H1) => /RltP. - by case/andP: p_01' => ? ?; exact/RltP. -case: (Req_EM_T (P b) 0) => H2. - rewrite H2 !(mul0R, mulR0, addR0, add0R). + rewrite log1 !(mul0r, mulr0, addr0, add0r, mul1r, mulr1). + by rewrite /onem mulN1r opprK opprB opprK addrC. +rewrite logM; last 2 first. + by rewrite lt_neqAle eq_sym H1/=. + by case/andP: p_01' => ? ?; exact/onem_gt0. +rewrite logM; last 2 first. + by rewrite lt_neqAle eq_sym H1/=. + by case/andP: p_01'. +have [H2|H2] := eqVneq (P b) 0. + rewrite H2 !(mul0r, mulr0, addr0, add0r). move: (FDist.f1 P); rewrite Set2sumE /= -/a -/b. rewrite H2 addr0 => ->. - rewrite /log Log_1 -!RmultE !(mul0R, mulR0, addR0, add0R, mul1R, mulR1). - rewrite /onem -RminusE (_ : 1%mcR = 1)//. - field. -rewrite /log LogM; last 2 first. - move/eqP in H2. - have [+ _] := fdist_gt0 P b. - by move/(_ H2) => /RltP. - by case/andP: p_01' => ? ?; exact/RltP. -rewrite /log LogM; last 2 first. - move/eqP in H2. - have [+ _] := fdist_gt0 P b. - by move/(_ H2) => /RltP. - by case/andP: p_01' => ? ?; exact/RltP/onem_gt0. -rewrite /log. -rewrite -!RmultE. -rewrite /onem -RminusE (_ : 1%mcR = 1)//. + rewrite log1 !(mul0r, mulr0, addr0, add0r, mul1r, mulr1). + rewrite /onem/=. + by rewrite mulN1r opprK opprB opprK addrC. +rewrite logM; last 2 first. + by rewrite lt_neqAle eq_sym H2/=. + by case/andP: p_01' => ? ?. +rewrite logM; last 2 first. + by rewrite lt_neqAle eq_sym H2/=. + by case/andP: p_01' => ? ?; exact/onem_gt0. +rewrite /onem. transitivity (p * (P a + P b) * log p + (1 - p) * (P a + P b) * log (1 - p) ). rewrite /log. set l2Pa := Log 2 (P a). @@ -110,77 +99,24 @@ transitivity (p * (P a + P b) * log p + (1 - p) * (P a + P b) * log (1 - p) ). set l2p := Log 2 p. set Pa := P a. set Pb := P b. - ring. + lra. move: (FDist.f1 P). rewrite Set2sumE /= -/a -/b. rewrite -RplusE => ->. -rewrite !mulR1. -rewrite /log; field. +rewrite !mulr1. +by rewrite opprB opprK addrC. Qed. Lemma IPW : `I(P, BSC.c card_A p_01) = `H(P `o BSC.c card_A p_01) - H2 p. -Proof. -rewrite /mutual_info_chan addRC. -set a := `H(_ `o _). -transitivity (a + (`H P - `H(P , BSC.c card_A p_01))); first by field. -by rewrite HP_HPW. -Qed. +Proof. by rewrite /mutual_info_chan addrAC HP_HPW addrC. Qed. Lemma H_out_max : `H(P `o BSC.c card_A p_01) <= 1. Proof. -rewrite {1}/entropy /= Set2sumE /= !fdist_outE 2!Set2sumE /=. -set a := Set2.a _. set b := Set2.b _. -rewrite /BSC.c !fdist_binaryxx !fdist_binaryE /= !(eq_sym _ a). -rewrite (negbTE (Set2.a_neq_b card_A)). -move: (FDist.f1 P); rewrite Set2sumE /= -/a -/b => P1. -rewrite -!(RmultE,RplusE). -have -> : p * P a + (1 - p) * P b = 1 - ((1 - p) * P a + p * P b). - rewrite -RplusE (_ : 1%mcR = 1)// in P1. - rewrite -{2}P1. - ring_simplify. - congr (_ + _). - by rewrite subRK. -case/andP: p_01' => /RltP Hp1 /RltP Hp2. -rewrite (_ : 0%mcR = 0%coqR)// in Hp1. -rewrite (_ : 1%mcR = 1%coqR)// in Hp2, P1. -have H01 : 0 < ((1 - p) * P a + p * P b) < 1. - move: (FDist.ge0 P a) => /RleP H1. - move: (FDist.le1 P b) => H4. - move: (FDist.le1 P a) => H3. - split. - case/Rle_lt_or_eq_dec : H1 => H1; rewrite (_ : 0%mcR = 0)// in H1. - - apply addR_gt0wl. - apply: mulR_gt0 => //. - by rewrite subR_gt0. - apply: mulR_ge0 => //. - exact: ltRW. - - by rewrite -H1 mulR0 add0R (_ : P b = 1) ?mulR1 // -P1 -H1 add0r. - rewrite -{2}P1. - case: (Req_EM_T (P a) 0) => Hi. - rewrite Hi mulR0 !add0R. - rewrite Hi add0r in P1. - by rewrite P1 mulR1 add0r. - case: (Req_EM_T (P b) 0) => Hj. - rewrite Hj addr0 in P1. - rewrite Hj mulR0 !addR0 P1 mulR1. - rewrite addr0. - by rewrite ltR_subl_addr ltR_addl. - case/Rle_lt_or_eq_dec : H1 => H1. - - apply leR_lt_add. - + rewrite -{2}(mul1R (P a)); apply leR_wpmul2r => //. - by rewrite leR_subl_addr leR_addl; exact: ltRW. - + rewrite -{2}(mul1R (P b)); apply ltR_pmul2r => //. - by apply/RltP; rewrite lt0r; apply/andP; split; [exact/eqP|by []]. - - rewrite -H1 mulR0 add0R add0r. - have -> : P b = 1 by rewrite -P1 -H1 add0r. - by rewrite mulR1. -rewrite (_ : forall a b, - (a + b) = - a - b); last by move=> *; field. -rewrite -mulNR. -set q := (1 - p) * P a + p * P b. -apply: (@leR_trans (H2 q)); last exact: H2_max. -by rewrite /H2 !mulNR; apply Req_le; field. +have-> : 1 = log#|A|%:R :> Rdefinitions.R by rewrite card_A log2. +exact:entropy_max. Qed. +(* Lemma bsc_out_H_half' : 0 < 1%:R / 2%:R < 1. Proof. rewrite /= (_ : 1%:R = 1) // (_ : 2%:R = 2) //. @@ -189,36 +125,50 @@ apply: divR_gt0 => //. apply/ltR_pdivr_mulr => //. by rewrite mul1R. Qed. +*) Lemma H_out_binary_uniform : `H(fdist_uniform card_A `o BSC.c card_A p_01) = 1. Proof. -rewrite {1}/entropy !Set2sumE /= !fdist_outE !Set2sumE /=. -rewrite /BSC.c !fdist_binaryxx !fdist_binaryE (eq_sym _ (Set2.a _)) !fdist_uniformE. -rewrite (negbTE (Set2.a_neq_b card_A)). -rewrite -!mulrDl. -rewrite /onem subrK. -rewrite !mul1r. -rewrite addrC subrK. -have ? : 2%mcR != 0%mcR :> R. - rewrite (_ : 2%mcR = 2)//. - rewrite (_ : 0%mcR = 0)//. - by apply/eqP. -rewrite -RdivE// ?card_A//. -rewrite div1R -RinvE//. -rewrite -!mulRDl /log LogV//. -rewrite Log_n //=. -rewrite (_ : 2%mcR = 2)//. -field. +rewrite /entropy Set2sumE 2!fdist_outE 2!Set2sumE /=. +rewrite /BSC.c !fdist_binaryE. +rewrite 2!eqxx (eq_sym (Set2.b card_A)) (negbTE (Set2.a_neq_b card_A)). +rewrite 2!fdist_uniformE -!(mulrDl _ _ _^-1) (addrC _.~) onemKC div1r. +rewrite card_A logV // log2. +by rewrite mulrC -splitr opprK. Qed. End bsc_capacity_proof. +(* +Section convex_ext. +Require Import entropy_convex. +Local Open Scope convex_scope. + +Variables (A B : finType). +Hypothesis card_A : #|A| = 2%nat. + +Lemma mutual_info_chan_uniform (W : A -> {fdist B}) : + `I(P, W) <= `I(fdist_uniform card_A, W). +Proof. +rewrite !mutual_info_chanE -!mutual_info_sym. +have [Q [q ->]] : exists (Q : {fdist A}) (q : {prob R}), + P = (fdist_uniform card_A) <|q|> Q. + admit. +have B0: (0 < #|B|)%nat. + admit. +set P' := (_ <|q|> _). +have:= mutual_information_concave W B0 P' W => /=. +rewrite /convex.concave_function /=. +End convex_ext. +*) + Section bsc_capacity_theorem. +Let R := Rdefinitions.R. Variable A : finType. -Hypothesis card_A : #|A| = 2%nat. +Hypothesis card_A : #|A| = 2%N. Variable p : R. -Hypothesis p_01' : (0 < p < 1)%mcR. -Let p_01'_ : (0 <= p <= 1)%mcR. +Hypothesis p_01' : 0 < p < 1. +Let p_01'_ : 0 <= p <= 1. by move: p_01' => /andP[/ltW -> /ltW ->]. Qed. Let p_01 : {prob R} := Eval hnf in Prob.mk_ p_01'_. @@ -238,30 +188,29 @@ have has_sup_E : has_sup E. rewrite (_ : tmp = p_01)//; last first. by apply/val_inj => //. move=> ->. - apply/RleP/leR_subl_addr/(leR_trans (H_out_max card_A P p_01')). - rewrite addRC -leR_subl_addr subRR. - by rewrite (entropy_H2 card_A (Prob.mk_ (p_01'_))); exact/entropy_ge0. -apply eqR_le; split. - apply/RleP. + rewrite lerBlDr (le_trans (H_out_max card_A P p_01'))//. + rewrite -lerBlDl subrr (_ : p = Prob.p p')// (entropy_H2 card_A). + exact/entropy_ge0. +apply/eqP; rewrite eq_le; apply/andP; split. have [_ /(_ (1 - H2 p))] := Rsup_isLub (0 : R) has_sup_E. - apply => x [d _ dx]; apply/RleP. + apply => x [d _ dx]. suff : `H(d `o BSC.c card_A p_01) <= 1. - have := IPW card_A d p_01'. - set tmp := (X in `I(_, BSC.c _ X)). - rewrite (_ : tmp = p_01)//; last first. - by apply/val_inj => //. - set tmp' := (X in _ = `H(d `o (BSC.c card_A X)) - _ -> _). - rewrite (_ : tmp' = p_01)//; last first. - by apply/val_inj => //. - rewrite dx => -> ?. - by rewrite leR_subl_addr subRK. + have := IPW card_A d p_01'. + set tmp := (X in `I(_, BSC.c _ X)). + rewrite (_ : tmp = p_01)//; last first. + by apply/val_inj => //. + set tmp' := (X in _ = `H(d `o (BSC.c card_A X)) - _ -> _). + rewrite (_ : tmp' = p_01)//; last first. + by apply/val_inj => //. + rewrite dx => -> ?. + by rewrite lerBlDr subrK. have := H_out_max card_A d p_01'. set tmp' := (X in `H(d `o (BSC.c card_A X)) <= _ -> _). rewrite (_ : tmp' = p_01)//. by apply/val_inj. move: (@IPW _ card_A (fdist_uniform card_A) _ p_01'). rewrite H_out_binary_uniform => <-. -apply/RleP/Rsup_ub => //=. +apply/Rsup_ub => //=. exists (fdist_uniform card_A) => //. do 2 f_equal. exact: val_inj. @@ -271,25 +220,26 @@ End bsc_capacity_theorem. Section dH_BSC. +Let R := Rdefinitions.R. Variable p : {prob R}. -Let card_F2 : #| 'F_2 | = 2%nat. by rewrite card_Fp. Qed. +Let card_F2 : #| 'F_2 | = 2%N. by rewrite card_Fp. Qed. Let W := BSC.c card_F2 p. Variables (M : finType) (n : nat) (f : encT 'F_2 M n). Local Open Scope vec_ext_scope. Lemma DMC_BSC_prop m y : let d := dH y (f m) in - W ``(y | f m) = ((1 - Prob.p p) ^ (n - d) * Prob.p p ^ d)%R. + W ``(y | f m) = (1 - Prob.p p) ^+ (n - d) * Prob.p p ^+ d. Proof. move=> d; rewrite DMCE. transitivity ((\prod_(i < n | (f m) ``_ i == y ``_ i) (1 - Prob.p p)) * - (\prod_(i < n | (f m) ``_ i != y ``_ i) Prob.p p))%R. + (\prod_(i < n | (f m) ``_ i != y ``_ i) Prob.p p)). rewrite (bigID [pred i | (f m) ``_ i == y ``_ i]) /=; congr (_ * _). by apply eq_bigr => // i /eqP ->; rewrite /BSC.c fdist_binaryxx. apply eq_bigr => //= i /negbTE Hyi; by rewrite /BSC.c fdist_binaryE eq_sym Hyi. congr (_ * _). - by rewrite big_const /= iter_mulR /= card_dHC. -by rewrite big_const /= iter_mulR /= card_dH_vec. + by rewrite big_const /= iter_mulr /= card_dHC mulr1. +by rewrite big_const /= iter_mulr /= card_dH_vec mulr1. Qed. End dH_BSC. @@ -300,18 +250,20 @@ Local Open Scope reals_ext_scope. Local Open Scope ring_scope. Local Open Scope order_scope. +Let R := Rdefinitions.R. + (* This lemma is more or less stating that (log q <|n2 / n|> log r) <= (log q <|n1 / n|> log r) *) Lemma expr_conv_mono n n1 n2 q r : - 0 < q :> R -> q <= r -> (n1 <= n2 <= n)%nat -> + 0 < q :> R -> q <= r -> (n1 <= n2 <= n)%N -> r ^+ (n - n2) * q ^+ n2 <= r ^+ (n - n1) * q ^+ n1. Proof. move=> /[dup] /ltW q0 q1 qr /andP [] n12 n2n. have r1 := lt_le_trans q1 qr. have r0 := ltW r1. -rewrite [leLHS](_ : _ = q ^+ n1 * q ^+ (n2 - n1)%nat * r ^+ (n - n2)%nat); +rewrite [leLHS](_ : _ = q ^+ n1 * q ^+ (n2 - n1)%N * r ^+ (n - n2)%N); last by rewrite -exprD subnKC // mulrC. -rewrite [leRHS](_ : _ = q ^+ n1 * r ^+ (n2 - n1)%nat * r ^+ (n - n2)%nat); +rewrite [leRHS](_ : _ = q ^+ n1 * r ^+ (n2 - n1)%N * r ^+ (n - n2)%N); last by rewrite -mulrA -exprD addnBAC // subnKC // mulrC. apply: ler_pM => //; [by apply/mulr_ge0; apply/exprn_ge0 | by apply/exprn_ge0 | ]. apply: ler_pM => //; [by apply/exprn_ge0 | by apply/exprn_ge0 |]. @@ -321,20 +273,20 @@ by rewrite ler_pdivlMr // mul1r. Qed. Lemma bsc_prob_prop (p : {prob R}) n : Prob.p p < 1 / 2 -> - forall n1 n2 : nat, (n1 <= n2 <= n)%nat -> - ((1 - Prob.p p) ^ (n - n2) * (Prob.p p) ^ n2 <= (1 - Prob.p p) ^ (n - n1) * (Prob.p p) ^ n1)%R. + forall n1 n2 : nat, (n1 <= n2 <= n)%N -> + (1 - Prob.p p) ^+ (n - n2) * (Prob.p p) ^+ n2 <= + (1 - Prob.p p) ^+ (n - n1) * (Prob.p p) ^+ n1. Proof. move=> p05 d1 d2 d1d2. -case/boolP: (p == 0%:pr). - move/eqP->; rewrite !coqRE; apply/RleP. +have [->|] := eqVneq p 0%:pr. rewrite probpK subr0 !expr1n !mul1r !expr0n. move: d1d2; case: d2; first by rewrite leqn0 => /andP [] ->. - by case: (d1 == 0%nat). + by case: (d1 == 0%N). move/prob_gt0 => p1. -rewrite !coqRE. -apply/RleP/expr_conv_mono => //. +apply/expr_conv_mono => //. lra. Qed. + End bsc_prob_prop. (* moved from ldpc.v *) @@ -345,8 +297,10 @@ Local Open Scope order_scope. Local Open Scope proba_scope. Local Open Scope vec_ext_scope. +Let R := Rdefinitions.R. + Variable A : finType. -Hypothesis card_A : #|A| = 2%nat. +Hypothesis card_A : #|A| = 2%N. Variable p : R. Hypothesis p_01' : 0 < p < 1. @@ -365,19 +319,19 @@ Hypothesis Ha' : receivable_prop (P `^ 1) (BSC.c card_A p_01) (\row_(i < 1) a'). Lemma bsc_post (a : A) : (P `^ 1) `^^ (BSC.c card_A p_01) (\row_(i < 1) a | mkReceivable Ha') = - (if a == a' then 1 - p else p)%R. + if a == a' then 1 - p else p. Proof. rewrite fdist_post_probE /= !fdist_rVE DMCE big_ord_recl big_ord0. -rewrite (eq_bigr (fun x : 'M_1 => P a * (BSC.c card_A p_01) ``( (\row__ a') | x))%R); last first. +rewrite (eq_bigr (fun x : 'M_1 => P a * (BSC.c card_A p_01) ``( (\row__ a') | x))); last first. by move=> i _; rewrite /P !fdist_rVE big_ord_recl big_ord0 !fdist_uniformE mulr1. -rewrite -big_distrr /= (_ : \sum_(_ | _) _ = 1)%R; last first. - transitivity (\sum_(i in 'M_1) fdist_binary card_A p_01 (i ``_ ord0) a')%R. +rewrite -big_distrr /= (_ : \sum_(_ | _) _ = 1); last first. + transitivity (\sum_(i in 'M_1) fdist_binary card_A p_01 (i ``_ ord0) a'). apply eq_bigr => i _. - by rewrite DMCE big_ord_recl big_ord0 mulR1 /BSC.c mxE. + by rewrite DMCE big_ord_recl big_ord0 mulr1 /BSC.c mxE. apply/(@big_rV1_ord0 _ _ _ _ (fdist_binary card_A p_01 ^~ a')). by rewrite -sum_fdist_binary_swap // FDist.f1. rewrite mxE mulr1 big_ord_recl big_ord0 /BSC.c fdist_binaryE /= eq_sym !mxE. -rewrite !coqRE mulr1 onemE. +rewrite mulr1 onemE. rewrite mulrAC mulfV ?mul1r // fdist_uniformE card_A invr_neq0 //. by apply: lt0r_neq0; lra. Qed. diff --git a/information_theory/channel.v b/information_theory/channel.v index 30557a04..889f93ae 100644 --- a/information_theory/channel.v +++ b/information_theory/channel.v @@ -1,9 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect all_algebra. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext fdist. +From mathcomp Require Import Rstruct reals. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln fdist. Require Import proba entropy jfdist_cond. (******************************************************************************) @@ -34,7 +33,7 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Import Num.Theory. +Import GRing.Theory Num.Theory. Declare Scope channel_scope. Delimit Scope fdist_scope with channel. @@ -55,8 +54,8 @@ Reserved Notation "`H( P , W )" (at level 10, P, W at next level, Reserved Notation "`H( W | P )" (at level 10, W, P at next level). Reserved Notation "`I( P , W )" (at level 50, format "`I( P , W )"). -Local Open Scope R_scope. Local Open Scope fdist_scope. +Local Open Scope ring_scope. Module Channel1. Section channel1. @@ -100,7 +99,7 @@ Variables (A B : finType) (W : `Ch(A, B)) (n : nat). Definition f (x : 'rV[A]_n) := [ffun y : 'rV[B]_n => (\prod_(i < n) W `(y ``_ i | x ``_ i))]. -Lemma f0 x y : (0 <= f x y). Proof. rewrite ffunE; apply/RleP; exact: prodR_ge0. Qed. +Lemma f0 x y : (0 <= f x y). Proof. rewrite ffunE; exact: prodr_ge0. Qed. Lemma f1 x : (\sum_(y in 'rV_n) f x y = 1)%R. Proof. @@ -175,7 +174,7 @@ Let f1 : \sum_(b in B) f b = 1. Proof. under eq_bigr do rewrite ffunE /=. rewrite exchange_big /= -[RHS](FDist.f1 P). -by apply eq_bigr => a _; rewrite -big_distrl /= (FDist.f1 (W a)) -RmultE mul1R. +by apply eq_bigr => a _; rewrite -big_distrl /= (FDist.f1 (W a)) mul1r. Qed. Definition fdist_out : {fdist B} := locked (FDist.make f0 f1). @@ -192,10 +191,9 @@ Notation "'`H(' P '`o' W )" := (`H ( `O( P , W ) )) : channel_scope. Section fdist_out_prop. Variables A B : finType. -Local Open Scope ring_scope. Lemma fdist_rV_out (W : `Ch(A, B)) (P : {fdist A}) n (b : 'rV_n): - `O(P, W) `^ _ b = - \sum_(j : 'rV[A]_n) (\prod_(i < n) W j ``_ i b ``_ i) * P `^ _ j. + (`O(P, W) `^ _) b = + \sum_(j : 'rV[A]_n) ((\prod_(i < n) W j ``_ i b ``_ i) * (P `^ _) j). Proof. rewrite fdist_rVE. under eq_bigr do rewrite fdist_outE. @@ -215,7 +213,7 @@ Local Close Scope ring_scope. Lemma fdistX_prod_out (W : `Ch(A, B)) (P : {fdist A}) : (fdistX (P `X W))`1 = `O(P, W). Proof. rewrite fdistX1; apply/fdist_ext => b; rewrite fdist_outE fdist_sndE. -by under eq_bigr do rewrite fdist_prodE -RmultE mulRC. +by under eq_bigr do rewrite fdist_prodE mulrC. Qed. End fdist_out_prop. @@ -236,19 +234,19 @@ Qed. Lemma Pr_DMC_fst (Q : 'rV_n -> bool) : Pr ((P `X W) `^ n) [set x | Q (rV_prod x).1 ] = - Pr P `^ n [set x | Q x]. + Pr (P `^ n) [set x | Q x]. Proof. rewrite {1}/Pr big_rV_prod /= -(pair_big_fst _ _ [pred x | Q x]) //=; last first. move=> t /=. set X := (X in X _ = _); transitivity (prod_rV t \in X) => //; rewrite inE/=. congr (Q _). by apply/rowP => a; rewrite !mxE. -transitivity (\sum_(i | Q i) P `^ n i * (\sum_(y in 'rV[B]_n) W ``(y | i))). +transitivity (\sum_(i | Q i) (P `^ n) i * (\sum_(y in 'rV[B]_n) W ``(y | i))). apply: eq_bigr => ta Sta; rewrite big_distrr; apply: eq_bigr => tb _ /=. rewrite DMCE [in RHS]fdist_rVE -[in RHS]big_split /= fdist_rVE. by apply eq_bigr => j _; rewrite fdist_prodE /= -fst_tnth_prod_rV -snd_tnth_prod_rV. -transitivity (\sum_(i | Q i) P `^ _ i). - by apply eq_bigr => i _; rewrite (FDist.f1 (W ``(| i))) mulR1. +transitivity (\sum_(i | Q i) (P `^ _) i). + by apply eq_bigr => i _; rewrite (FDist.f1 (W ``(| i))) mulr1. by rewrite /Pr; apply eq_bigl => t; rewrite !inE. Qed. @@ -274,7 +272,7 @@ apply: eq_big => ta. by rewrite inE; apply/esym/eqP/rowP => a; rewrite mxE ffunE. move=> Hta. rewrite fdist_rVE /=; apply eq_bigr => l _. -by rewrite fdist_prodE -fst_tnth_prod_rV -snd_tnth_prod_rV ffunE -RmultE mulRC. +by rewrite fdist_prodE -fst_tnth_prod_rV -snd_tnth_prod_rV ffunE mulrC. Qed. Local Close Scope ring_scope. @@ -302,15 +300,15 @@ Lemma cond_entropy_chanE : `H(W | P) = cond_entropy (fdistX (P `X W)). Proof. rewrite /cond_entropy_chan. have := chain_rule (P `X W); rewrite /joint_entropy => ->. -by rewrite fdist_prod1 addRC addRK. +by rewrite fdist_prod1 addrAC subrr add0r. Qed. Lemma cond_entropy_chanE2 : `H(W | P) = \sum_(a in A) P a * `H (W a). Proof. -rewrite cond_entropy_chanE cond_entropyE big_morph_oppR; apply: eq_bigr => a _. -rewrite big_morph_oppR /entropy mulRN -mulNR big_distrr/=; apply: eq_bigr => b _. -rewrite fdistXI fdist_prodE /= mulNR mulRA; congr (- _). -have [->|Pa0] := eqVneq (P a) 0; first by rewrite -RmultE !(mulR0,mul0R). +rewrite cond_entropy_chanE cond_entropyE big_morph_oppr; apply: eq_bigr => a _. +rewrite big_morph_oppr /entropy mulrN -mulNr big_distrr/=; apply: eq_bigr => b _. +rewrite fdistXI fdist_prodE /= mulNr (mulrA (P a)); congr (- _). +have [->|Pa0] := eqVneq (P a) 0; first by rewrite !(mulr0,mul0r). by rewrite -channel_jcPr. Qed. @@ -334,7 +332,7 @@ Variables (A B : finType) (W : `Ch(A, B)) (P : {fdist A}). Lemma mutual_info_chanE : `I(P, W) = mutual_info (fdistX (P `X W)). Proof. rewrite /mutual_info_chan mutual_infoE -cond_entropy_chanE. -by rewrite -[in RHS]addR_opp oppRB addRCA addRA fdistX_prod_out. +by rewrite opprB addrCA addrA fdistX_prod_out. Qed. End mutual_info_chan_prop. diff --git a/information_theory/channel_code.v b/information_theory/channel_code.v index fc2ed823..b88f3813 100644 --- a/information_theory/channel_code.v +++ b/information_theory/channel_code.v @@ -1,9 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import Reals_ext ssrR logb fdist proba channel. +From mathcomp Require Import Rstruct reals exp. +Require Import bigop_ext realType_ext realType_ln fdist proba channel. (******************************************************************************) (* Definition of a channel code *) @@ -33,9 +32,9 @@ Import Prenex Implicits. Local Open Scope proba_scope. Local Open Scope channel_scope. -Local Open Scope R_scope. +Local Open Scope ring_scope. -Import Num.Theory. +Import GRing.Theory Num.Theory. Section code_definition. Variables (A B M : finType) (n : nat). @@ -47,7 +46,7 @@ Definition decT := {ffun 'rV[B]_n -> option M}. Record code := mkCode { enc : encT ; dec : decT }. -Definition CodeRate (c : code) := (log (#| M |%:R) / n%:R)%R. +Definition CodeRate (c : code) : Rdefinitions.R := log (#| M |%:R) / n%:R. Definition preimC (phi : decT) m := ~: (phi @^-1: xpred1 (Some m)). @@ -57,23 +56,22 @@ Definition ErrRateCond (W : `Ch(A, B)) c m := Local Notation "e( W , c )" := (ErrRateCond W c) (at level 50). Definition CodeErrRate (W : `Ch(A, B)) c := - (1 / #| M |%:R * \sum_(m in M) e(W, c) m)%R. + (#| M |%:R^-1 * \sum_(m in M) e(W, c) m)%R. Local Notation "echa( W , c )" := (CodeErrRate W c) (at level 50). Lemma echa_ge0 (HM : (0 < #| M |)%nat) W (c : code) : 0 <= echa(W , c). Proof. -apply/RleP/mulR_ge0. -- apply divR_ge0; [exact/Rle_0_1| exact/ltR0n]. -- by apply/RleP/sumr_ge0 => ? _; exact: sumr_ge0. +apply/mulr_ge0. +- by rewrite invr_ge0. +- by apply/sumr_ge0 => ? _; exact: sumr_ge0. Qed. Lemma echa_le1 (HM : (0 < #| M |)%nat) W (c : code) : echa(W , c) <= 1. Proof. -rewrite /CodeErrRate div1R. -apply/RleP/ (@leR_pmul2l (INR #|M|)); first exact/ltR0n. -rewrite mulRA mulRV ?INR_eq0' -?lt0n // mul1R -iter_addR -big_const. -by apply: leR_sumR => m _; exact: Pr_le1. +rewrite /CodeErrRate ler_pdivrMl ?ltr0n// mulr1. +rewrite -sum1_card natr_sum. +by apply: ler_sum => m _; exact: Pr_le1. Qed. Definition scha (W : `Ch(A, B)) (c : code) := (1 - echa(W , c))%R. @@ -92,11 +90,13 @@ Proof. set rhs := (\sum_(m | _ ) _)%R. have {rhs}-> : rhs = (\sum_(m in M) (1 - e(W, c) m))%R. apply eq_bigr => i Hi; rewrite -Pr_to_cplt. - apply eq_bigl => t /=; by rewrite inE. + by apply eq_bigl => t /=; rewrite inE. set rhs := (\sum_(m | _ ) _)%R. have {rhs}-> : rhs = (#|M|%:R - \sum_(m in M) e(W, c) m)%R. - by rewrite /rhs {rhs} big_split /= big_const iter_addR mulR1 -big_morph_oppR. -by rewrite mulRDr -mulRA mulVR ?mulR1 ?INR_eq0' -?lt0n // mulRN. + rewrite /rhs {rhs} big_split /= big_morph_oppr; congr +%R. + by rewrite -sum1_card natr_sum. +rewrite mulrDr -mulrA mulVf ?mulr1 ?pnatr_eq0 ?gtn_eqF// mul1r. +by rewrite mulrN//. Qed. End code_definition. @@ -106,5 +106,5 @@ Notation "echa( W , c )" := (CodeErrRate W c) : channel_code_scope. Notation "scha( W , C )" := (scha W C) : channel_code_scope. Record CodeRateType := mkCodeRateType { - rate :> R ; - _ : exists n d, (0 < n)%nat /\ (0 < d)%nat /\ rate = log (INR n) / INR d }. + rate :> Rdefinitions.R ; + _ : exists n d, (0 < n)%nat /\ (0 < d)%nat /\ rate = log n%:R / d%:R }. diff --git a/information_theory/channel_coding_converse.v b/information_theory/channel_coding_converse.v index a3bbfc2d..0e5bcbc1 100644 --- a/information_theory/channel_coding_converse.v +++ b/information_theory/channel_coding_converse.v @@ -1,9 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg matrix. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext ssr_ext ssralg_ext logb ln_facts num_occ. +From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. +From mathcomp Require Import Rstruct reals exp. +Require Import ssr_ext ssralg_ext realType_ln num_occ. Require Import fdist entropy types jtypes divergence conditional_divergence. Require Import error_exponent channel_code channel success_decode_bound. @@ -29,14 +28,17 @@ Local Open Scope reals_ext_scope. Local Open Scope proba_scope. Local Open Scope types_scope. Local Open Scope divergence_scope. -Local Open Scope R_scope. +Local Open Scope ring_scope. + +Import Order.POrderTheory Num.Theory GRing.Theory. Section channel_coding_converse_intermediate_lemma. +Let R := Rdefinitions.R. Variables (A B : finType) (W : `Ch*(A, B)). Variable minRate : R. Hypothesis HminRate : minRate > capacity W. Hypothesis set_of_I_has_ubound : - classical_sets.has_ubound (fun y => exists P, `I(P, W) = y). + classical_sets.has_ubound (fun y => exists P, `I(P, W) = y)(*TODO*). Let Anot0 : (0 < #|A|)%nat. Proof. by case: W. Qed. @@ -46,36 +48,46 @@ Proof. case/card_gt0P : Anot0 => a _; exact: (fdist_card_neq0 (W a)). Qed. Lemma channel_coding_converse_gen : exists Delta, 0 < Delta /\ forall n', let n := n'.+1 in forall (M : finType) (c : code A B M n), (0 < #|M|)%nat -> minRate <= CodeRate c -> - scha(W, c) <= n.+1%:R ^ (#|A| + #|A| * #|B|) * exp2 (- n%:R * Delta). + scha(W, c) <= n.+1%:R ^+ (#|A| + #|A| * #|B|) * 2 `^ (- n%:R * Delta). Proof. move: error_exponent_bound => /(_ _ _ Bnot0 W _ HminRate set_of_I_has_ubound). case => Delta [Delta_pos HDelta]. exists Delta; split => // n' n M c Mnot0 H. -apply: (leR_trans (success_bound W Mnot0 c)). +apply: (le_trans (success_bound W Mnot0 c)). set Pmax := [arg max_(P > _) _]%O. set tc := _.-typed_code _. -rewrite pow_add -mulRA. -apply leR_wpmul2l; first exact/pow_le/leR0n. -apply: (leR_trans (typed_success_bound W Mnot0 (Pmax.-typed_code c))). -apply leR_wpmul2l; first exact/pow_le/leR0n. +rewrite exprD -mulrA. +apply ler_wpM2l. + by rewrite exprn_ge0//. +apply: (le_trans (typed_success_bound W Mnot0 (Pmax.-typed_code c))). +apply ler_wpM2l. + by rewrite exprn_ge0//. set Vmax := [arg max_(V > _) _]%O. rewrite /success_factor_bound /exp_cdiv. -case : ifP => Hcase; last by rewrite mul0R. -rewrite -ExpD. -apply Exp_le_increasing => //. -rewrite -mulRDr 2!mulNR. -rewrite leR_oppr oppRK; apply/leR_wpmul2l; first exact/leR0n. +case : ifP => Hcase; last by rewrite mul0r powR_ge0. +rewrite -powRD; last by rewrite pnatr_eq0 implybT. +rewrite ler_powR ?ler1n//. +rewrite -mulrDr 2!mulNr. +rewrite lerNr opprK; apply/ler_wpM2l; first exact/ler0n. have {}Hcase : Pmax |- Vmax << W. move=> a Hp; apply/dominatesP => b /eqP Hw. move/forallP : Hcase. by move/(_ a)/implyP/(_ Hp)/forallP/(_ b)/implyP/(_ Hw)/eqP. -apply (leR_trans (HDelta Pmax Vmax Hcase)) => /=. -exact/leR_add2l/Rle_max_compat_l/leR_add2r. +apply (le_trans (HDelta Pmax Vmax Hcase)) => /=. +rewrite lerD2l//. +(* TODO: lemma *) +rewrite Order.TotalTheory.ge_max. +apply/andP; split. + by rewrite Order.TotalTheory.le_max lexx. +rewrite Order.TotalTheory.le_max. +apply/orP; right. +by rewrite lerB//. Qed. End channel_coding_converse_intermediate_lemma. Section channel_coding_converse. +Let R := Rdefinitions.R. Variables (A B : finType) (W : `Ch*(A, B)). Variable minRate : R. Hypothesis minRate_cap : minRate > capacity W. @@ -87,72 +99,66 @@ Hypothesis eps_gt0 : 0 < epsilon. Theorem channel_coding_converse : exists n0, forall n M (c : code A B M n), - (0 < #|M|)%nat -> n0 < n%:R -> minRate <= CodeRate c -> scha(W, c) < epsilon. + (0 < #|M|)%nat -> n0 < n%:R :> R -> minRate <= CodeRate c -> scha(W, c) < epsilon. Proof. case: (channel_coding_converse_gen minRate_cap set_of_I_has_ubound) => Delta [Delta_pos HDelta]. pose K := (#|A| + #|A| * #|B|)%nat. -pose n0 := 2 ^ K * K.+1`!%:R / ((Delta * ln 2) ^ K.+1) / epsilon. +pose n0 := 2 ^+ K * K.+1`!%:R / ((Delta * ln 2) ^+ K.+1) / epsilon. exists n0 => n M c HM n0_n HminRate. -have Rlt0n : 0 < n%:R. - apply: (ltR_trans _ n0_n). +have Rlt0n : 0 < n%:R :> R. + apply: (lt_trans _ n0_n). rewrite /n0. - apply mulR_gt0; last exact/invR_gt0. - rewrite /Rdiv -mulRA. - apply mulR_gt0; first exact/expR_gt0/Rlt_0_2. - apply mulR_gt0; - [exact/ltR0n/fact_gt0 | exact/invR_gt0/expR_gt0/mulR_gt0]. + rewrite mulr_gt0// ?invr_gt0//. + rewrite -mulrA mulr_gt0 ?exprn_gt0//. + rewrite divr_gt0// ?ltr0n ?fact_gt0//. + rewrite exprn_gt0//. + by rewrite mulr_gt0// ln_gt0// ltr1n. destruct n as [|n']. - by apply ltRR in Rlt0n. + by rewrite ltxx in Rlt0n. set n := n'.+1. -apply: (@leR_ltR_trans (n.+1%:R ^ K * exp2 (- n%:R * Delta))). +apply: (@le_lt_trans _ _ (n.+1%:R ^+ K * 2 `^ (- n%:R * Delta))). exact: HDelta. -move: (n0_n) => /(@ltR_pmul2l (/ n%:R) _) => /(_ (invR_gt0 n%:R Rlt0n)). -rewrite mulVR ?INR_eq0' //. -move/(@ltR_pmul2l epsilon) => /(_ eps_gt0); rewrite mulR1 => H1'. -apply: (leR_ltR_trans _ H1') => {H1'}. -rewrite /n0 [in X in _ <= X]mulRC -2![in X in _ <= X]mulRA. -rewrite mulVR ?mulR1 ?gtR_eqF //. -apply Rge_le; rewrite mulRC -2!mulRA; apply Rle_ge. +move: (n0_n). +rewrite -[in X in X -> _](@ltr_pM2l _ n%:R^-1) ?invr_gt0 ?ltr0n//. +rewrite mulVf ?pnatr_eq0//. +rewrite -[in X in X -> _](@ltr_pM2l _ epsilon)// mulr1. +apply: le_lt_trans. +rewrite /n0. +rewrite [in X in _ <= X]mulrC. +rewrite -6![in X in _ <= X]mulrA. +rewrite mulVf ?gt_eqF// mulr1. +rewrite [leRHS]mulrC. +rewrite -2!mulrA. set aux := _%:R * (_ * _). have aux_gt0 : 0 < aux. - apply mulR_gt0; first exact/ltR0n/fact_gt0. - apply mulR_gt0; [exact/invR_gt0/expR_gt0/mulR_gt0 | exact/invR_gt0]. -apply (@leR_trans ((n.+1%:R / n%:R) ^ K * aux)); last first. - apply leR_pmul => //. - - apply/expR_ge0/divR_ge0 => //; exact: leR0n. - - exact: ltRW. - - apply pow_incr; split. - + apply divR_ge0 => //; exact: leR0n. - + apply (@leR_pmul2r n%:R) => //. - rewrite -mulRA mulVR // ?mulR1 ?INR_eq0' ?gtn_eqF // (_ : 2 = 2%:R) //. - rewrite -natRM; apply/le_INR/leP; by rewrite -{1}(mul1n n) ltn_pmul2r. - - by apply/RleP; rewrite Order.POrderTheory.lexx. -rewrite expRM -mulRA; apply leR_pmul => //. -- exact/expR_ge0/ltRW/ltR0n. -- by apply/RleP; rewrite Order.POrderTheory.lexx. -- apply invR_le => //. - + apply mulR_gt0; last exact aux_gt0. - rewrite expRV ?INR_eq0' //; exact/invR_gt0/expR_gt0. - + rewrite -exp2_Ropp mulNR oppRK /exp2. - have nDeltaln2 : 0 <= n%:R * Delta * ln 2. - apply mulR_ge0; last exact/ltRW. - apply mulR_ge0; [exact/leR0n | exact/ltRW]. - apply: (leR_trans _ (exp_lb (K.+1) nDeltaln2)) => {nDeltaln2}. - apply Req_le. - rewrite invRM; last 2 first. - exact/gtR_eqF/expR_gt0/invR_gt0. - exact/gtR_eqF. - rewrite -/(Rdiv _ _) divRM; last 2 first. - by rewrite INR_eq0' gtn_eqF // fact_gt0. - rewrite gtR_eqF //; apply/mulR_gt0; last exact/invR_gt0. - exact/invR_gt0/expR_gt0/mulR_gt0. - rewrite -mulRA mulRC invRM; last 2 first. - - by apply/eqP/invR_neq0/eqP; rewrite expR_eq0 mulR_neq0' ln2_neq0 andbT; exact/gtR_eqF. - - by apply/eqP/invR_neq0/eqP; by rewrite INR_eq0'. - - rewrite 2!invRK (_ : / (/ n%:R) ^ K = n%:R ^ K); last first. - rewrite expRV ?INR_eq0' // invRK //; apply/expR_neq0; by rewrite INR_eq0'. - rewrite -mulRA {1}/Rdiv (mulRA n%:R) -expRS mulRA -expRM. - by rewrite -/(Rdiv _ _) mulRCA -mulRA (mulRC (ln 2)). + rewrite mulr_gt0 ?ltr0n ?fact_gt0// divr_gt0//. + by rewrite invr_gt0// exprn_gt0// mulr_gt0// ln_gt0 ?ltr1n. +apply (@le_trans _ _ ((n.+1%:R / n%:R) ^+ K * aux)); last first. + rewrite ler_pM2r//. + rewrite lerXn2r ?nnegrE ?divr_ge0//. + rewrite ler_pdivrMr ?ltr0n//. + by rewrite -[in leRHS]mulrC mulr_natr mulr2n -natr1 lerD2l ler1n. +rewrite expr_div_n -mulrA ler_wpM2l//. +- by rewrite exprn_ge0. +- rewrite -lef_pV2 ?posrE ?powR_gt0//; last first. + by rewrite mulr_gt0// invr_gt0 exprn_gt0. + rewrite -powRN mulNr opprK. + have nDeltaln2 : 0 < n%:R * Delta * ln 2. + by rewrite mulr_gt0// ?ln_gt0 ?ltr1n// mulr_gt0//. + rewrite /exp.powR(* TODO *) pnatr_eq0/=. + apply/ltW. + apply: (le_lt_trans _ (exp_strict_lb K.+1 nDeltaln2)) => {nDeltaln2}. + apply/eqW. + rewrite invfM invrK. + rewrite /aux. + rewrite !invfM. + rewrite mulrCA mulrC. + congr (_ / _). + rewrite invrK. + rewrite mulrCA. + rewrite invrK -exprSr. + rewrite -exprMn_comm//; last by rewrite /GRing.comm [in RHS]mulrC. + by rewrite mulrC mulrA. Qed. End channel_coding_converse. diff --git a/information_theory/channel_coding_direct.v b/information_theory/channel_coding_direct.v index 3198c51f..cb712dc4 100644 --- a/information_theory/channel_coding_direct.v +++ b/information_theory/channel_coding_direct.v @@ -1,10 +1,11 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From HB Require Import structures. -From mathcomp Require Import all_ssreflect ssralg ssrnum matrix perm. -Require Import Reals Lra Classical. -From mathcomp Require Import Rstruct classical_sets. -Require Import ssrZ ssrR Reals_ext realType_ext logb ssr_ext ssralg_ext bigop_ext. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint matrix perm. +From mathcomp Require Import archimedean lra ring. +From mathcomp Require Import mathcomp_extra boolp classical_sets reals Rstruct. +From mathcomp Require Import exp. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln. Require Import fdist proba entropy aep typ_seq joint_typ_seq channel. Require Import channel_code. @@ -28,27 +29,30 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. Local Open Scope fdist_scope. +Local Open Scope ring_scope. Local Open Scope jtyp_seq_scope. Local Open Scope channel_code_scope. Local Open Scope channel_scope. Local Open Scope vec_ext_scope. +Import Order.Theory GRing.Theory Num.Theory. +#[local] Definition R := Rdefinitions.R. + Module Wght. Section wght. Variables (A M : finType) (P : {fdist A}) (n : nat). -Definition f := [ffun g : encT A M n => \prod_(m in M) P `^ n (g m)]. +Definition f := [ffun g : encT A M n => \prod_(m in M) (P `^ n)%fdist (g m)]. -Lemma f0 g : (0 <= f g)%mcR. Proof. rewrite ffunE; apply/RleP; exact: prodR_ge0. Qed. +Lemma f0 g : 0 <= f g. Proof. by rewrite ffunE prodr_ge0. Qed. Lemma f1 : \sum_(g in {ffun M -> 'rV[A]_n}) f g = 1. Proof. under eq_bigr do rewrite ffunE /=. -rewrite -(bigA_distr_bigA (fun _ v => P `^ n v)) /=. +rewrite -(bigA_distr_bigA (fun _ => (P `^ n)%fdist)) /=. rewrite [RHS](_ : _ = \prod_(m0 : M | xpredT m0) 1); last by rewrite big1. -by apply eq_bigr => _ _; rewrite (FDist.f1 (P `^ n)). +by apply eq_bigr => _ _; rewrite (FDist.f1 (P `^ n)%fdist). Qed. Definition d : {fdist encT A M n} := locked (FDist.make f0 f1). @@ -92,15 +96,15 @@ Lemma good_code_sufficient_condition P W epsilon exists f, echa(W , mkCode f (phi f)) < epsilon. Proof. move=> H. -apply not_all_not_ex => abs. +apply/not_existsP => abs. set x := \sum_(f <- _) _ in H. have : \sum_(f : encT A M n) Wght.d P f * epsilon <= x. - rewrite /x; apply leR_sumRl => //= f _. - - by apply leR_wpmul2l => //; exact/Rnot_lt_le/abs. - - by apply mulR_ge0 => //; exact/RleP/echa_ge0. -apply/Rlt_not_le/(@ltR_leR_trans epsilon) => //. -rewrite -big_distrl /= (FDist.f1 (Wght.d P)) mul1R. -by apply/RleP; rewrite Order.POrderTheory.lexx. + rewrite /x ler_suml => //= f _. + by rewrite ler_wpM2l // leNgt; exact/negP. +apply/negP. +rewrite -ltNge. +apply/(lt_le_trans H). +by rewrite -big_distrl /= (FDist.f1 (Wght.d P)) mul1r. Qed. Definition o_PI (m m' : M) := fun g : encT A M n => [ffun x => g (tperm m m' x)]. @@ -217,19 +221,11 @@ End joint_typicality_decoding. (* TODO: move? *) Section sum_rV_ffun. -Import Monoid.Theory. -Variable R : Type. -Variable times : Monoid.mul_law 0. -Local Notation "*%M" := times (at level 0). -Variable plus : Monoid.add_law 0 *%M. -Local Notation "+%M" := plus (at level 0). - -Lemma sum_rV_ffun (I J : finType) (F : {ffun I -> J} -> R) +Lemma sum_rV_ffun S (I J : finType) (F : {ffun I -> J} -> S) (G : _ -> _ -> _) (idef : I) (zero : 'I_ _) : O = zero -> - \big[+%M/0]_(j : 'rV[J]_#|I|) G (F [ffun x => j ord0 (enum_rank x)]) (j ord0 zero) = - \big[+%M/0]_(f : {ffun I -> J}) G (F f) (f (nth idef (enum I) 0)). + \sum_(j : 'rV[J]_#|I|) G (F [ffun x => j ord0 (enum_rank x)]) (j ord0 zero) = + \sum_(f : {ffun I -> J}) G (F f) (f (nth idef (enum I) 0)) :> R. Proof. -Local Open Scope ring_scope. move=> Hzero. rewrite (reindex_onto (fun y : {ffun _ -> J} => \row_(i < _) y (enum_val i)) (fun p => [ffun x => p ord0 (enum_rank x)])) //. @@ -245,7 +241,6 @@ rewrite (reindex_onto (fun y : {ffun _ -> J} => \row_(i < _) y (enum_val i)) move=> i _. apply/rowP => a; by rewrite mxE ffunE enum_valK. Qed. - End sum_rV_ffun. Section random_coding_good_code_existence. @@ -255,9 +250,11 @@ Variables (B A : finType) (W : `Ch(A, B)) (P : {fdist A}). Definition epsilon0_condition r epsilon epsilon0 := 0 < epsilon0 /\ epsilon0 < epsilon / 2 /\ epsilon0 < (`I(P, W) - r) / 4. +(* TODO move *) +Definition frac_part (x : R) := x - (Num.floor x)%:~R. Definition n_condition r epsilon0 n := - (O < n)%nat /\ - log epsilon0 / epsilon0 < INR n /\ - frac_part (exp2 (INR n * r)) = 0 /\ (JTS_1_bound P W epsilon0 <= n)%nat. + (O < n)%nat /\ - log epsilon0 / epsilon0 < n%:R /\ + frac_part (2 `^ (r *+ n)) = 0 /\ (JTS_1_bound P W epsilon0 <= n)%nat. Definition cal_E M n epsilon (f : encT A M n) m := [set vb | prod_rV (f m, vb) \in `JTS P W n epsilon]. @@ -287,9 +284,9 @@ Qed. (* TODO: move? *) Lemma rsum_rmul_tuple_pmf_tnth {C : finType} n k (Q : {fdist C}) : - \sum_(t : {:k.-tuple ('rV[C]_n)}) \prod_(m < k) (Q `^ n) t !_ m = 1. + \sum_(t : {:k.-tuple ('rV[C]_n)}) \prod_(m < k) (Q `^ n)%fdist t !_ m = 1. Proof. -transitivity (\sum_(j : {ffun 'I_k -> 'rV[_]_n}) \prod_(m < k) Q `^ _ (j m)). +transitivity (\sum_(j : {ffun 'I_k -> 'rV[_]_n}) \prod_(m < k) (Q `^ _)%fdist (j m)). rewrite (reindex_onto (fun p => [ffun x => p!_(enum_rank x)]) (fun x => fgraph x)) //=; last first. by move=> f _; apply/ffunP => /= i; rewrite ffunE tnth_fgraph enum_rankK. @@ -298,13 +295,13 @@ transitivity (\sum_(j : {ffun 'I_k -> 'rV[_]_n}) \prod_(m < k) Q `^ _ (j m)). - move=> i /=; apply/esym/eqP/eq_from_tnth => j. by rewrite tnth_fgraph ffunE enum_valK. - by move=> i _; apply eq_bigr => j _; rewrite ffunE /= tcastE -enum_rank_ord. -rewrite -(bigA_distr_bigA (fun m xn => Q `^ _ xn)) /= big_const. -by rewrite FDist.f1 iter_mulR exp1R. +rewrite -(bigA_distr_bigA (fun _ => (Q `^ _)%fdist)) /= big_const. +by rewrite FDist.f1 iter_mulr mulr1 expr1n. Qed. (* TODO: move? *) Lemma rsum_rmul_tuple_pmf {C : finType} n k (Q : {fdist C}) : - \sum_(t in {:k.-tuple ('rV[C]_n)}) \prod_(x <- t) (Q `^ n) x = 1. + \sum_(t in {:k.-tuple ('rV[C]_n)}) \prod_(x <- t) (Q `^ n)%fdist x = 1. Proof. rewrite -[X in _ = X](rsum_rmul_tuple_pmf_tnth n k Q). apply eq_bigr => t _. @@ -322,7 +319,7 @@ Lemma first_summand k n epsilon0 : let M := 'I_k.+1 in (\sum_(f : encT A M n) Wght.d P f * Pr (W ``(| f ord0)) (~: cal_E epsilon0 f ord0)) = - Pr ((P `X W) `^ n) (~: `JTS P W n epsilon0). + Pr ((P `X W) `^ n)%fdist (~: `JTS P W n epsilon0). Proof. move=> M. have M_prednK : #|M|.-1.+1 = #|M| by rewrite card_ord. @@ -331,13 +328,14 @@ rewrite {1}/cal_E. case/card_gt0P : (fdist_card_neq0 P) => a _. pose zero := @enum_rank M ord0. have : 0%N = zero :> nat by rewrite /zero enum_rank_ord. -move/(@sum_rV_ffun _ _ _ _ _ (Wght.d P) - (fun r v => r * Pr (W ``(| v )) (~: [set w | prod_rV (v, w) \in `JTS P W n epsilon0])) - ord0 zero). +move/(sum_rV_ffun (Wght.d P) + (fun r v => + r * Pr (W ``(| v )) (~: [set w | prod_rV (v, w) \in `JTS P W n epsilon0])) + ord0). rewrite (_ : nth ord0 (enum M) 0 = ord0); last by rewrite enum_ordSl. move=> <- /=. transitivity (\sum_(v : 'rV['rV[A]_n]_#|M|) ( - (\prod_(m : M) P `^ n ([ffun x => v ``_ x] (enum_rank m))) * + (\prod_(m : M) (P `^ n)%fdist ([ffun x => v ``_ x] (enum_rank m))) * \sum_(w | w \in ~: cal_E epsilon0 [ffun x => v ``_ x] zero) (W ``(| [ffun x => v ``_ x] zero)) w)). apply eq_bigr => v _; congr (_ * _). @@ -351,12 +349,14 @@ transitivity (\sum_(v : 'rV[A]_n) (\sum_(y in ~: [set w | prod_rV (v, w) \in `JTS P W n epsilon0]) (W ``(| v)) y) * \sum_(j in {: #|M|.-1.-tuple ('rV[A]_n)}) - (\prod_(m : M) P `^ _ ((tcast M_prednK [tuple of v :: j]) !_ (enum_rank m)))). - rewrite (reindex_onto (fun y : {ffun _ -> 'rV__} => \row_(i < _) y (enum_val i)) + (\prod_(m : M) + (P `^ _)%fdist ((tcast M_prednK [tuple of v :: j]) !_ (enum_rank m)))). + rewrite (reindex_onto + (fun y : {ffun _ -> 'rV__} => \row_(i < _) y (enum_val i)) (fun p : 'rV_ _ => [ffun x => p ``_ (enum_rank x)])) //=; last first. move=> v _; by apply/rowP => i; rewrite mxE ffunE enum_valK. apply trans_eq with (\sum_(f : {ffun M -> 'rV__}) - ((\prod_(m < k.+1) P `^ n (f m)) * + ((\prod_(m < k.+1) (P `^ n)%fdist (f m)) * \sum_(y in ~: [set y0 | prod_rV (f ord0, y0) \in `JTS P W n epsilon0]) W ``(y | f ord0))). apply eq_big => //= f. @@ -367,12 +367,12 @@ transitivity (\sum_(v : 'rV[A]_n) move=> ?; by rewrite !inE -[in RHS]Hf !ffunE mxE. move=> ? _; by rewrite -[in RHS]Hf !ffunE mxE. rewrite (_ : ord0 = nth ord0 (enum M) 0); last by rewrite enum_ordSl. - rewrite -(big_tuple_ffun _ (fun f => \prod_(m : M) P `^ n (f m)) + rewrite -(big_tuple_ffun _ (fun f => \prod_(m : M) (P `^ n)%fdist (f m)) (fun r yn => r * (\sum_(y in ~: [set y0 | prod_rV (yn, y0) \in `JTS P W n epsilon0]) - W ``(y | yn))) (\row_(i < n) a) ord0)%R. + W ``(y | yn))) (\row_(i < n) a) ord0). transitivity (\sum_(j : _) - (\prod_(m : M) P `^ n ((tcast M_prednK j) !_ (enum_rank m))) * + (\prod_(m : M) (P `^ n)%fdist ((tcast M_prednK j) !_ (enum_rank m))) * (\sum_(y in ~: [set y0 | prod_rV (nth (\row_(i < n) a) j 0, y0) \in `JTS P W n epsilon0]) W ``(y | nth (\row_(i < n) a) j 0))). @@ -385,44 +385,43 @@ transitivity (\sum_(v : 'rV[A]_n) by rewrite tcastE /= cast_ord_id. apply eq_big => m; by rewrite !inE H. rewrite -(@big_tuple_cons_behead _ #|M|.-1 - (fun j => ((\prod_(m : M) P `^ n ((tcast M_prednK j) !_ (enum_rank m))) * + (fun j => ((\prod_(m : M) (P `^ n)%fdist ((tcast M_prednK j) !_ (enum_rank m))) * (\sum_(y in ~: [set y0 | prod_rV (nth (\row_(i < n) a) j 0, y0) \in `JTS P W n epsilon0]) W ``(y | nth (\row_(i < n) a) j 0)))) xpredT xpredT). - apply eq_bigr => ta _ /=; by rewrite -big_distrl /= mulRC. -transitivity ((\sum_(ta in 'rV[A]_n) P `^ _ ta * + apply eq_bigr => ta _ /=; by rewrite -big_distrl /= mulrC. +transitivity ((\sum_(ta in 'rV[A]_n) (P `^ _)%fdist ta * (\sum_(y in ~: [set y0 | prod_rV (ta, y0) \in `JTS P W n epsilon0]) (W ``(| ta ) ) y)) * - \sum_(j in {:k.-tuple ('rV[A]_n)}) \prod_(m < k) (P `^ _ (j !_ m)))%R. + \sum_(j in {:k.-tuple ('rV[A]_n)}) \prod_(m < k) ((P `^ _)%fdist (j !_ m))). rewrite big_distrl /=. apply eq_bigr => ta _. - rewrite -mulRA mulRCA; congr Rmult. + rewrite -mulrA mulrCA; congr (_ * _). transitivity (\sum_(j in {: #|'I_k|.-tuple ('rV[A]_n) }) - P `^ _ ta * \prod_(m < k) P `^ _ (j !_ (enum_rank m)))%R. + (P `^ _)%fdist ta * \prod_(m < k) (P `^ _)%fdist (j !_ (enum_rank m))). have k_prednK : #|'I_k.+1|.-1 = #|'I_k| by rewrite !card_ord. rewrite (big_tcast (esym k_prednK)) esymK. apply eq_bigr => i0 Hi0. rewrite big_ord_recl /=. - congr (P `^ _ _ * _)%R; first by rewrite tcastE // enum_rank_ord. - apply eq_bigr => i1 _; congr (P `^ _ _). + congr ((P `^ _)%fdist _ * _); first by rewrite tcastE // enum_rank_ord. + apply eq_bigr => i1 _; congr ((P `^ _)%fdist _). rewrite !tcastE {1}/tnth /=. rewrite (_ : enum_rank _ = (enum_rank i1).+1 :> nat) /=; last by rewrite !enum_rank_ord. apply set_nth_default; by rewrite size_tuple /= enum_rank_ord /= card_ord. - rewrite -big_distrr /=; congr (_ * _)%R. + rewrite -big_distrr /=; congr (_ * _). rewrite (big_tcast (esym (card_ord k))) esymK. apply eq_bigr => /= i0 _. apply eq_bigr => /= i1 _. by rewrite tcastE -enum_rank_ord. -rewrite rsum_rmul_tuple_pmf_tnth mulR1. +rewrite rsum_rmul_tuple_pmf_tnth mulr1. transitivity (\sum_(v in 'rV[A]_n) \sum_(y in ~: [set w | prod_rV (v, w) \in `JTS P W n epsilon0]) - ((P `X W) `^ n (prod_rV (v, y))))%R. + (((P `X W) `^ n)%fdist (prod_rV (v, y)))). apply eq_bigr => /= v _. rewrite big_distrr /=. apply eq_bigr => // w _. rewrite DMCE 2!fdist_rVE -big_split /=. apply eq_bigr => /= i _. - rewrite fdist_prodE -fst_tnth_prod_rV -snd_tnth_prod_rV /= mulRC. - by rewrite RmultE GRing.mulrC. + by rewrite fdist_prodE -fst_tnth_prod_rV -snd_tnth_prod_rV /=. rewrite /Pr big_rV_prod pair_big_dep /=. by apply eq_bigl; case=> /= ? ?; rewrite !inE. Qed. @@ -430,11 +429,11 @@ Qed. (* TODO: move? *) Lemma big_cat_tuple {C : finType} m n (F : (m + n)%nat.-tuple C -> R) : (\sum_(i in {:m.-tuple C}) \sum_(j in {: n.-tuple C}) - F [tuple of (i ++ j)] = \sum_(p in {: (m + n)%nat.-tuple C}) (F p))%R. + F [tuple of (i ++ j)] = \sum_(p in {: (m + n)%nat.-tuple C}) (F p)). Proof. elim: m n F => [m2 F /=|m IH n F]. - transitivity (\sum_(i <- [tuple] :: [::]) - \sum_(j in {: m2.-tuple C}) F [tuple of i ++ j] )%R. + \sum_(j in {: m2.-tuple C}) F [tuple of i ++ j] ). apply congr_big => //=. apply (@eq_from_nth _ [tuple]); rewrite /index_enum -enumT /= (eqP (enum_tupleP _)) card_tuple expn0 //. @@ -442,11 +441,12 @@ elim: m n F => [m2 F /=|m IH n F]. rewrite tupleE /=. case: (enum _) => //= t. by rewrite (tuple0 t). - rewrite big_cons /= big_nil /= addR0. + rewrite big_cons /= big_nil /= addr0. apply eq_bigr => // i _; congr F. exact/val_inj. - symmetry. - transitivity (\sum_(p in [the finType of (m + n).+1.-tuple C]) F p)%R; first by apply congr_big. + transitivity (\sum_(p in [the finType of (m + n).+1.-tuple C]) F p); + first by apply congr_big. rewrite -(@big_tuple_cons_behead _ _ _ xpredT xpredT). rewrite -(@big_tuple_cons_behead _ _ _ xpredT xpredT). apply eq_bigr => i _. @@ -457,11 +457,11 @@ Qed. (* TODO: move? *) Lemma big_cat_tuple_seq {C : finType} m n (F : seq C -> R) : - (\sum_(i in {:m.-tuple C} ) \sum_(j in {: n.-tuple C}) (F (i ++ j)) = - \sum_(p in {: (m + n)%nat.-tuple C}) (F p))%R. + \sum_(i in {:m.-tuple C} ) \sum_(j in {: n.-tuple C}) (F (i ++ j)) = + \sum_(p in {: (m + n)%nat.-tuple C}) (F p). Proof. -move: (@big_cat_tuple _ m n (fun l => if size l == (m + n)%nat then F l else R0)). -set lhs := (\sum_(i in _) _)%R => H. +move: (@big_cat_tuple _ m n (fun l => if size l == (m + n)%nat then F l else 0)). +set lhs := (\sum_(i in _) _) => H. apply trans_eq with lhs. apply eq_bigr => /= t _; apply eq_bigr => /= t' _. case: ifP => //; by rewrite size_tuple eqxx. @@ -472,8 +472,8 @@ Lemma second_summand n k epsilon0 : let M := 'I_k.+1 in forall i, i != ord0 -> (\sum_(f : encT A M n) Wght.d P f * - Pr (W ``(| f ord0)) (cal_E epsilon0 f i))%R = - Pr ((P `^ n) `x `O( P , W ) `^ n) [set x | prod_rV x \in `JTS P W n epsilon0]. + Pr (W ``(| f ord0)) (cal_E epsilon0 f i)) = + Pr ((P `^ n) `x `O( P , W ) `^ n)%fdist [set x | prod_rV x \in `JTS P W n epsilon0]. Proof. move=> M. have M_prednK : #|M|.-1.+1 = #|M| by rewrite card_ord. @@ -489,7 +489,7 @@ transitivity ( \sum_(ji in 'rV[A]_n) Wght.d P [ffun x => (tcast Hcast [tuple of j0 :: j1 ++ ji :: j2])!_x] * \sum_(y | y \in [set w | prod_rV (ji, w) \in `JTS P W n epsilon0]) - (W ``(| j0)) y)%R. + (W ``(| j0)) y). transitivity ( \sum_(j0 in 'rV[A]_n) \sum_(j1 in {: i.-1.-tuple ('rV[A]_n)}) @@ -497,12 +497,12 @@ transitivity ( \sum_(j2 in {: (#|M| - i.+1).-tuple ('rV[A]_n)}) Wght.d P [ffun x => (tcast Hcast [tuple of j0 :: j1 ++ ji :: j2])!_x] * \sum_( y | y \in [set w | prod_rV (ji, w) \in `JTS P W n epsilon0]) - (W ``(| j0) ) y)%R. + (W ``(| j0) ) y). rewrite (reindex_onto (fun p => [ffun x => p!_(enum_rank x)]) (fun y => fgraph y)) /=; last first. move=> f _; apply/ffunP => m; by rewrite ffunE tnth_fgraph enum_rankK. transitivity ( \sum_(j : _) (Wght.d P [ffun x => j!_(enum_rank x)] * - Pr (W ``(| [ffun x => j!_(enum_rank x)] ord0)) (E_F_N [ffun x => j!_(enum_rank x)] i)))%R. + Pr (W ``(| [ffun x => j!_(enum_rank x)] ord0)) (E_F_N [ffun x => j!_(enum_rank x)] i))). apply eq_big => //= x; apply/eqP/eq_from_tnth => j. by rewrite tnth_fgraph ffunE enum_valK. rewrite (big_tcast (card_ord k.+1)). @@ -520,11 +520,11 @@ transitivity ( rewrite (big_tcast Hs) -(big_tuple_cons_behead _ xpredT xpredT). apply eq_bigr => i2 _. have Ht : (#|'I_k.+1| - i.+1 = k - i)%nat by rewrite card_ord /= subSS. - rewrite (big_tcast Ht) //; apply eq_bigr => /= i3 _; congr (_ * _)%R. + rewrite (big_tcast Ht) //; apply eq_bigr => /= i3 _; congr (_ * _). - rewrite 2!Wght.dE /Wght.f 2!ffunE /=. rewrite (reindex_onto enum_rank enum_val); last by move=> *; rewrite enum_valK. apply eq_big => /=; first by move=> x; rewrite enum_rankK eqxx inE. - move=> i4 _; congr (P `^ _ _). + move=> i4 _; congr ((P `^ _)%fdist _). rewrite !ffunE; congr (_ !_ _). apply/val_inj => /=. rewrite [LHS]eq_tcast /= !eq_tcast /= [RHS]eq_tcast eq_tcast /=; congr (_ :: _ ++ _ :: _). @@ -550,13 +550,13 @@ transitivity ( transitivity ( (\sum_(j1 in {: i.-1.-tuple ('rV[A]_n)}) \sum_(j2 in {: (#|M| - i.+1).-tuple ('rV[A]_n)}) - \prod_(i <- j1 ++ j2) (P `^ n) i) * + \prod_(i <- j1 ++ j2) (P `^ n)%fdist i) * (\sum_(j0 in 'rV[A]_n) \sum_(ji in 'rV[A]_n) - ((P `^ n) j0) * ((P `^ n) ji) * + ((P `^ n)%fdist j0) * ((P `^ n)%fdist ji) * (\sum_( y | y \in [set y0 | prod_rV (ji , y0) \in `JTS P W n epsilon0]) - (W ``(| j0) ) y)))%R. + (W ``(| j0) ) y))). rewrite !big_distrl /=. apply eq_bigr => j1 _. rewrite !big_distrl /=. @@ -565,59 +565,59 @@ transitivity ( apply eq_bigr => j0 _. rewrite !big_distrr /=. apply eq_bigr => j3 _. - rewrite !mulRA Wght.dE /Wght.f /=; congr (_ * _)%R. - transitivity (\prod_( i <- j0 :: j1 ++ j3 :: j2) P `^ _ i)%R; last first. - rewrite big_cons -mulRA mulRCA; congr (_ * _)%R. - rewrite big_cat /= big_cons [in RHS]mulRC mulRCA; congr (_ * _)%R. - by rewrite big_cat /= mulRC. + rewrite !mulrA Wght.dE /Wght.f /=; congr (_ * _). + transitivity (\prod_( i <- j0 :: j1 ++ j3 :: j2) (P `^ _)%fdist i); last first. + rewrite big_cons -mulrA mulrCA; congr (_ * _). + rewrite big_cat /= big_cons [in RHS]mulrC mulrCA; congr (_ * _). + by rewrite big_cat /= mulrC. rewrite [in RHS](big_nth j0) /= big_mkord. transitivity (\prod_(j < #|@predT M|) - P `^ _ ([ffun x => (tcast Hcast [tuple of j0 :: j1 ++ j3 :: j2])!_(enum_rank x)] (enum_val j)))%R. + (P `^ _)%fdist ([ffun x => (tcast Hcast [tuple of j0 :: j1 ++ j3 :: j2])!_(enum_rank x)] (enum_val j))). rewrite ffunE; apply eq_big => ? //= _. by rewrite !ffunE enum_valK. have j_M : (size (j1 ++ j3 :: j2)).+1 = #|M|. rewrite size_cat (size_tuple j1) /= (size_tuple j2) card_ord. by rewrite -[RHS](card_ord k.+1) -Hcast card_ord. rewrite j_M. - apply eq_bigr => i0 _; congr (P `^ n _). + apply eq_bigr => i0 _; congr ((P `^ n)%fdist _). rewrite ffunE /= enum_valK tcastE /tnth /=. apply set_nth_default; by rewrite /= j_M ltn_ord. transitivity (\sum_(j0 : 'rV[A]_n) \sum_(ji : 'rV[A]_n) - ((P `^ n) j0) * ((P `^ n) ji) * (\sum_( y | y \in + ((P `^ n)%fdist j0) * ((P `^ n)%fdist ji) * (\sum_( y | y \in [set y0 in 'rV[B]_n | prod_rV (ji , y0) \in `JTS P W n epsilon0]) - (W ``(| j0)) y))%R. - set lhs := (\sum_(_ <- _) _)%R. - suff : lhs = 1%R by move=> ->; rewrite mul1R. + (W ``(| j0)) y)). + set lhs := (\sum_(_ <- _) _). + suff : lhs = 1 by move=> ->; rewrite mul1r. rewrite /lhs {lhs}. - rewrite (@big_cat_tuple_seq _ i.-1 (#|M| - i.+1) (fun x => \prod_(i0 <- x) (P `^ n) i0))%R. + rewrite (@big_cat_tuple_seq _ i.-1 (#|M| - i.+1) (fun x => \prod_(i0 <- x) (P `^ n)%fdist i0)). by rewrite rsum_rmul_tuple_pmf. -transitivity (\sum_(ji : 'rV[A]_n) ((P `^ n) ji) * +transitivity (\sum_(ji : 'rV[A]_n) ((P `^ n)%fdist ji) * (\sum_(y | y \in [set y0 | prod_rV (ji , y0) \in `JTS P W n epsilon0]) - \sum_(j0 : 'rV[A]_n) ((W ``(| j0) ) y) * ((P `^ n) j0)))%R. + \sum_(j0 : 'rV[A]_n) ((W ``(| j0) ) y) * ((P `^ n)%fdist j0))). rewrite exchange_big /=. apply eq_bigr => ta _. - transitivity (\sum_(i1 : 'rV[A]_n) P `^ _ ta * P `^ _ i1 * + transitivity (\sum_(i1 : 'rV[A]_n) (P `^ _)%fdist ta * (P `^ _)%fdist i1 * (\sum_(y in [set y0 | prod_rV (ta, y0) \in `JTS P W n epsilon0]) - W ``(y | i1)))%R. + W ``(y | i1))). apply eq_bigr => i1 _. - by rewrite -mulRA mulRCA mulRA. + by rewrite -mulrA mulrCA mulrA. rewrite exchange_big /= big_distrr /=. apply eq_bigr => ta' _. - rewrite -[in X in _ = (_ * X)%R]big_distrl /= -mulRA; congr Rmult. - by rewrite mulRC. -transitivity (\sum_(ji : 'rV[A]_n) ((P `^ n) ji) * + rewrite -[in X in _ = (_ * X)]big_distrl /= -mulrA; congr (_ * _). + by rewrite mulrC. +transitivity (\sum_(ji : 'rV[A]_n) ((P `^ n)%fdist ji) * \sum_( y | y \in [set y0 | prod_rV (ji , y0) \in `JTS P W n epsilon0]) - ((`O(P , W)) `^ n) y)%R. - apply eq_bigr => ta _; congr (_ * _)%R; apply eq_bigr => /= tb _. + ((`O(P , W)) `^ n)%fdist y). + apply eq_bigr => ta _; congr (_ * _); apply eq_bigr => /= tb _. by rewrite fdist_rV_out; apply eq_bigr => i0 _; by rewrite DMCE. transitivity (\sum_(v : 'rV[A]_n) (\sum_(y | y \in [set y0 | prod_rV (v , y0) \in `JTS P W n epsilon0]) - ((P `^ n) `x ((`O(P , W)) `^ n)) (v, y)))%R. + ((P `^ n) `x ((`O(P , W)) `^ n))%fdist (v, y))). apply eq_bigr => // v _. rewrite big_distrr /=; apply eq_bigr => w _; by rewrite fdist_prodE. transitivity (\sum_( jiy | prod_rV jiy \in `JTS P W n epsilon0) - ((P `^ n) `x ((`O(P , W)) `^ n)) jiy)%R. + ((P `^ n) `x ((`O(P , W)) `^ n))%fdist jiy). rewrite [in LHS]pair_big_dep /=. by apply eq_big => -[? ?] /=; rewrite !inE ?fdist_prodE. by apply eq_bigl => ?; rewrite !inE. @@ -653,7 +653,7 @@ apply/idP/idP. move: Hm2; apply contra => Hm2. apply/forallP => m_; apply/implyP => m_m0. apply: contra Hm2 => Hm2. - apply/bigcupP; exists m_ => //; by rewrite /Cal_E /cal_E inE. + by apply/bigcupP; exists m_ => //; rewrite /Cal_E /cal_E inE. - rewrite finset.in_setU ffunE. case: (pickP _) => [m2 Hm2|//]. case/orP. @@ -662,87 +662,93 @@ apply/idP/idP. by case/andP : Hm2; rewrite m20 (negbTE Hy). + case/bigcupP => m Hm; rewrite /cal_E 2!inE => m_tb. apply/eqP => -[m20]. - case/andP : Hm2 => _ /forallP /(_ m); by rewrite !inE m_tb m20 Hm implyTb. + by case/andP : Hm2 => _ /forallP /(_ m); rewrite !inE m_tb m20 Hm implyTb. Qed. -Local Open Scope zarith_ext_scope. +(* TODO: move *) +Lemma ExpK (R' : realType) n x : (1 < n)%N -> Log n (n%:R `^ x) = x :> R'. +Proof. +move=> n1; rewrite /Log prednK// 1?ltnW// ln_powR mulrK //. +by apply/unitf_gt0/ln_gt0; rewrite ltr1n. +Qed. Lemma random_coding_good_code epsilon : 0 <= epsilon -> forall (r : CodeRateType), forall epsilon0, epsilon0_condition r epsilon epsilon0 -> forall n, n_condition r epsilon0 n -> - exists M : finType, (0 < #|M|)%nat /\ #|M| = '| Int_part (exp2 (INR n * r)) | /\ + exists M : finType, (0 < #|M|)%nat /\ #|M| = `| Num.floor (2 `^ (rate r *+ n)) |%N /\ let Jtdec := jtdec P W epsilon0 in - \sum_(f : encT A M n) (Wght.d P f * echa(W , mkCode f (Jtdec f)))%R < epsilon. + (\sum_(f : encT A M n) Wght.d P f * echa(W , mkCode f (Jtdec f))) < epsilon. Proof. move=> Hepsilon r epsilon0 Hepsilon0 n Hn. -have [k Hk] : exists k, (log (INR k.+1) / INR n = r)%R. +have [k Hk] : exists k, log k.+1%:R / n%:R = r :> R. case: Hn => ? [? [Hn2 ?]]. - case/fp_nat : Hn2 => k Hn2. - exists '| k |.-1. + exists `| Num.floor (2 `^ (rate r *+ n)) |.-1. rewrite prednK; last first. - apply/ltP/INR_lt. (* TODO: ssrZ? *) - rewrite INR_Zabs_nat; [by rewrite -Hn2 | apply le_IZR; by rewrite -Hn2]. - rewrite -(@eqR_mul2l (INR n)); last by rewrite INR_eq0; apply/eqP; rewrite -lt0n. - rewrite mulRCA mulRV ?INR_eq0' -?lt0n // mulR1 -(exp2K (INR n * r)) Hn2 INR_Zabs_nat //. - apply le_IZR; by rewrite -Hn2. + rewrite absz_gt0; apply/eqP => Habs. + rewrite /frac_part Habs subr0 in Hn2. + by move/eqP : Hn2; apply/negP; rewrite gt_eqF// powR_gt0. + rewrite eqr_divr_mulr; last by rewrite (eqr_nat R n 0) -lt0n. + rewrite -[in LHS]mulrz_nat natz gez0_abs. + move/subr0_eq: Hn2 => <-. + by rewrite /log ExpK // mulr_natr. + by rewrite floor_ge0 powR_ge0. set M : finType := 'I_k.+1. exists M. split; first by rewrite /= card_ord. split. - have -> : (INR n * r)%R = log (INR k.+1). - rewrite -Hk mulRCA mulRV ?INR_eq0' -?lt0n ?mulR1 //; by case: Hn. - rewrite logK; last exact/ltR0n. - by rewrite Int_part_INR Zabs_nat_Z_of_nat card_ord. + have -> : rate r *+ n = log k.+1%:R. + rewrite -Hk -[LHS]mulr_natr -mulrA mulVr ?mulr1 //. + by case: Hn; rewrite -(ltr_nat R) => /unitf_gt0. + rewrite LogK // card_ord (floor_def (m:=k.+1)) // -{1}natz mulrz_nat lexx. + by rewrite addrC -intS -natz mulrz_nat ltr_nat leqnn. move=> Jtdec. rewrite /CodeErrRate. -rewrite [X in X < _](_ : _ = (1 / INR #|M| * - \sum_(f : encT A M n) Wght.d P f * (\sum_(m in M) e(W, mkCode f (Jtdec f)) m))%R); last first. +rewrite [X in X < _](_ : _ = (1 / #|M|%:R * + \sum_(f : encT A M n) Wght.d P f * (\sum_(m in M) e(W, mkCode f (Jtdec f)) m))); last first. rewrite big_distrr /=. apply eq_bigr => f _. - rewrite -!mulRA mulRC -!mulRA. - do 2 f_equal. - by rewrite mulRC. -rewrite [X in X < _](_ : _ = (\sum_(f : encT A M n) Wght.d P f * (e(W, mkCode f (Jtdec f))) ord0)%R); last first. - transitivity (1 / INR #|M| * - \sum_(f : encT A M n) (\sum_(m in M) Wght.d P f * (e(W, mkCode f (Jtdec f))) m))%R. + by rewrite -!mulrA mulrC mul1r -!mulrA [Wght.d _ _ * _]mulrC. +rewrite [X in X < _](_ : _ = (\sum_(f : encT A M n) Wght.d P f * (e(W, mkCode f (Jtdec f))) ord0)); last first. + transitivity (1 / #|M|%:R * + \sum_(f : encT A M n) (\sum_(m in M) Wght.d P f * (e(W, mkCode f (Jtdec f))) m)). f_equal. apply eq_bigr => i _; by rewrite big_distrr. rewrite exchange_big /=. - transitivity (1 / INR #|M| * \sum_(f : encT A M n) - (\sum_( m_ in M ) Wght.d P f * (e(W, mkCode f (Jtdec f))) ord0))%R. - congr (_ * _)%R. + transitivity (1 / #|M|%:R * \sum_(f : encT A M n) + (\sum_( m_ in M ) Wght.d P f * (e(W, mkCode f (Jtdec f))) ord0)). + congr (_ * _). rewrite [in RHS]exchange_big /=. apply eq_bigr => m' _. apply error_rate_symmetry. - by move: Hepsilon0; rewrite /epsilon0_condition; case => /ltRW. - rewrite exchange_big /= big_const /= iter_addR div1R mulRA mulVR ?mul1R //. - by rewrite INR_eq0' card_ord. + by move: Hepsilon0; rewrite /epsilon0_condition; case => /ltW. + rewrite exchange_big /= big_const /= iter_addr addr0 div1r. + by rewrite -(mulr_natl (\sum__ _)) mulrA mulVr (mul1r,unitf_gt0) // card_ord. set Cal_E := @cal_E M n epsilon0. -apply/RltP. -apply (@leR_ltR_trans +apply (@le_lt_trans _ _ (\sum_(f : encT A M n) Wght.d P f * Pr (W ``(| f ord0)) (~: Cal_E f ord0) + \sum_(i | i != ord0) - \sum_(f : encT A M n) Wght.d P f * Pr (W ``(| f ord0)) (Cal_E f i))%R). + \sum_(f : encT A M n) Wght.d P f * Pr (W ``(| f ord0)) (Cal_E f i))). rewrite exchange_big /= -big_split /=. - apply leR_sumR => /= i _. - rewrite -big_distrr /= -mulRDr. - apply leR_wpmul2l; first exact/RleP/FDist.ge0. - rewrite [X in (X <= _)%coqR](_ : _ = Pr (W ``(| i ord0)) + apply ler_sum => /= i _. + rewrite -big_distrr /= -mulrDr. + apply ler_wpM2l; first by rewrite FDist.ge0. + rewrite [X in (X <= _)](_ : _ = Pr (W ``(| i ord0)) (~: Cal_E i ord0 :|: \bigcup_(i0 : M | i0 != ord0) Cal_E i i0)); last first. congr Pr; apply/setP => /= tb. move: (preimC_Cal_E epsilon0 i tb); by rewrite inE. - apply (@leR_trans (Pr (W ``(| i ord0)) (~: Cal_E i ord0) + - Pr (W ``(| i ord0)) (\bigcup_(i0 | i0 != ord0) (Cal_E i i0)))%R). + apply (@le_trans _ _ (Pr (W ``(| i ord0)) (~: Cal_E i ord0) + + Pr (W ``(| i ord0)) (\bigcup_(i0 | i0 != ord0) (Cal_E i i0)))). exact: le_Pr_setU. - exact/leR_add2l/Pr_bigcup. + by rewrite lerD2l Pr_bigcup. rewrite first_summand //. -set lhs := (\sum_(_ < _ | _) _)%R. -have -> : lhs = (#| M |.-1%:R * Pr ((P `^ n) `x ((`O(P , W)) `^ n)) [set x | prod_rV x \in `JTS P W n epsilon0])%R. +set lhs := (\sum_(_ < _ | _) _). +have -> : lhs = (#| M |.-1%:R * Pr ((P `^ n) `x ((`O(P , W)) `^ n)) [set x | prod_rV x \in `JTS P W n epsilon0])%fdist. rewrite {}/lhs. rewrite [RHS](_ : _ = \sum_(H0 < k.+1 | H0 != ord0) - Pr ((P `^ n) `x ((`O( P , W )) `^ n)) [set x | prod_rV x \in `JTS P W n epsilon0])%R; last first. - rewrite big_const /= iter_addR; congr (_%:R * _)%R. + Pr ((P `^ n) `x ((`O( P , W )) `^ n))%fdist [set x | prod_rV x \in `JTS P W n epsilon0]); last first. + rewrite big_const /= iter_addr addr0 -[in RHS]mulr_natl. + congr (_%:R * _). rewrite card_ord /=. transitivity (#| finset.setT :\ (@ord0 k)|). move: (cardsD1 (@ord0 k) finset.setT) => /=. @@ -753,135 +759,142 @@ have -> : lhs = (#| M |.-1%:R * Pr ((P `^ n) `x ((`O(P , W)) `^ n)) [set x | pro by rewrite -!topredE /= !finset.in_set andbC/= inE. by apply eq_big => //; exact: second_summand. rewrite card_ord /=. -apply (@leR_ltR_trans (epsilon0 + k%:R * - Pr P `^ n `x (`O(P , W)) `^ n [set x | prod_rV x \in `JTS P W n epsilon0])%R). - apply leR_add2r. - rewrite Pr_setC leR_subl_addr addRC -leR_subl_addr; apply/JTS_1 => //. +apply (@le_lt_trans _ _ (epsilon0 + k%:R * + Pr (P `^ n) `x (`O(P , W) `^ n) [set x | prod_rV x \in `JTS P W n epsilon0])%fdist). + rewrite lerD2r. + rewrite Pr_setC lerBlDr addrC -lerBlDr; apply/JTS_1 => //. by case: Hepsilon0. by case: Hn => _ [_ []]. -apply (@leR_ltR_trans (epsilon0 + - #| M |%:R * exp2 (- n%:R * (`I(P, W ) - 3 * epsilon0)))). - apply/leR_add2l/leR_pmul; [exact: leR0n|exact: Pr_ge0| |exact: non_typical_sequences]. - by apply/le_INR/leP; rewrite card_ord. -apply (@ltR_trans (epsilon0 + epsilon0)); last by case: Hepsilon0 => ? [? ?]; lra. -apply ltR_add2l. -have -> : INR #| M | = exp2 (log (INR #| M |)). - rewrite logK // (_ : 0 = INR 0)%R //. - by apply lt_INR; rewrite card_ord; exact/ltP. -rewrite -ExpD. -rewrite (_ : _ + _ = - n%:R * (`I(P, W) - log #| M |%:R / n%:R - 3 * epsilon0))%R; last first. +apply (@le_lt_trans _ _ (epsilon0 + + #| M |%:R * 2 `^ (- n%:R * (`I(P, W ) - 3 * epsilon0)))). + rewrite lerD2l ler_pM //. by rewrite card_ord ler_nat. + exact: non_typical_sequences. +apply (@lt_trans _ _ (epsilon0 + epsilon0)); last by case: Hepsilon0 => ? [? ?]; lra. +rewrite ltrD2l. +have -> : #| M |%:R = 2 `^ (log #| M |%:R) :> R by rewrite LogK // card_ord. +rewrite -powRD; last by rewrite (eqr_nat R 2 0) implybT. +rewrite (_ : _ + _ = - n%:R * (`I(P, W) - log #| M |%:R / n%:R - 3 * epsilon0)); last first. field. - by apply/eqP; rewrite INR_eq0' gtn_eqF //; case: Hn. -rewrite (_ : _ / _ = r)%R; last by rewrite -Hk card_ord. -apply (@ltR_trans (exp2 (- n%:R * epsilon0))). - apply Exp_increasing => //. - rewrite !mulNR ltR_oppr oppRK; apply/ltR_pmul2l. - - apply ltR0n; by case: Hn. - - case: Hepsilon0 => _ [_ Hepsilon0]. - apply (@ltR_pmul2l 4) in Hepsilon0; last lra. - rewrite mulRCA mulRV ?mulR1 in Hepsilon0; last exact/eqP. - clear Hk; lra. -apply (@ltR_leR_trans (exp2 (- (- (log epsilon0) / epsilon0) * epsilon0))). - apply Exp_increasing => //; apply ltR_pmul2r. - - rewrite /epsilon0_condition in Hepsilon0; tauto. - - rewrite ltR_oppr oppRK; by case: Hn => _ [Hn2 _]. - rewrite !mulNR -mulRA mulVR ?mulR1 ?oppRK; last first. - by apply/gtR_eqF; case: Hepsilon0. - rewrite logK; [| by case: Hepsilon0]. - by apply/RleP; rewrite Order.POrderTheory.lexx. + by case: Hn; rewrite -(ltr_nat R) => /lt0r_neq0. +rewrite (_ : _ / _ = rate r); last by rewrite -Hk card_ord. +apply (@lt_trans _ _ (2 `^ (- n%:R * epsilon0))). + rewrite gt1_ltr_powRr ?ltr1n//. + rewrite -mulr_natr -mulNr. + rewrite -2!mulrA ltr_nM2l ?oppr_lt0 //. + rewrite ltr_pM2l; last by case: Hn; rewrite (ltr_nat R 0 n). + case: Hepsilon0 => _ [_ Hepsilon0]. + rewrite -(@ltr_pM2l R 4) in Hepsilon0; last lra. + rewrite mulrCA mulrV ?mulR1 in Hepsilon0; last first. + by rewrite unitfE (eqr_nat R 4 0). + lra. +apply (@lt_le_trans _ _ (2 `^ (- (- (log epsilon0) / epsilon0) * epsilon0))). + rewrite /powR (eqr_nat R 2 0) /=. + rewrite ltr_expR ltr_pM2r; last by apply/ln_gt0; rewrite (ltr_nat R 1 2). + rewrite ltr_pM2r; first last. + - by case: Hepsilon0. + - rewrite -mulr_natr ltrN2 mul1r. + by case: Hn => _ []. +rewrite !mulNr opprK -mulrA mulVr; last first. + by case: Hepsilon0 => /lt0r_neq0; rewrite unitfE. +by rewrite mulr1 LogK ?lexx //; case: Hepsilon0. Qed. End random_coding_good_code_existence. +(* TODO: move to realType_logb *) +Lemma exists_frac_part (P : nat -> Prop) : (exists n, P n) -> + forall num den, (0 < num)%nat -> (0 < den)%nat -> + (forall n m, (n <= m)%nat -> P n -> P m) -> + exists n, P n /\ + frac_part (2 `^ (n%:R * (log num%:R / den%:R))) = 0. +Proof. +case=> n Pn num den Hden HP. +exists (n * den)%nat. +split. + apply H with n => //. + by rewrite -{1}(muln1 n) leq_mul2l HP orbC. +rewrite natrM -mulrA (mulrCA den%:R) mulrV // ?mulr1; last first. + by rewrite unitfE lt0r_neq0 // (ltr_nat R 0). +rewrite /frac_part mulrC powRrM. +rewrite (LogK (n:=2)) // ?ltr0n // powR_mulrn ?ler0n // -natrX. +by rewrite floorK ?subrr // intr_nat. +Qed. + Section channel_coding_theorem. Variables (A B : finType) (W : `Ch(A, B)). Hypothesis set_of_I_nonempty : classical_sets.nonempty (fun y => exists P, `I(P, W) = y). -Local Open Scope zarith_ext_scope. - -Theorem channel_coding (r : CodeRateType) : r < capacity W -> +Theorem channel_coding (r : CodeRateType) : rate r < capacity W -> forall epsilon, 0 < epsilon -> exists n M (c : code A B M n), CodeRate c = r /\ echa(W, c) < epsilon. Proof. move=> r_I epsilon Hepsilon. -have [P HP] : exists P : {fdist A}, r < `I(P, W). - apply NNPP => abs. +have [P HP] : exists P : {fdist A}, rate r < `I(P, W). + apply/not_existsP => abs. have {}abs : forall P : {fdist A}, `I(P, W) <= r. - move/not_ex_all_not in abs. - move=> P; exact/Rnot_lt_le/abs. + by move=> P; rewrite leNgt; apply/negP. have ? : capacity W <= r. - apply/RleP. have : has_sup [set `I(P, W) | P in [set: {fdist A}]]. case: set_of_I_nonempty => [x [P H1]]; split; first by exists x, P. - by exists (rate r) => _ [Q _ <-]; exact/Rstruct.RleP/abs. + by exists (rate r) => _ [Q _ <-]. move=> /(@Rsup_isLub 0 [set `I(P, W) | P in [set: {fdist A}]])[_]. apply. - by move=> x [P _ <-{x}]; exact/RleP/abs. + by move=> x [P _ <-{x}]. lra. have [epsilon0 Hepsilon0] : exists epsilon0, - 0 < epsilon0 /\ epsilon0 < epsilon / 2 /\ epsilon0 < (`I(P, W) - r) / 4. - exists ((Rmin (epsilon/2) ((`I(P, W) - r) / 4))/2). - have H0 : 0 < Rmin (epsilon / 2) ((`I(P, W) - r) / 4). - apply Rmin_pos; apply mulR_gt0 => //; lra. - split; first by apply mulR_gt0 => //; lra. - split; [exact/(ltR_leR_trans (Rlt_eps2_eps _ H0))/geR_minl | - exact/(ltR_leR_trans (Rlt_eps2_eps _ H0))/geR_minr ]. + 0 < epsilon0 /\ epsilon0 < epsilon / 2 /\ epsilon0 < (`I(P, W) - rate r) / 4. + exists ((Order.min (epsilon/2) ((`I(P, W) - rate r) / 4))/2). + have H0 : 0 < Order.min (epsilon / 2) ((`I(P, W) - rate r) / 4). + rewrite lt_min; lra. + split; first by apply mulr_gt0 => //; lra. + split; apply/(@lt_le_trans _ _ (Num.min (epsilon / 2) ((`I(P, W) - rate r) / 4))); try by rewrite ltr_pdivrMr // mulr_natr mulr2n ltr_pwDr. + by rewrite ge_min lexx. + by rewrite ge_min lexx orbT. have [n Hn] : exists n, n_condition W P r epsilon0 n. destruct r as [r [num [den [Hnum [Hden Hr]]]]]. have Hn : exists n, (0 < n)%nat /\ - - log epsilon0 / epsilon0 < INR n /\ - (maxn '| up (aep_bound P (epsilon0 / 3)) | - (maxn '| up (aep_bound (`O(P , W)) (epsilon0 / 3)) | - '| up (aep_bound ((P `X W)) (epsilon0 / 3)) |) <= n)%nat. + - log epsilon0 / epsilon0 < n%:R /\ + (maxn (Nup (aep_bound P (epsilon0 / 3))) + (maxn (Nup (aep_bound (`O(P , W)) (epsilon0 / 3))) + (Nup (aep_bound ((P `X W)) (epsilon0 / 3)))) <= n)%nat. set supermax := maxn 1 - (maxn '| up (- log epsilon0 / epsilon0) | - (maxn '| up (aep_bound P (epsilon0 / 3)) | - (maxn '| up (aep_bound (`O(P , W)) (epsilon0 / 3)) | - '| up (aep_bound ((P `X W)) (epsilon0 / 3)) |))). + (maxn (Nup (- log epsilon0 / epsilon0)) + (maxn (Nup (aep_bound P (epsilon0 / 3))) + (maxn (Nup (aep_bound (`O(P , W)) (epsilon0 / 3))) + (Nup (aep_bound ((P `X W)) (epsilon0 / 3)))))). exists supermax. split; first by rewrite leq_max. split. - apply (@ltR_leR_trans (IZR (up (- log epsilon0 / epsilon0)))). - rewrite up_Int_part. - case: (base_Int_part (- log epsilon0 / epsilon0)) => H1 H2. - rewrite plus_IZR //. - move: H2. - set eps := - log epsilon0 / epsilon0. - move=> ?; lra. - apply (@leR_trans (INR '| up (- log epsilon0 / epsilon0) |)). - case: (Z_lt_le_dec (up (- log epsilon0 / epsilon0)) 0) => H1. - by apply (@leR_trans 0); [exact/IZR_le/ltZW | exact: leR0n]. - rewrite INR_Zabs_nat //. - by apply/RleP; rewrite Order.POrderTheory.lexx. - apply le_INR. - rewrite /supermax maxnA. - apply/leP. - by rewrite leq_max leq_max leqnn orbT. + apply (@lt_le_trans _ R (Num.floor (- log epsilon0 / epsilon0) + 1)%:~R). + exact: lt_succ_floor. + apply (@le_trans _ R (Nup (- log epsilon0 / epsilon0))%:R). + by rewrite /Nup -addn1 -mulrz_nat natz PoszD ler_int lerD // lez_abs. + by rewrite ler_nat /supermax 2!leq_max leqnn orbT. by rewrite [X in (_ <= X)%nat]maxnA leq_maxr. + rewrite /n_condition. lapply (exists_frac_part Hn Hnum Hden); last move=> n1 n2 n1_n2 Pn1. case=> n [[Hn1 [Hn3 Hn4]] Hn2]. exists n => /=. rewrite /n_condition. split => //; split => //; split => //. - by rewrite -Hr in Hn2. + by rewrite -Hr mulr_natl in Hn2. split. by apply/(@leq_trans n1) => //; tauto. split. - by apply (@ltR_leR_trans (INR n1)); [tauto | exact/le_INR/leP]. + by apply: (@lt_le_trans _ _ n1%:R); [tauto | rewrite ler_nat]. by apply leq_trans with n1 => //; tauto. -have He : (0 <= epsilon)%mcR. - apply/RleP. - by apply/ltRW. +have He : (0 <= epsilon) by apply ltW. case: (random_coding_good_code He Hepsilon0 Hn) => M [HM [M_k H]]. -move/RltP in H. -case: (good_code_sufficient_condition HM H) => f Hf. +case: (good_code_sufficient_condition H) => f Hf. exists n, M, (mkCode f (jtdec P W epsilon0 f)); split => //. -rewrite /CodeRate M_k INR_Zabs_nat; last exact/Int_part_ge0. -suff -> : IZR (Int_part (exp2 (INR n * r))) = exp2 (INR n * r). - rewrite exp2K /Rdiv -mulRA mulRCA mulRV ?INR_eq0' -?lt0n ?mulR1 //; by case: Hn. -by apply frac_Int_part; case: Hn => _ [_ []]. +rewrite /CodeRate M_k -mulrz_nat natz gez0_abs; last first. + by rewrite floor_ge0 powR_ge0. +case: Hn => Hn [_] []. +rewrite /frac_part => /subr0_eq <- _. +rewrite /log ExpK // -(mulr_natr (rate r)) mulrK //. +by apply/unitf_gt0; rewrite ltr0n. Qed. End channel_coding_theorem. diff --git a/information_theory/conditional_divergence.v b/information_theory/conditional_divergence.v index 0deb15eb..0001c5a8 100644 --- a/information_theory/conditional_divergence.v +++ b/information_theory/conditional_divergence.v @@ -1,11 +1,10 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum finset matrix. -Require Import Reals. -From mathcomp Require Import Rstruct reals. -Require Import ssrR realType_ext Reals_ext ssr_ext ssralg_ext logb ln_facts. -Require Import num_occ fdist entropy channel divergence types jtypes. -Require Import proba jfdist_cond. +From mathcomp Require Import all_ssreflect ssralg ssrnum matrix ring lra. +From mathcomp Require Import Rstruct reals exp. +Require Import ssr_ext bigop_ext ssralg_ext realType_ext realType_ln. +Require Import num_occ fdist proba entropy channel divergence types jtypes. +Require Import jfdist_cond. (******************************************************************************) (* Conditional divergence *) @@ -20,15 +19,17 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. Local Open Scope reals_ext_scope. Local Open Scope fdist_scope. +Local Open Scope ring_scope. Local Open Scope entropy_scope. Local Open Scope channel_scope. Local Open Scope divergence_scope. Local Open Scope num_occ_scope. Local Open Scope types_scope. +Import Order.TTheory GRing.Theory Num.Theory. + Section conditional_dominance. Variables (A B : finType) (V W : `Ch(A, B)) (P : {fdist A}). @@ -39,13 +40,14 @@ Proof. split; [move/dominatesP => H | move=> H; apply/dominatesP]. - move=> a p_not_0; apply/dominatesP => b; move: (H (a, b)). rewrite fdist_prodE /= => H0 H1. - move: H0; rewrite H1 -RmultE mulR0 => /(_ erefl)/eqP. - by rewrite fdist_prodE mulR_eq0' /= (negbTE p_not_0) orFb => /eqP. + move: H0; rewrite H1 mulr0 => /(_ erefl)/eqP. + rewrite fdist_prodE/= [X in _ == X -> _](_ : _ = 0%:R)//. + by rewrite mulf_eq0 (negbTE p_not_0) orFb => /eqP. - case=> a p_not_0 b; move: {H}(H a) => H. rewrite fdist_prodE /=. - have [->|H1] := eqVneq (P a) 0; first by rewrite -RmultE mul0R. - move: {H}(H H1) => /dominatesP ->; first by rewrite -RmultE mulR0. - move/eqP : b; by rewrite fdist_prodE mulR_eq0' /= (negbTE H1) orFb => /eqP. + have [->|H1] := eqVneq (P a) 0; first by rewrite mul0r. + move: {H}(H H1) => /dominatesP ->; first by rewrite mulr0. + move/eqP : b; by rewrite fdist_prodE mulf_eq0 /= (negbTE H1) orFb => /eqP. Qed. End conditional_dominance. @@ -57,17 +59,16 @@ Notation "P '|-' V '< V a `< (P `X V) `<< (P `X W). +Lemma dominates_prodl : P |- V << W -> (P `X V) `<< (P `X W). Proof. move=> V_dom_by_W /=; apply/dominatesP => ab Hab. -case/RleP/leR_eqVlt : (FDist.ge0 P ab.1) => [/esym|] Hab1. -- by rewrite fdist_prodE Hab1 -RmultE mul0R. +have := FDist.ge0 P ab.1; rewrite le_eqVlt => /predU1P[/esym|] Hab1. +- by rewrite fdist_prodE Hab1 mul0r. - rewrite fdist_prodE in Hab. - rewrite fdist_prodE (dominatesE (V_dom_by_W _ _)) -?RmultE ?mulR0 //. - + exact/gtR_eqF. - + move: Hab; rewrite mulR_eq0 => -[|//]. - by move: (gtR_eqF _ _ Hab1) => /eqP. + rewrite fdist_prodE (dominatesE (V_dom_by_W _ _)) ?mulr0 //. + + by rewrite gt_eqF//. + + move/eqP: Hab; rewrite mulf_eq0 => -/orP[|/eqP//]. + by move: Hab1 => /[swap] /eqP ->; rewrite ltxx. Qed. End joint_dom. @@ -88,25 +89,25 @@ Lemma cdiv_is_div_joint_dist : D(V || W | P) = D((P `X V) || (P `X W)). Proof. rewrite (_ : D(V || W | P) = \sum_(a in A) (\sum_(b in B) V a b * (log (V a b / W a b)) * P a)); last first. - apply eq_bigr => a _. - by rewrite -(big_morph _ (morph_mulRDl _) (mul0R _)) mulRC. + apply eq_bigr => a _; rewrite big_distrr//=. + by apply: eq_bigr => b _; rewrite mulrC. rewrite pair_bigA big_mkcond /=. apply eq_bigr => -[a b] /= _. -rewrite fdist_prodE /= -RmultE (mulRC (P a)) [in RHS]mulRAC. -case/boolP : (P a == 0) => [/eqP -> | Pa0]; first by rewrite !mulR0. -congr (_ * _). -case/boolP : (V a b == 0) => [/eqP -> | Vab0]; first by rewrite !mul0R. -congr (_ * _). +rewrite fdist_prodE /= (mulrC (P a)) [in RHS]mulrAC. +have [->|Pa0] := eqVneq (P a) 0; first by rewrite !mulr0. +congr *%R. +have [->|Vab0] := eqVneq (V a b) 0; first by rewrite !mul0r. +congr *%R. have Wab0 : W a b != 0 := dominatesEN (V_dom_by_W Pa0) Vab0. -rewrite fdist_prodE /= {2}/Rdiv -RmultE (mulRC _ (W a b)) (invRM (W a b)) //. -by rewrite -mulRA (mulRCA (P a)) mulRV // mulR1. +rewrite fdist_prodE /=. +by rewrite -(mulrA _ (P a)) invfM (mulrA (P a)) divff// mul1r. Qed. Lemma cdiv_ge0 : 0 <= D(V || W | P). -Proof. rewrite cdiv_is_div_joint_dist //; exact/div_ge0/joint_dominates. Qed. +Proof. by rewrite cdiv_is_div_joint_dist //; exact/div_ge0/dominates_prodl. Qed. -Lemma cdiv0P : D(V || W | P) = 0 <-> (P `X V) = (P `X W). -Proof. rewrite cdiv_is_div_joint_dist; exact/div0P/joint_dominates. Qed. +Lemma cdiv0P : D(V || W | P) = 0 <-> P `X V = P `X W. +Proof. by rewrite cdiv_is_div_joint_dist; exact/div0P/dominates_prodl. Qed. End conditional_divergence_prop. @@ -125,26 +126,25 @@ under eq_bigr do rewrite big_distrr /=. rewrite pair_big /=; apply eq_bigr => -[a b] _ /=. rewrite (_ : (R `X P) (a, b) = (R `X P) (a, b)); last by rewrite fdist_prodE. rewrite (_ : (R `X Q) (a, b) = (R `X Q) (a, b)); last by rewrite fdist_prodE. -rewrite mulRA. +rewrite mulrA. rewrite {1}/jcPr. rewrite fdistX2 fdist_prod1 Pr_set1. have [H|H] := eqVneq (R a) 0. - by rewrite H mul0R fdist_prodE H -RmultE !mul0R/=. + by rewrite H mulrA fdist_prodE H !mul0r/=. congr (_ * log _). - by rewrite setX1 Pr_set1 fdistXE fdist_prodE /=; field; exact/eqP. + by rewrite setX1 Pr_set1 fdistXE fdist_prodE /=; field. rewrite /jcPr !setX1 !Pr_set1 !fdistXE !fdistX2. have [H'|H'] := eqVneq ((R `X Q) (a, b)) 0. have : (R `X P) (a, b) = 0 by move/dominatesP : PQ => ->. - rewrite fdist_prodE /= mulR_eq0 => -[| -> ]. + rewrite fdist_prodE /= => /eqP; rewrite mulf_eq0 => -/predU1P[|/eqP ->]. by move/eqP : H; tauto. - rewrite -RmultE. - by rewrite !(mulR0,mul0R,div0R). + by rewrite !(mulr0,mul0r). rewrite 2!fdist_prod1 /=. set x := R _. set y := (R `X P _). set z := (R `X Q _). field. -split; exact/eqP. +by rewrite H'. Qed. End conditional_divergence_vs_conditional_relative_entropy. @@ -160,14 +160,14 @@ Variable y : 'rV[B]_n. Local Open Scope vec_ext_scope. Lemma dmc_cdiv_cond_entropy_aux : W ``(y | x) = - \prod_(a : A) \prod_(b : B) W a b ^ N(a, b | tuple_of_row x, tuple_of_row y). + \prod_(a : A) \prod_(b : B) W a b ^+ N(a, b | tuple_of_row x, tuple_of_row y). Proof. transitivity (\prod_(a : A) \prod_(b : B) \prod_(i < n) if (a == x ``_ i) && (b == y ``_ i) then W `(y ``_ i | x ``_ i) else 1). rewrite pair_big exchange_big /= DMCE. apply eq_bigr => i _. rewrite (bigD1 (x ``_ i, y ``_ i)) //= 2!eqxx andbT. - rewrite big1; first by rewrite mulR1. + rewrite big1; first by rewrite mulr1. case=> a b /=. rewrite xpair_eqE negb_and. case/orP. @@ -175,13 +175,13 @@ transitivity (\prod_(a : A) \prod_(b : B) \prod_(i < n) - move/negbTE => ->; by rewrite andbF. apply eq_bigr => a _; apply eq_bigr => b _. rewrite num_co_occ_alt -sum1_card. -rewrite (@big_morph _ _ (fun x => W a b ^ x) 1 Rmult O addn) //; last first. - move=> * /=; by rewrite -pow_add. +rewrite (@big_morph _ _ (fun x => W a b ^+ x) 1 *%R O addn) //; last first. + by move=> * /=; rewrite exprD. rewrite [in RHS]big_mkcond. apply eq_bigr => i _. case: ifP. case/andP => /eqP Ha /eqP Hb. - by rewrite inE 2!tnth_mktuple -Ha -Hb 2!eqxx /= mulR1. + by rewrite inE 2!tnth_mktuple -Ha -Hb 2!eqxx /= expr1. move/negbT. rewrite negb_and inE 2!tnth_mktuple. case/orP => /negbTE. @@ -201,63 +201,61 @@ Hypothesis Hn : n != O. the conditional divergence and the condition entropy *) Lemma dmc_cdiv_cond_entropy : - W ``(y | x) = exp2 (- INR n * (D(V || W | P) + `H(V | P))). + W ``(y | x) = 2 `^ (- n%:R * (D(V || W | P) + `H(V | P))). Proof. rewrite dmc_cdiv_cond_entropy_aux cond_entropy_chanE2. rewrite /cdiv /entropy -big_split /=. -rewrite (big_morph _ (morph_mulRDr _) (mulR0 _)). -rewrite (big_morph _ morph_exp2_plus exp2_0). +rewrite big_distrr/= powR2sum. apply eq_bigr => a _. -rewrite big_morph_oppR. -rewrite /div /= -mulRDr mulRA -big_split /=. -rewrite (big_morph _ (morph_mulRDr _) (mulR0 _)). -rewrite (big_morph _ morph_exp2_plus exp2_0). +rewrite big_morph_oppr. +rewrite /div /= -mulrDr mulrA -big_split /=. +rewrite big_distrr/= powR2sum. apply eq_bigr => b _. -case/boolP : (type.d P a == 0) => [/eqP|] Pa0. +have [Pa0|Pa0] := eqVneq (type.d P a) 0. move: Hy; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP => ->. move: (HV); rewrite in_set => /cond_type_equiv/(_ _ Hx a). move: Hx; rewrite in_set => /forallP/(_ a)/eqP; rewrite {}Pa0 => HPa sumB. - move: HPa; rewrite -sumB => /esym; rewrite mulR_eq0 => -[/eqP|/eqP]; last first. - by move/invR_eq0'; rewrite INR_eq0' (negbTE Hn). - rewrite INR_eq0' sum_nat_eq0 => /forall_inP/(_ b erefl)/eqP => H; apply/eqP. - by rewrite H pow_O !(mulR0,mul0R) exp2_0. -case/boolP : (W a b == 0) => [/eqP |] Wab0. + move: HPa; rewrite -sumB => /esym/eqP; rewrite mulf_eq0 => -/orP[/eqP|/eqP]; last first. + move=> /eqP. + by rewrite invr_eq0 (_ : 0 = 0%:R)// eqr_nat (negbTE Hn). + move=> /eqP; rewrite (_ : 0 = 0%:R)// eqr_nat. + rewrite sum_nat_eq0 => /forall_inP/(_ b erefl)/eqP => H; apply/eqP. + by rewrite H expr0 !(mulr0,mul0r) powRr0. +have [Wab0|Wab0] := eqVneq (W a b) 0. move: (dominatesE (W0_V0 Pa0) Wab0) => nullV. suff -> : N(a, b| tuple_of_row x, tuple_of_row y) = O. - by rewrite nullV 2!mul0R oppR0 addR0 mulR0 exp2_0. + by rewrite nullV 2!mul0r oppr0 addr0 mulr0 powRr0. move: Hy; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP => ->. by rewrite jtype_0_jtypef. -rewrite -{1}(@logK (W a b)); last first. - apply/RltP. +rewrite -{1}(@LogK _ 2 (W a b))//; last first. by rewrite -fdist_gt0. -case/boolP : (V a b == 0) => [/eqP|] Vab0. +have [Vab0|Vab0] := eqVneq (V a b) 0. suff -> : N( a, b | [seq x ``_ i | i <- enum 'I_n], [seq y ``_ i | i <- enum 'I_n]) = O. - by rewrite pow_O Vab0 !(mulR0,mul0R,addR0,add0R,oppR0,exp2_0). + by rewrite expr0 Vab0 !(mulr0,mul0r,addr0,add0r,oppr0,powRr0). move: Hy; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP => ->. by rewrite jtype_0_jtypef. -rewrite -exp2_pow; congr exp2. -rewrite -mulRN -mulRDr mulRA addR_opp -logDiv; last 2 first. - apply/divR_gt0. - apply/RltP. - by rewrite -fdist_gt0//. - apply/RltP. - by rewrite -fdist_gt0//. - apply/RltP. - by rewrite -fdist_gt0//. -rewrite /Rdiv (mulRAC _ (/ _)) mulRV // mul1R logV -?fdist_gt0 //; last first. - apply/RltP. - by rewrite -fdist_gt0//. -rewrite mulRN 3!mulNR oppRK; congr (_ * log _). +rewrite -powR_mulrn ?powR_ge0// -powRrM//. +congr (_ `^ _). +rewrite -mulrN -mulrDr mulrA. +rewrite logM; last 2 first. + by rewrite -fdist_gt0. + by rewrite invr_gt0 -fdist_gt0. +rewrite logV; last by rewrite -fdist_gt0. +rewrite addrAC subrr add0r. +rewrite mulrN 3!mulNr opprK. +rewrite mulrC. +congr (_ * log _). move: Hy; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP => ->. move: (HV); rewrite in_set => /cond_type_equiv => /(_ _ Hx a) sumB. move: Hx; rewrite in_set => /forallP/(_ a)/eqP => HPa. rewrite (JType.c_f V) /=. case: ifPn => [/eqP|] HP. -- rewrite HPa -sumB HP div0R mulR0 mul0R. +- rewrite HPa -sumB HP mul0r mulr0 mul0r. move/eqP : HP; rewrite sum_nat_eq0 => /forallP/(_ b). by rewrite implyTb => /eqP ->. -- rewrite HPa -sumB (mulRCA (INR n)) mulRV ?INR_eq0' // mulR1. - by rewrite mulRCA mulRV ?mulR1 // INR_eq0'. +- rewrite HPa -sumB (mulrCA (n%:R)) mulfV ?mulr1; last first. + by rewrite pnatr_eq0. + by rewrite mulrCA mulfV ?mulr1 // pnatr_eq0. Qed. End dmc_cdiv_cond_entropy. @@ -270,17 +268,20 @@ Variable W : `Ch*(A, B). Definition exp_cdiv := if (type.d P) |- V < ->. apply/forallP => a; apply/implyP => Pa0. -apply/forall_inP => b /eqP Wab; by rewrite (dominatesE (H _ Pa0)). +by apply/forall_inP => b /eqP Wab; rewrite (dominatesE (H _ Pa0)). Qed. +Lemma exp_cdiv_ge0 : 0 <= exp_cdiv. +Proof. by rewrite /exp_cdiv; case: ifPn => // _; rewrite powR_ge0. Qed. + End cdiv_specialized. Section dmc_cdiv_cond_entropy_spec. @@ -297,28 +298,27 @@ Hypothesis Vctyp : V \in \nu^{B}(P). Hypothesis Htb : tuple_of_row y \in V.-shell (tuple_of_row x). Lemma dmc_exp_cdiv_cond_entropy : - W ``(y | x) = exp_cdiv P V W * exp2 (- INR n * `H(V | P)). + W ``(y | x) = exp_cdiv P V W * 2 `^ (- n%:R * `H(V | P)). Proof. rewrite /exp_cdiv. case : ifP => Hcase. -- rewrite -ExpD -mulRDr. +- rewrite -powRD; last by rewrite pnatr_eq0 implybT. + rewrite -mulrDr. apply dmc_cdiv_cond_entropy => //. (* TODO: lemma? *) move=> a Pa; apply/dominatesP => b /eqP Wab. by move: Hcase => /forallP/(_ a)/implyP/(_ Pa)/forallP/(_ b)/implyP/(_ Wab)/eqP. -- rewrite mul0R. +- rewrite mul0r. move: Hcase => /negbT; rewrite negb_forall; case/existsP => a. rewrite negb_imply. case/andP => Pa. rewrite negb_forall_in ; move/existsP ; case => b. case/andP=> Wab H. rewrite dmc_cdiv_cond_entropy_aux. - rewrite pair_big /= (bigD1 (a, b)) //=. - rewrite mulR_eq0; left. + rewrite pair_big /= (bigD1 (a, b)) //=; apply/eqP. + rewrite mulf_eq0; apply/orP; left. move/eqP in Wab; rewrite Wab. - apply pow_i. - apply/ltP. - rewrite lt0n. + rewrite expr0n. move: Htb ; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP ->. move: H => /=. rewrite (JType.c_f V) /=. @@ -327,10 +327,11 @@ case : ifP => Hcase. move/cond_type_equiv => /(_ _ Hta a) ->. move: Hta; rewrite in_set => /forallP/(_ a)/eqP => HPa. case: ifPn => Nax; last first. - by apply: contra => /eqP ->; rewrite div0R. + rewrite mulf_eq0 negb_or invr_eq0. + by rewrite !pnatr_eq0 Nax andbT => /negbTE ->. exfalso. move/eqP : Pa; apply. - by rewrite HPa (eqP Nax) div0R. + by rewrite HPa (eqP Nax) mul0r. Qed. End dmc_cdiv_cond_entropy_spec. diff --git a/information_theory/entropy.v b/information_theory/entropy.v index 78c6bfab..0e161e25 100644 --- a/information_theory/entropy.v +++ b/information_theory/entropy.v @@ -1,11 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect all_algebra fingroup perm. -Require Import Reals. -From mathcomp Require Import Rstruct reals. -Require Import ssrR Reals_ext realType_ext ssr_ext ssralg_ext bigop_ext. -Require Import logb ln_facts fdist jfdist_cond proba binary_entropy_function. -Require Import divergence. +From mathcomp Require Import reals exp. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln. +Require Import fdist jfdist_cond proba binary_entropy_function divergence. (******************************************************************************) (* Chapter 2 of Elements of Information Theory *) @@ -54,27 +52,28 @@ Declare Scope entropy_scope. Declare Scope chap2_scope. Delimit Scope chap2_scope with chap2. -Local Open Scope R_scope. Local Open Scope fdist_scope. Local Open Scope proba_scope. Local Open Scope vec_ext_scope. +Local Open Scope ring_scope. Import Order.POrderTheory GRing.Theory Num.Theory. Section entropy_definition. -Variables (A : finType) (P : {fdist A}). +Variables (R : realType) (A : finType) (P : R.-fdist A). -Definition entropy := - \sum_(a in A) P a * log (P a). +Definition entropy : R^o := - \sum_(a in A) P a * log (P a). Local Notation "'`H'" := (entropy). Lemma entropy_ge0 : 0 <= `H. Proof. -rewrite /entropy big_morph_oppR; apply/RleP/sumr_ge0 => i _; apply/RleP. -have [->|Hi] := eqVneq (P i) 0; first by rewrite mul0R oppR0. - (* NB: this step in a standard textbook would be handled as a consequence of lim x->0 x log x = 0 *) -rewrite mulRC -mulNR; apply mulR_ge0 => //; apply: oppR_ge0. -rewrite -log1; apply: Log_increasing_le => //. -by apply/RltP; rewrite lt0r Hi/=. +rewrite /entropy big_morph_oppr; apply/sumr_ge0 => i _. +have [->|Hi] := eqVneq (P i) 0; first by rewrite mul0r oppr0. +(* NB: this step in a standard textbook would be handled as a consequence of + lim x->0 x log x = 0 *) +rewrite mulrC -mulNr mulr_ge0// lerNr oppr0. +rewrite -log1 ler_log// ?posrE//. +by rewrite lt0r Hi/=. Qed. End entropy_definition. @@ -85,63 +84,61 @@ Local Open Scope entropy_scope. Section entropy_theory. Local Open Scope fdist_scope. Local Open Scope proba_scope. -Context (A : finType). +Context (R : realType) (A : finType). -Lemma entropy_Ex (P : {fdist A}) : `H P = `E (`-- (`log P)). +Lemma entropy_Ex (P : R.-fdist A) : `H P = `E (`-- (`log P)). Proof. -rewrite /entropy /log_RV /= big_morph_oppR. -by apply eq_bigr => a _; rewrite mulRC -mulNR. +rewrite /entropy /log_RV /= big_morph_oppr. +by apply eq_bigr => a _; rewrite mulrC -mulNr. Qed. -Lemma xlnx_entropy (P : {fdist A}) : `H P = / ln 2 * - \sum_(a : A) xlnx (P a). +Lemma xlnx_entropy (P : R.-fdist A) : + `H P = (ln 2)^-1 * - \sum_(a : A) xlnx (P a). Proof. -rewrite /entropy mulRN; congr (- _); rewrite big_distrr/=. -apply: eq_bigr => a _; rewrite /log /Rdiv mulRA mulRC; congr (_ * _). -rewrite /xlnx; case : ifP => // /RltP Hcase. -have -> : P a = 0 by case (Rle_lt_or_eq_dec 0 (P a)). -by rewrite mul0R. +rewrite /entropy mulrN; congr (- _); rewrite big_distrr/=. +apply: eq_bigr => a _; rewrite /xlnx /log /Log/=. +have := FDist.ge0 P a; rewrite le_eqVlt => /predU1P[<-|Pa0]. + by rewrite !mul0r ltxx mulr0. +by rewrite Pa0 mulrA mulrC. Qed. Lemma entropy_uniform n (An1 : #|A| = n.+1) : - `H (fdist_uniform An1) = log (INR #|A|). + `H (fdist_uniform An1) = log #|A|%:R :> R. Proof. rewrite /entropy. under eq_bigr do rewrite fdist_uniformE. -rewrite big_const iter_addR mulRA RmultE -RinvE. -rewrite INRE mulRV; last by rewrite An1 -INRE INR_eq0'. -rewrite -RmultE mul1R logV ?oppRK//; rewrite An1. -by rewrite -INRE; apply/ltR0n. +rewrite big_const iter_addr addr0 logV; last by rewrite An1. +rewrite -mulNrn mulrN opprK -mulrnAr -(mulr_natr (log _) #|A|) mulrCA. +by rewrite mulVf ?mulr1// An1 pnatr_eq0. Qed. -Lemma entropy_H2 (card_A : #|A| = 2%nat) (p : {prob R}) : +Lemma entropy_H2 (card_A : #|A| = 2%nat) (p : prob R) : H2 (Prob.p p) = entropy (fdist_binary card_A p (Set2.a card_A)). Proof. rewrite /H2 /entropy Set2sumE /= fdist_binaryxx !fdist_binaryE. -by rewrite eq_sym (negbTE (Set2.a_neq_b _)) oppRD addRC. +by rewrite eq_sym (negbTE (Set2.a_neq_b _)) opprD addrC. Qed. -Lemma entropy_max (P : {fdist A}) : `H P <= log #|A|%:R. +Lemma entropy_max (P : R.-fdist A) : `H P <= log #|A|%:R. Proof. have [n An1] : exists n, #|A| = n.+1. by exists #|A|.-1; rewrite prednK //; exact: (fdist_card_neq0 P). have /div_ge0 H := dom_by_uniform P An1. -rewrite -subR_ge0; apply/(leR_trans H)/Req_le. +rewrite -subr_ge0; apply/(le_trans H). +rewrite le_eqVlt; apply/orP; left; apply/eqP. transitivity (\sum_(a|a \in A) P a * log (P a) + \sum_(a|a \in A) P a * - log (fdist_uniform An1 a)). - rewrite -big_split /=; apply eq_bigr => a _; rewrite -mulRDr. - case/boolP : (P a == 0) => [/eqP ->|H0]; first by rewrite !mul0R. - congr (_ * _); rewrite logDiv ?addR_opp //. - by apply/RltP; rewrite -fdist_gt0. - rewrite fdist_uniformE -RinvE. - apply/invR_gt0; rewrite An1 -INRE. - exact/ltR0n. + rewrite -big_split /=; apply eq_bigr => a _; rewrite -mulrDr. + have [->|Pa0] := eqVneq (P a) 0; first by rewrite !mul0r. + congr (_ * _); rewrite logDiv//. + by rewrite -fdist_gt0. + by rewrite fdist_uniformE invr_gt0// An1 ltr0n. under [in X in _ + X]eq_bigr do rewrite fdist_uniformE. -rewrite -[in X in _ + X = _]big_distrl /= FDist.f1 mul1R. -rewrite addRC /entropy /log -RinvE. -by rewrite LogV ?oppRK ?subR_opp // An1 ?INRE// -INRE; exact/ltR0n. +rewrite -[in X in _ + X = _]big_distrl /= FDist.f1 mul1r. +by rewrite addrC /entropy logV ?opprK// An1 ltr0n. Qed. -Lemma entropy_fdist_rV_of_prod n (P : {fdist A * 'rV[A]_n}) : +Lemma entropy_fdist_rV_of_prod n (P : R.-fdist (A * 'rV[A]_n)) : `H (fdist_rV_of_prod P) = `H P. Proof. rewrite /entropy /=; congr (- _). @@ -150,7 +147,7 @@ apply eq_bigr => -[a b] _ /=. by rewrite fdist_rV_of_prodE /= row_mx_row_ord0 rbehead_row_mx. Qed. -Lemma entropy_fdist_prod_of_rV n (P : {fdist 'rV[A]_n.+1}) : +Lemma entropy_fdist_prod_of_rV n (P : R.-fdist 'rV[A]_n.+1) : `H (fdist_prod_of_rV P) = `H P. Proof. rewrite /entropy /=; congr (- _). @@ -158,7 +155,7 @@ rewrite -(big_rV_cons_behead _ xpredT xpredT) /= pair_bigA /=. apply eq_bigr => -[a b] _ /=; by rewrite fdist_prod_of_rVE /=. Qed. -Lemma entropy_fdist_perm n (P : {fdist 'rV[A]_n}) (s : 'S_n) : +Lemma entropy_fdist_perm n (P : R.-fdist 'rV[A]_n) (s : 'S_n) : `H (fdist_perm P s) = `H P. Proof. rewrite /entropy; congr (- _) => /=; apply/esym. @@ -170,7 +167,7 @@ Qed. End entropy_theory. Section joint_entropy. -Variables (A B : finType) (P : {fdist A * B}). +Variables (R : realType) (A B : finType) (P : R.-fdist (A * B)). (* eqn 2.8 *) Definition joint_entropy := `H P. @@ -189,7 +186,7 @@ Qed. End joint_entropy. -Lemma entropy_rV (A : finType) n (P : {fdist 'rV[A]_n.+1}) : +Lemma entropy_rV (R : realType) (A : finType) n (P : R.-fdist 'rV[A]_n.+1) : `H P = joint_entropy (fdist_belast_last_of_rV P). Proof. rewrite /joint_entropy /entropy; congr (- _) => /=. @@ -199,7 +196,8 @@ by rewrite fdist_belast_last_of_rVE. Qed. Section joint_entropy_RV_def. -Variables (U A B : finType) (P : {fdist U}) (X : {RV P -> A}) (Y : {RV P -> B}). +Variable R : realType. +Variables (U A B : finType) (P : R.-fdist U) (X : {RV P -> A}) (Y : {RV P -> B}). Definition joint_entropy_RV := joint_entropy `p_[% X, Y]. End joint_entropy_RV_def. Notation "'`H(' X ',' Y ')'" := (joint_entropy_RV X Y) : chap2_scope. @@ -207,7 +205,8 @@ Notation "'`H(' X ',' Y ')'" := (joint_entropy_RV X Y) : chap2_scope. Local Open Scope chap2_scope. Section joint_entropy_RV_prop. -Variables (U A B : finType) (P : {fdist U}) (X : {RV P -> A}) (Y : {RV P -> B}). +Variable R : realType. +Variables (U A B : finType) (P : R.-fdist U) (X : {RV P -> A}) (Y : {RV P -> B}). (* 2.9 *) Lemma eqn29 : `H(X, Y) = - `E (`log `p_[% X, Y]). @@ -216,7 +215,7 @@ Proof. by rewrite /joint_entropy_RV joint_entropyE E_neg_RV. Qed. End joint_entropy_RV_prop. Section joint_entropy_prop. -Variable (A : finType) (P : {fdist A}). +Variable (R : realType) (A : finType) (P : R.-fdist A). Lemma joint_entropy_self : joint_entropy (fdist_self P) = `H P. Proof. @@ -226,14 +225,14 @@ rewrite (eq_bigr (fun a => fdist_self P (a.1, a.2) * rewrite -(pair_bigA _ (fun a1 a2 => fdist_self P (a1, a2) * log (fdist_self P (a1, a2)))) /=. apply/eq_bigr => a _. -rewrite (bigD1 a) //= !fdist_selfE /= eqxx big1 ?addR0 //. -by move=> a' /negbTE; rewrite fdist_selfE /= eq_sym => ->; rewrite mul0R. +rewrite (bigD1 a) //= !fdist_selfE /= eqxx big1 ?addr0 //. +by move=> a' /negbTE; rewrite fdist_selfE /= eq_sym => ->; rewrite mul0r. Qed. End joint_entropy_prop. Section conditional_entropy. -Variables (A B : finType) (QP : {fdist B * A}). +Variables (R : realType) (A B : finType) (QP : R.-fdist (B * A)). (* H(Y|X = x), see eqn 2.10 *) Definition cond_entropy1 a := - \sum_(b in B) @@ -242,7 +241,7 @@ Definition cond_entropy1 a := - \sum_(b in B) Let P := QP`2. (*eqn 2.11 *) -Definition cond_entropy := \sum_(a in A) P a * cond_entropy1 a. +Definition cond_entropy : R^o := \sum_(a in A) P a * cond_entropy1 a. Let PQ := fdistX QP. @@ -250,31 +249,31 @@ Let PQ := fdistX QP. Lemma cond_entropyE : cond_entropy = - \sum_(a in A) \sum_(b in B) PQ (a, b) * log (\Pr_QP [ [set b] | [set a]]). Proof. -rewrite /cond_entropy big_morph_oppR /=; apply eq_bigr => a _. -rewrite /cond_entropy1 mulRN big_distrr /=; congr (- _); apply eq_bigr => b _. -rewrite mulRA; congr (_ * _). -by rewrite mulRC -(Pr_set1 P a) -jproduct_rule setX1 fdistXE Pr_set1. +rewrite /cond_entropy big_morph_oppr /=; apply eq_bigr => a _. +rewrite /cond_entropy1 mulrN big_distrr /=; congr (- _); apply eq_bigr => b _. +rewrite mulrA; congr (_ * _). +by rewrite mulrC -(Pr_set1 P a) -jproduct_rule setX1 fdistXE Pr_set1. Qed. Lemma cond_entropy1_ge0 a : 0 <= cond_entropy1 a. Proof. -rewrite /cond_entropy1 big_morph_oppR; apply/RleP/sumr_ge0 => b _; rewrite -mulRN. +rewrite /cond_entropy1 big_morph_oppr; apply/sumr_ge0 => b _; rewrite -mulrN. have [->|H0] := eqVneq (\Pr_QP[[set b]|[set a]]) 0. - by rewrite mul0R. -apply/RleP/mulR_ge0; [exact: jcPr_ge0|]. -rewrite -oppR0 -(Log_1 2) /log leR_oppr oppRK. -by apply Log_increasing_le => //; [rewrite jcPr_gt0 | exact: jcPr_le1]. + by rewrite mul0r. +apply/mulr_ge0; [exact: jcPr_ge0|]. +by rewrite -oppr0 -log1 lerNr opprK ler_log ?posrE// ?jcPr_gt0// jcPr_le1. Qed. Lemma cond_entropy_ge0 : 0 <= cond_entropy. Proof. -by apply/RleP/sumr_ge0 => a _; apply/RleP/mulR_ge0 => //; exact: cond_entropy1_ge0. +by apply/sumr_ge0 => a _; apply/mulr_ge0 => //; exact: cond_entropy1_ge0. Qed. End conditional_entropy. Section cond_entropy1_RV_prop. -Variables (U A B : finType) (P : {fdist U}) (X : {RV P -> A}) (Y : {RV P -> B}). +Variable R : realType. +Variables (U A B : finType) (P : R.-fdist U) (X : {RV P -> A}) (Y : {RV P -> B}). Definition cond_entropy1_RV a := `H (`p_[% X, Y] `(| a )). @@ -291,7 +290,7 @@ Notation "'`H(' Y '|' X ')'" := (cond_entropy `p_[% Y, X]) : chap2_scope. Section conditional_entropy_prop. -Variables (A B C : finType) (PQR : {fdist A * B * C}). +Variables (R : realType) (A B C : finType) (PQR : R.-fdist (A * B * C)). Lemma cond_entropy1_fdistAC b c : cond_entropy1 (fdistA PQR) (b, c) = cond_entropy1 (fdistA (fdistAC PQR)) (c, b). @@ -300,7 +299,8 @@ rewrite /cond_entropy1; congr (- _). by apply eq_bigr => a _; rewrite -!setX1 jcPr_fdistA_AC. Qed. -Lemma cond_entropy_fdistA : cond_entropy (fdistA PQR) = cond_entropy (fdistA (fdistAC PQR)). +Lemma cond_entropy_fdistA : + cond_entropy (fdistA PQR) = cond_entropy (fdistA (fdistAC PQR)). Proof. rewrite /cond_entropy /=. rewrite (eq_bigr (fun a => (fdistA PQR)`2 (a.1, a.2) * @@ -315,7 +315,7 @@ Qed. End conditional_entropy_prop. Section chain_rule. -Variables (A B : finType) (PQ : {fdist A * B}). +Variables (R : realType) (A B : finType) (PQ : R.-fdist (A * B)). Let P := PQ`1. Let QP := fdistX PQ. @@ -326,22 +326,22 @@ transitivity (- (\sum_(a in A) \sum_(b in B) PQ (a, b) * log (P a * \Pr_QP [ [set b] | [set a] ]))). (* 2.16 *) congr (- _); rewrite pair_big /=; apply eq_bigr => -[a b] _ /=. congr (_ * log _); have [H0|H0] := eqVneq (P a) 0. - - by rewrite (dom_by_fdist_fst _ H0) H0 mul0R. - - rewrite -(Pr_set1 P a) /P -(fdistX2 PQ) mulRC -jproduct_rule setX1. + - by rewrite (dom_by_fdist_fst _ H0) H0 mul0r. + - rewrite -(Pr_set1 P a) /P -(fdistX2 PQ) mulrC -jproduct_rule setX1. by rewrite Pr_set1 fdistXE. transitivity ( - (\sum_(a in A) \sum_(b in B) PQ (a, b) * log (P a)) - (\sum_(a in A) \sum_(b in B) PQ (a, b) * log (\Pr_QP [ [set b] | [set a] ]))). (* 2.17 *) - rewrite -oppRB; congr (- _); rewrite -addR_opp oppRK -big_split /=. + rewrite -opprB; congr (- _); rewrite opprK -big_split /=. apply eq_bigr => a _; rewrite -big_split /=; apply eq_bigr => b _. - have [->|H0] := eqVneq (PQ (a, b)) 0; first by rewrite !mul0R addR0. - rewrite -mulRDr; congr (_ * _); rewrite mulRC logM //. - by rewrite -Pr_jcPr_gt0 setX1 Pr_set1 fdistXE; apply/RltP; rewrite -fdist_gt0. - by apply/RltP; rewrite -fdist_gt0; exact: dom_by_fdist_fstN H0. -rewrite [in X in _ + X = _]big_morph_oppR; congr (_ + _). + have [->|H0] := eqVneq (PQ (a, b)) 0; first by rewrite !mul0r addr0. + rewrite -mulrDr; congr (_ * _); rewrite mulrC logM //. + by rewrite -Pr_jcPr_gt0 setX1 Pr_set1 fdistXE; rewrite -fdist_gt0. + by rewrite -fdist_gt0; exact: dom_by_fdist_fstN H0. +rewrite [in X in _ + X = _]big_morph_oppr; congr (_ + _). - rewrite /entropy; congr (- _); apply eq_bigr => a _. by rewrite -big_distrl /= -fdist_fstE. -- rewrite cond_entropyE big_morph_oppR. +- rewrite cond_entropyE big_morph_oppr. by apply eq_bigr => a _; congr (- _); apply eq_bigr => b _; rewrite !fdistXE. Qed. @@ -349,7 +349,8 @@ End chain_rule. Section chain_rule_RV. Local Open Scope chap2_scope. -Variables (U A B : finType) (P : {fdist U}) (X : {RV P -> A}) (Y : {RV P -> B}). +Variable R : realType. +Variables (U A B : finType) (P : R.-fdist U) (X : {RV P -> A}) (Y : {RV P -> B}). Lemma chain_rule_RV : `H(X, Y) = `H `p_X + `H(Y | X). Proof. @@ -398,7 +399,8 @@ Arguments put_front_inj {n} _. Definition put_front_perm (n : nat) i : 'S_n.+1 := perm (put_front_inj i). (* TODO: clean *) -Lemma fdist_col'_put_front n (A : finType) (P : {fdist 'rV[A]_n.+1}) (i : 'I_n.+1) : +Lemma fdist_col'_put_front n (R : realType) (A : finType) + (P : R.-fdist 'rV[A]_n.+1) (i : 'I_n.+1) : i != ord0 -> fdist_col' P i = (fdist_prod_of_rV (fdist_perm P (put_front_perm i)))`2. Proof. @@ -446,7 +448,7 @@ rewrite neq_ltn => /orP[|] ki. rewrite /unbump ltnNge (ltnW ki) subn0 inordK //. by rewrite (leq_trans ki) // -ltnS/=. rewrite ltnNge (ltnW ki) /=; move: ki. -have [/eqP -> //|k0] := boolP (k == ord0). +have [->//|k0] := eqVneq k ord0. rewrite (_ : k = rshift 1 (inord k.-1)); last first. by apply val_inj => /=; rewrite add1n inordK ?prednK // ?lt0n // -ltnS. rewrite (@row_mxEr _ 1 1) /=. @@ -454,7 +456,7 @@ rewrite inordK ?prednK ?lt0n // -1?ltnS // ltnS add1n prednK ?lt0n // => ik. by congr (v _ _); apply val_inj => /=; rewrite /unbump ik subn1. Qed. -Lemma chain_rule_multivar (A : finType) (n : nat) (P : {fdist 'rV[A]_n.+1}) +Lemma chain_rule_multivar (R : realType) (A : finType) (n : nat) (P : R.-fdist 'rV[A]_n.+1) (i : 'I_n.+1) : i != ord0 -> (`H P = `H (fdist_col' P i) + cond_entropy (fdist_prod_of_rV (fdist_perm P (put_front_perm i))))%R. @@ -467,15 +469,15 @@ Qed. End chain_rule_generalization. Section entropy_chain_rule_corollary. -Variables (A B C : finType) (PQR : {fdist A * B * C}). -Let PR : {fdist A * C} := fdist_proj13 PQR. -Let QPR : {fdist B * (A * C)} := fdistA (fdistC12 PQR). +Variables (R : realType) (A B C : finType) (PQR : R.-fdist (A * B * C)). +Let PR : R.-fdist (A * C) := fdist_proj13 PQR. +Let QPR : R.-fdist (B * (A * C)) := fdistA (fdistC12 PQR). (* eqn 2.21, H(X,Y|Z) = H(X|Z) + H(Y|X,Z) *) Lemma chain_rule_corollary : cond_entropy PQR = cond_entropy PR + cond_entropy QPR. Proof. -rewrite !cond_entropyE -oppRD; congr (- _). +rewrite !cond_entropyE -opprD; congr (- _). rewrite [in X in _ = _ + X](eq_bigr (fun j => \sum_(i in B) (fdistX QPR) ((j.1, j.2), i) * log \Pr_QPR[[set i] | [set (j.1, j.2)]])); last by case. rewrite -[in RHS](pair_bigA _ (fun j1 j2 => \sum_(i in B) (fdistX QPR ((j1, j2), i) * @@ -487,48 +489,47 @@ rewrite -[in LHS](pair_bigA _ (fun j1 j2 => (fdistX PQR) (c, (j1, j2)) * log \Pr_PQR[[set (j1, j2)] | [set c]])) /=. rewrite -big_split; apply eq_bigr => a _ /=. rewrite fdistXE fdist_proj13E big_distrl /= -big_split; apply eq_bigr => b _ /=. -rewrite !(fdistXE,fdistAE,fdistC12E) /= -mulRDr. -have [->|H0] := eqVneq (PQR (a, b, c)) 0; first by rewrite !mul0R. +rewrite !(fdistXE,fdistAE,fdistC12E) /= -mulrDr. +have [->|H0] := eqVneq (PQR (a, b, c)) 0; first by rewrite !mul0r. rewrite -logM; last 2 first. by rewrite -Pr_jcPr_gt0 Pr_gt0P setX1 Pr_set1; exact: fdist_proj13_dominN H0. by rewrite -Pr_jcPr_gt0 Pr_gt0P setX1 Pr_set1 fdistAE /= fdistC12E. congr (_ * log _). -by rewrite -setX1 product_ruleC !setX1 mulRC. +by rewrite -setX1 product_ruleC !setX1 mulrC. Qed. End entropy_chain_rule_corollary. Section conditional_entropy_prop2. (* NB: here because use chain rule *) - -Variables (A B : finType) (PQ : {fdist A * B}). +Variables (R : realType) (A B : finType) (PQ : R.-fdist (A * B)). Let P := PQ`1. Let Q := PQ`2. Let QP := fdistX PQ. Lemma entropyB : `H P - cond_entropy PQ = `H Q - cond_entropy QP. Proof. -rewrite subR_eq addRAC -subR_eq subR_opp -chain_rule joint_entropyC. +apply/eqP; rewrite subr_eq addrAC -subr_eq opprK; apply/eqP. +rewrite -chain_rule joint_entropyC. by rewrite -/(joint_entropy (fdistX PQ)) chain_rule fdistX1 -/Q fdistXI. Qed. End conditional_entropy_prop2. Section conditional_entropy_prop3. (* NB: here because use chain rule *) - -Variables (A : finType) (P : {fdist A}). +Variables (R : realType) (A : finType) (P : R.-fdist A). Lemma cond_entropy_self : cond_entropy (fdist_self P) = 0. Proof. -move: (@chain_rule _ _ (fdist_self P)). -rewrite !fdist_self1 fdistX_self addRC -subR_eq => <-. -by rewrite joint_entropy_self subRR. +move: (@chain_rule _ _ _ (fdist_self P)). +rewrite !fdist_self1 fdistX_self addrC => /eqP; rewrite -subr_eq => /eqP <-. +by rewrite joint_entropy_self subrr. Qed. End conditional_entropy_prop3. Section mutual_information. Local Open Scope divergence_scope. -Variables (A B : finType) (PQ : {fdist A * B}). +Variables (R : realType) (A B : finType) (PQ : R.-fdist (A * B)). Let P := PQ`1. Let Q := PQ`2. Let QP := fdistX PQ. @@ -538,7 +539,7 @@ Definition mutual_info := D(PQ || P `x Q). End mutual_information. Section mutual_information_prop. -Variables (A B : finType) (PQ : {fdist A * B}). +Variables (R : realType) (A B : finType) (PQ : R.-fdist (A * B)). Let P := PQ`1. Let Q := PQ`2. Let QP := fdistX PQ. @@ -548,7 +549,7 @@ Lemma mutual_infoE0 : mutual_info PQ = \sum_(a in A) \sum_(b in B) PQ (a, b) * log (PQ (a, b) / (P a * Q b)). Proof. rewrite /mutual_info /div pair_big /=; apply eq_bigr; case => a b _ /=. -have [->|H0] := eqVneq (PQ (a, b)) 0; first by rewrite !mul0R. +have [->|H0] := eqVneq (PQ (a, b)) 0; first by rewrite !mul0r. by rewrite fdist_prodE. Qed. @@ -560,27 +561,26 @@ transitivity (\sum_(a in A) \sum_(b in B) PQ (a, b) * log (\Pr_PQ [ [set a] | [set b] ] / P a)). apply eq_bigr => a _; apply eq_bigr => b _. rewrite /jcPr setX1 2!Pr_set1 /= -/Q. - have [->|H0] := eqVneq (PQ (a, b)) 0; first by rewrite !mul0R. - by congr (_ * log _); rewrite divRM 1?mulRAC //; [ - exact: dom_by_fdist_fstN H0 | exact: dom_by_fdist_sndN H0]. + have [->|H0] := eqVneq (PQ (a, b)) 0; first by rewrite !mul0r. + by congr (_ * log _); rewrite invfM mulrAC mulrA. transitivity (- (\sum_(a in A) \sum_(b in B) PQ (a, b) * log (P a)) + \sum_(a in A) \sum_(b in B) PQ (a, b) * log (\Pr_PQ [ [set a] | [set b] ])). (* 2.37 *) - rewrite big_morph_oppR -big_split; apply/eq_bigr => a _ /=. - rewrite big_morph_oppR -big_split; apply/eq_bigr => b _ /=. - rewrite addRC -mulRN -mulRDr addR_opp. - have [->|H0] := eqVneq (PQ (a, b)) 0; first by rewrite !mul0R. + rewrite big_morph_oppr -big_split; apply/eq_bigr => a _ /=. + rewrite big_morph_oppr -big_split; apply/eq_bigr => b _ /=. + rewrite addrC -mulrN -mulrDr. + have [->|H0] := eqVneq (PQ (a, b)) 0; first by rewrite !mul0r. congr (_ * _); rewrite logDiv //. - by rewrite -Pr_jcPr_gt0 Pr_gt0P setX1 Pr_set1. - - by apply/RltP; rewrite -fdist_gt0; exact: dom_by_fdist_fstN H0. -rewrite -subR_opp; congr (_ - _). + - by rewrite -fdist_gt0; exact: dom_by_fdist_fstN H0. +congr (_ + _). - rewrite /entropy; congr (- _); apply/eq_bigr => a _. by rewrite -big_distrl /= -fdist_fstE. - rewrite /cond_entropy exchange_big. - rewrite big_morph_oppR; apply eq_bigr=> b _ /=. - rewrite mulRN; congr (- _). + rewrite big_morph_oppr; apply eq_bigr=> b _ /=. + rewrite mulrN opprK. rewrite big_distrr /=; apply eq_bigr=> a _ /=. - rewrite mulRA; congr (_ * _); rewrite -/Q. - by rewrite -[in LHS]Pr_set1 -setX1 jproduct_rule Pr_set1 -/Q mulRC. + rewrite [in RHS]mulrCA mulrA; congr (_ * _); rewrite -/Q. + by rewrite -[in LHS]Pr_set1 -setX1 jproduct_rule Pr_set1 -/Q mulrC. Qed. Lemma mutual_infoE2 : mutual_info PQ = `H Q - cond_entropy QP. (* 2.40 *) @@ -589,8 +589,8 @@ Proof. by rewrite mutual_infoE entropyB. Qed. Lemma mutual_infoE3 : mutual_info PQ = `H P + `H Q - `H PQ. (* 2.41 *) Proof. rewrite mutual_infoE; have := chain_rule QP. -rewrite addRC -subR_eq -(fdistXI PQ) -/QP => <-. -by rewrite -addR_opp oppRB fdistX1 -/Q addRA joint_entropyC. +rewrite addrC => /eqP; rewrite -subr_eq -(fdistXI PQ) -/QP => /eqP <-. +by rewrite opprB fdistX1 -/Q addrA joint_entropyC. Qed. (* nonnegativity of mutual information 2.90 *) @@ -606,7 +606,8 @@ Qed. End mutual_information_prop. Section mutualinfo_RV_def. -Variables (U A B : finType) (P : {fdist U}) (X : {RV P -> A}) (Y : {RV P -> B}). +Variable R : realType. +Variables (U A B : finType) (P : R.-fdist U) (X : {RV P -> A}) (Y : {RV P -> B}). Definition mutual_info_RV := mutual_info `p_[% X, Y]. End mutualinfo_RV_def. Notation "'`I(' X ';' Y ')'" := (mutual_info_RV X Y) : chap2_scope. @@ -618,21 +619,21 @@ Section mutualinfo_prop. Local Open Scope divergence_scope. (* eqn 2.46 *) -Lemma mutual_info_sym (A B : finType) (PQ : {fdist A * B}) : +Lemma mutual_info_sym (R : realType) (A B : finType) (PQ : R.-fdist (A * B)) : mutual_info PQ = mutual_info (fdistX PQ). Proof. by rewrite !mutual_infoE entropyB fdistX1. Qed. (* eqn 2.47 *) -Lemma mutual_info_self (A : finType) (P : {fdist A}) : +Lemma mutual_info_self (R : realType) (A : finType) (P : R.-fdist A) : mutual_info (fdist_self P) = `H P. -Proof. by rewrite mutual_infoE cond_entropy_self subR0 fdist_self1. Qed. +Proof. by rewrite mutual_infoE cond_entropy_self subr0 fdist_self1. Qed. End mutualinfo_prop. Section chain_rule_for_entropy. Local Open Scope vec_ext_scope. -Lemma entropy_head_of1 (A : finType) (P : {fdist 'M[A]_1}) : +Lemma entropy_head_of1 (R : realType) (A : finType) (P : R.-fdist 'M[A]_1) : `H P = `H (head_of_fdist_rV P). Proof. rewrite /entropy; congr (- _); apply: big_rV_1 => // a. @@ -642,7 +643,7 @@ congr (P _ * log (P _)); apply/rowP => i. by rewrite (ord1 i) !mxE; case: splitP => // i0; rewrite (ord1 i0) mxE. Qed. -Lemma chain_rule_rV (A : finType) (n : nat) (P : {fdist 'rV[A]_n.+1}) : +Lemma chain_rule_rV (R : realType) (A : finType) (n : nat) (P : R.-fdist 'rV[A]_n.+1) : `H P = \sum_(i < n.+1) if i == O :> nat then `H (head_of_fdist_rV P) @@ -650,7 +651,7 @@ Lemma chain_rule_rV (A : finType) (n : nat) (P : {fdist 'rV[A]_n.+1}) : cond_entropy (fdistX (fdist_belast_last_of_rV (fdist_take P (lift ord0 i)))). Proof. elim: n P => [P|n IH P]. - by rewrite big_ord_recl /= big_ord0 addR0 -entropy_head_of1. + by rewrite big_ord_recl /= big_ord0 addr0 -entropy_head_of1. rewrite entropy_rV chain_rule {}IH [in RHS]big_ord_recr /=. rewrite fdist_take_all; congr (_ + _); apply eq_bigr => i _. case: ifP => i0; first by rewrite head_of_fdist_rV_belast_last. @@ -664,7 +665,7 @@ Qed. End chain_rule_for_entropy. Section divergence_conditional_distributions. -Variables (A B C : finType) (PQR : {fdist A * B * C}). +Variables (R : realType) (A B C : finType) (PQR : R.-fdist (A * B * C)). Definition cdiv1 z := \sum_(x in {: A * B}) \Pr_PQR[[set x] | [set z]] * log (\Pr_PQR[[set x] | [set z]] / @@ -680,16 +681,16 @@ Lemma cdiv1_is_div (c : C) (Hc : (fdistX PQR)`1 c != 0) Proof. rewrite /cdiv1 /div; apply eq_bigr => -[a b] /= _; rewrite jfdist_condE //. rewrite fdistXI. -have [->|H0] := eqVneq (\Pr_PQR[[set (a, b)]|[set c]]) 0; first by rewrite !mul0R. +have [->|H0] := eqVneq (\Pr_PQR[[set (a, b)]|[set c]]) 0; first by rewrite !mul0r. by rewrite fdist_prodE /= jfdist_condE // jfdist_condE // !fdistXI. Qed. Lemma cdiv1_ge0 z : 0 <= cdiv1 z. Proof. have [z0|z0] := eqVneq (PQR`2 z) 0. - apply/RleP/sumr_ge0 => -[a b] _; apply/RleP. + apply/sumr_ge0 => -[a b] _. rewrite {1}/jcPr setX1 [X in X / _ * _]Pr_set1/= (dom_by_fdist_snd (a, b) z0). - by rewrite div0R mul0R. + by rewrite !mul0r. have Hc : (fdistX PQR)`1 z != 0 by rewrite fdistX1. have Hc1 : (fdistX (fdist_proj13 PQR))`1 z != 0. by rewrite fdistX1 fdist_proj13_snd. @@ -698,23 +699,23 @@ have Hc2 : (fdistX (fdist_proj23 PQR))`1 z != 0. rewrite cdiv1_is_div //; apply div_ge0. (* TODO: lemma *) apply/dominatesP => -[a b]. -rewrite fdist_prodE !jfdist_condE //= mulR_eq0 => -[|]. -- rewrite /jcPr !setX1 !Pr_set1 !mulR_eq0 => -[|]. - rewrite !fdistXI. - by move/fdist_proj13_domin => ->; left. - rewrite !fdistXI. - by rewrite fdist_proj13_snd /Rdiv => ->; right. -- rewrite /jcPr !setX1 !Pr_set1 !mulR_eq0 => -[|]. - rewrite !fdistXI. - by move/fdist_proj23_domin => ->; left. - by rewrite !fdistXI fdist_proj23_snd => ->; right. +rewrite fdist_prodE !jfdist_condE //= => /eqP; rewrite mulf_eq0 => /orP[|]. +- rewrite /jcPr !setX1 !Pr_set1 !mulf_eq0 => /orP[|]. + rewrite !fdistXI => /eqP. + by move/fdist_proj13_domin => ->; rewrite mul0r. + rewrite !fdistXI => /eqP. + by rewrite fdist_proj13_snd => ->; rewrite mulr0. +- rewrite /jcPr !setX1 !Pr_set1 mulf_eq0 => /orP[|]. + rewrite !fdistXI => /eqP. + by move/fdist_proj23_domin => ->; rewrite mul0r. + by rewrite !fdistXI fdist_proj23_snd => /eqP ->; rewrite mulr0. Qed. End divergence_conditional_distributions. Section conditional_mutual_information. Section def. -Variables (A B C : finType) (PQR : {fdist A * B * C}). +Variables (R : realType) (A B C : finType) (PQR : R.-fdist (A * B * C)). (* I(X;Y|Z) = H(X|Z) - H(X|Y,Z) 2.60 *) Definition cond_mutual_info := @@ -722,19 +723,19 @@ Definition cond_mutual_info := End def. Section prop. -Variables (A B C : finType) (PQR : {fdist A * B * C}). +Variables (R : realType) (A B C : finType) (PQR : R.-fdist (A * B * C)). Lemma cond_mutual_infoE : cond_mutual_info PQR = \sum_(x in {: A * B * C}) PQR x * log (\Pr_PQR[[set x.1] | [set x.2]] / (\Pr_(fdist_proj13 PQR)[[set x.1.1] | [set x.2]] * \Pr_(fdist_proj23 PQR)[[set x.1.2] | [set x.2]])). Proof. -rewrite /cond_mutual_info 2!cond_entropyE /= subR_opp big_morph_oppR. +rewrite /cond_mutual_info 2!cond_entropyE /= big_morph_oppr. rewrite (eq_bigr (fun a => \sum_(b in A) (fdistX (fdistA PQR)) (a.1, a.2, b) * log \Pr_(fdistA PQR)[[set b] | [set (a.1, a.2)]])); last by case. rewrite -(pair_bigA _ (fun a1 a2 => \sum_(b in A) (fdistX (fdistA PQR)) ((a1, a2), b) * log \Pr_(fdistA PQR)[[set b] | [set (a1, a2)]])). -rewrite exchange_big -big_split /=. +rewrite /= exchange_big /= opprK -big_split /=. rewrite (eq_bigr (fun x => PQR (x.1, x.2) * log (\Pr_PQR[[set x.1] | [set x.2]] / (\Pr_(fdist_proj13 PQR)[[set x.1.1] | [set x.2]] * @@ -744,7 +745,7 @@ rewrite -(pair_bigA _ (fun x1 x2 => PQR (x1, x2) * log (\Pr_(fdist_proj13 PQR)[[set x1.1] | [set x2]] * \Pr_(fdist_proj23 PQR)[[set x1.2] | [set x2]])))). rewrite /= exchange_big; apply eq_bigr => c _. -rewrite big_morph_oppR /= exchange_big -big_split /=. +rewrite big_morph_oppr /= exchange_big -big_split /=. rewrite (eq_bigr (fun i => PQR ((i.1, i.2), c) * log (\Pr_PQR[[set (i.1, i.2)] | [set c]] / (\Pr_(fdist_proj13 PQR)[[set i.1] | [set c]] * @@ -753,28 +754,25 @@ rewrite -(pair_bigA _ (fun i1 i2 => PQR (i1, i2, c) * log (\Pr_PQR[[set (i1, i2)] | [set c]] / (\Pr_(fdist_proj13 PQR)[[set i1] | [set c]] * \Pr_(fdist_proj23 PQR)[[set i2] | [set c]])))). apply eq_bigr => a _ /=. -rewrite fdistXE fdist_proj13E big_distrl /= big_morph_oppR -big_split. +rewrite fdistXE fdist_proj13E big_distrl /= big_morph_oppr -big_split. apply eq_bigr => b _ /=. -rewrite fdistXE fdistAE /= -mulRN -mulRDr. -have [->|H0] := eqVneq (PQR (a, b, c)) 0; first by rewrite !mul0R. +rewrite fdistXE fdistAE /= -mulrN -mulrDr. +have [->|H0] := eqVneq (PQR (a, b, c)) 0; first by rewrite !mul0r. congr (_ * _). -rewrite addRC addR_opp -logDiv; last 2 first. +rewrite addrC -logDiv; last 2 first. by rewrite -Pr_jcPr_gt0 Pr_gt0P setX1 Pr_set1; exact: fdistA_dominN H0. by rewrite -Pr_jcPr_gt0 Pr_gt0P setX1 Pr_set1; exact: fdist_proj13_dominN H0. congr (log _). -rewrite divRM; last 2 first. - by rewrite -jcPr_gt0 -Pr_jcPr_gt0 Pr_gt0P setX1 Pr_set1; exact: fdist_proj13_dominN H0. - by rewrite -jcPr_gt0 -Pr_jcPr_gt0 Pr_gt0P setX1 Pr_set1; exact: fdist_proj23_dominN H0. -rewrite {2}/Rdiv -mulRA mulRCA {1}/Rdiv [in LHS]mulRC; congr (_ * _). -rewrite -[in X in _ = X * _]setX1 jproduct_rule_cond setX1 -mulRA mulRV ?mulR1 //. -rewrite /jcPr divR_neq0' // ?setX1 !Pr_set1. +rewrite [in RHS]invfM mulrCA [RHS]mulrC; congr (_ / _). +rewrite -[in X in _ = X * _]setX1 jproduct_rule_cond setX1 -mulrA mulfV ?mulr1 //. +rewrite /jcPr mulf_neq0// ?setX1 !Pr_set1. exact: fdist_proj23_dominN H0. -by rewrite fdist_proj23_snd; exact: dom_by_fdist_sndN H0. +by rewrite fdist_proj23_snd invr_eq0; exact: dom_by_fdist_sndN H0. Qed. -Let R := PQR`2. +Let PQR2 := (PQR`2). -Lemma cond_mutual_infoE2 : cond_mutual_info PQR = \sum_(z in C) R z * cdiv1 PQR z. +Lemma cond_mutual_infoE2 : cond_mutual_info PQR = \sum_(z in C) PQR2 z * cdiv1 PQR z. Proof. rewrite cond_mutual_infoE. rewrite (eq_bigr (fun x => PQR (x.1, x.2) * log @@ -786,8 +784,8 @@ rewrite -(pair_bigA _ (fun x1 x2 => PQR (x1, x2) * log (\Pr_(fdist_proj13 PQR)[[set x1.1] | [set x2]] * \Pr_(fdist_proj23 PQR)[[set x1.2] | [set x2]])))). rewrite exchange_big; apply eq_bigr => c _ /=. -rewrite big_distrr /=; apply eq_bigr => -[a b] _ /=; rewrite mulRA; congr (_ * _). -rewrite mulRC. +rewrite big_distrr /=; apply eq_bigr => -[a b] _ /=; rewrite mulrA; congr (_ * _). +rewrite mulrC. move: (jproduct_rule PQR [set (a, b)] [set c]); rewrite -/R Pr_set1 => <-. by rewrite setX1 Pr_set1. Qed. @@ -795,12 +793,12 @@ Qed. (* 2.92 *) Lemma cond_mutual_info_ge0 : 0 <= cond_mutual_info PQR. Proof. -rewrite cond_mutual_infoE2; apply/RleP/sumr_ge0 => c _; apply/RleP/mulR_ge0 => //. +rewrite cond_mutual_infoE2; apply/sumr_ge0 => c _; apply/mulr_ge0 => //. exact: cdiv1_ge0. Qed. -Let P : {fdist A} := (fdistA PQR)`1. -Let Q : {fdist B} := (PQR`1)`2. +Let P : R.-fdist A := (fdistA PQR)`1. +Let Q : R.-fdist B := (PQR`1)`2. Lemma chain_rule_mutual_info : mutual_info PQR = mutual_info (fdist_proj13 PQR) + cond_mutual_info (fdistX (fdistA PQR)). @@ -808,8 +806,8 @@ Proof. rewrite mutual_infoE. have := chain_rule (PQR`1); rewrite /joint_entropy => ->. rewrite (chain_rule_corollary PQR). -rewrite -addR_opp oppRD addRCA 2!addRA -(addRA (- _ + _)) addR_opp; congr (_ + _). - rewrite mutual_infoE addRC; congr (_ - _). +rewrite opprD addrCA 2!addrA -(addrA (- _ + _)); congr (_ + _). + rewrite mutual_infoE addrC; congr (_ - _). by rewrite fdist_proj13_fst fdistA1. rewrite /cond_mutual_info; congr (cond_entropy _ - _). by rewrite /fdist_proj13 -/(fdistC13 _) fdistA_C13_snd. @@ -831,10 +829,11 @@ End conditional_mutual_information. Section conditional_relative_entropy. Section def. -Variables (A B : finType) (P Q : ({fdist A} * (A -> {fdist B}))). -Let Pj : {fdist B * A} := fdistX (P.1 `X P.2). -Let Qj : {fdist B * A} := fdistX (Q.1 `X Q.2). -Let P1 : {fdist A} := P.1. +Variable R : realType. +Variables (A B : finType) (P Q : (R.-fdist A * (A -> R.-fdist B))). +Let Pj : R.-fdist (B * A) := fdistX (P.1 `X P.2). +Let Qj : R.-fdist (B * A) := fdistX (Q.1 `X Q.2). +Let P1 : R.-fdist A := P.1. (* eqn 2.65 *) Definition cond_relative_entropy := \sum_(x in A) P1 x * \sum_(y in B) @@ -845,11 +844,11 @@ End def. Section prop. Local Open Scope divergence_scope. Local Open Scope reals_ext_scope. -Variables (A B : finType) (P Q : ({fdist A} * (A -> {fdist B}))). -Let Pj : {fdist B * A} := fdistX (P.1 `X P.2). -Let Qj : {fdist B * A} := fdistX (Q.1 `X Q.2). -Let P1 : {fdist A} := P.1. -Let Q1 : {fdist A} := Q.1. +Variables (R : realType) (A B : finType) (P Q : (R.-fdist A * (A -> R.-fdist B))). +Let Pj : R.-fdist (B * A) := fdistX (P.1 `X P.2). +Let Qj : R.-fdist (B * A) := fdistX (Q.1 `X Q.2). +Let P1 : R.-fdist A := P.1. +Let Q1 : R.-fdist A := Q.1. Lemma chain_rule_relative_entropy : Pj `<< Qj -> D(Pj || Qj) = D(P1 || Q1) + cond_relative_entropy P Q. @@ -859,36 +858,36 @@ rewrite {2}/div /cond_relative_entropy -big_split /= {1}/div /=. rewrite (eq_bigr (fun a => Pj (a.1, a.2) * (log (Pj (a.1, a.2) / (Qj (a.1, a.2)))))); last by case. rewrite -(pair_bigA _ (fun a1 a2 => Pj (a1, a2) * (log (Pj (a1, a2) / (Qj (a1, a2)))))) /=. rewrite exchange_big; apply eq_bigr => a _ /=. -rewrite [in X in _ = X * _ + _](_ : P1 a = Pj`2 a); last first. - by rewrite /P fdistX2 fdist_prod1. +rewrite [in X in _ = X * _ + _](_ : P1 a = Pj`2 a); last by rewrite /P fdistX2 fdist_prod1. rewrite fdist_sndE big_distrl /= big_distrr /= -big_split /=; apply eq_bigr => b _. -rewrite mulRA (_ : P1 a * _ = Pj (b, a)); last first. - rewrite /jcPr Pr_set1 -/P1 mulRCA setX1 Pr_set1 {1}/Pj fdistX2 fdist_prod1. +rewrite [X in _ = _ + X]mulrA [X in _ = _ + X * _](_ : P.1 a * _ = Pj (b, a)); last first. + rewrite /jcPr Pr_set1 -/P1 mulrCA setX1 Pr_set1 {1}/Pj fdistX2 fdist_prod1. have [P2a0|P2a0] := eqVneq (P1 a) 0. have Pba0 : Pj (b, a) = 0. - by rewrite /P fdistXE fdist_prodE P2a0 -RmultE mul0R. - by rewrite Pba0 mul0R. - by rewrite mulRV // ?mulR1. -rewrite -mulRDr. -have [->|H0] := eqVneq (Pj (b, a)) 0; first by rewrite !mul0R. + by rewrite /P fdistXE fdist_prodE P2a0 mul0r. + by rewrite Pba0 mul0r. + by rewrite mulfV // ?mulr1. +rewrite -mulrDr. +have [->|H0] := eqVneq (Pj (b, a)) 0; first by rewrite !mul0r. congr (_ * _). have P1a0 : P1 a != 0. apply: contra H0 => /eqP. - by rewrite /P fdistXE fdist_prodE => ->; rewrite -RmultE mul0R. + by rewrite /P fdistXE fdist_prodE => ->; rewrite mul0r. have Qba0 := dominatesEN PQ H0. have Q2a0 : Q1 a != 0. - apply: contra Qba0; rewrite /Q fdistXE fdist_prodE => /eqP ->; by rewrite -RmultE mul0R. + apply: contra Qba0; rewrite /Q fdistXE fdist_prodE => /eqP ->; by rewrite mul0r. rewrite -logM; last 2 first. - by apply/divR_gt0; apply/RltP; rewrite -fdist_gt0. - by apply/divR_gt0; by rewrite -Pr_jcPr_gt0 setX1 Pr_set1; apply/RltP; rewrite -fdist_gt0. + by apply/divr_gt0; rewrite -fdist_gt0. + by apply/divr_gt0; by rewrite -Pr_jcPr_gt0 setX1 Pr_set1; rewrite -fdist_gt0. congr (log _). rewrite /jcPr !setX1 !Pr_set1. rewrite !fdistXE !fdistX2 !fdist_prod1 !fdist_prodE /=. -rewrite -/P1 -/Q1; field. -split; first exact/eqP. -split; first exact/eqP. -apply/eqP. -by apply: contra Qba0; rewrite /Qj fdistXE fdist_prodE /= => /eqP ->. +rewrite -/P1 -/Q1. +rewrite -(mulrA (Q1 a)) (mulrCA (Q1 a)) divff// mulr1. +rewrite -[in X in _ = _ * X](mulrA (P1 a)) (mulrCA (P1 a)) divff// mulr1. +rewrite -!mulrA; congr *%R. +rewrite mulrCA; congr *%R. +by rewrite invfM. Qed. End prop. @@ -896,15 +895,15 @@ End prop. End conditional_relative_entropy. Section chain_rule_for_information. -Variables (A : finType). +Variables (R : realType) (A : finType). Let B := A. (* need in the do-not-delete-me step *) -Variables (n : nat) (PY : {fdist 'rV[A]_n.+1 * B}). -Let P : {fdist 'rV[A]_n.+1} := PY`1. -Let Y : {fdist B} := PY`2. +Variables (n : nat) (PY : R.-fdist ('rV[A]_n.+1 * B)). +Let P : R.-fdist 'rV[A]_n.+1 := PY`1. +Let Y : R.-fdist B := PY`2. -Let f (i : 'I_n.+1) : {fdist A * 'rV[A]_i * B} := fdistC12 (fdist_prod_take PY i). -Let fAC (i : 'I_n.+1) : {fdist A * B * 'rV[A]_i} := fdistAC (f i). -Let fA (i : 'I_n.+1) : {fdist A * ('rV[A]_i * B)} := fdistA (f i). +Let f (i : 'I_n.+1) : R.-fdist (A * 'rV[A]_i * B) := fdistC12 (fdist_prod_take PY i). +Let fAC (i : 'I_n.+1) : R.-fdist (A * B * 'rV[A]_i) := fdistAC (f i). +Let fA (i : 'I_n.+1) : R.-fdist (A * ('rV[A]_i * B)) := fdistA (f i). Local Open Scope vec_ext_scope. @@ -922,16 +921,16 @@ have -> : cond_entropy PY = \sum_(j < n.+1) else cond_entropy (fA j). have := chain_rule (fdistX PY). - rewrite fdistXI addRC -subR_eq fdistX1 -/Y => <-. + rewrite fdistXI addrC => /eqP; rewrite -subr_eq fdistX1 -/Y => /eqP <-. rewrite /joint_entropy. (* do-not-delete-me *) - set YP : {fdist 'rV[A]_n.+2} := fdist_rV_of_prod (fdistX PY). + set YP : R.-fdist 'rV[A]_n.+2 := fdist_rV_of_prod (fdistX PY). transitivity (`H YP - `H Y); first by rewrite /YP entropy_fdist_rV_of_prod. rewrite (chain_rule_rV YP). rewrite [in LHS]big_ord_recl /=. rewrite (_ : `H (head_of_fdist_rV YP) = `H Y); last first. by rewrite /YP /head_of_fdist_rV (fdist_prod_of_rVK (fdistX PY)) fdistX1. - rewrite addRC addRK. + rewrite addrAC subrr add0r. apply eq_bigr => j _. case: ifPn => j0. - have {}j0 : j = ord0 by move: j0 => /eqP j0; exact/val_inj. @@ -1043,7 +1042,7 @@ have -> : cond_entropy PY = \sum_(j < n.+1) move/andP => /= [/eqP <- /eqP ->]. apply/eqP/rowP => k. rewrite !mxE !castmxE /= esymK !cast_ord_id. - case/boolP : (k == O :> nat) => [/eqP | ] k0. + have [k0|k0] := eqVneq (nat_of_ord k) 0%N. rewrite (_ : cast_ord _ _ = ord0); last exact: val_inj. rewrite (_ : k = ord0); last exact: val_inj. by rewrite 2!row_mx_row_ord0. @@ -1094,9 +1093,9 @@ have -> : cond_entropy PY = \sum_(j < n.+1) congr (_ / _ * log (_ / _)). + by rewrite 2!fdist_sndE; apply eq_bigr => a' _; rewrite H2. + by rewrite 2!fdist_sndE; apply eq_bigr => a' _; rewrite H2. -rewrite -addR_opp big_morph_oppR -big_split /=; apply eq_bigr => j _ /=. +rewrite big_morph_oppr -big_split /=; apply eq_bigr => j _ /=. case: ifPn => j0. -- rewrite mutual_infoE addR_opp; congr (`H _ - _). +- rewrite mutual_infoE; congr (`H _ - _). rewrite /head_of_fdist_rV /fdist_fst /fdist_rV_of_prod. by rewrite /fdist_prod_nth !fdistmap_comp. - rewrite /cond_mutual_info /fA -/P; congr (_ - _). @@ -1120,29 +1119,31 @@ End chain_rule_for_information. Section conditioning_reduces_entropy. Section prop. -Variables (A B : finType) (PQ : {fdist A * B}). +Variables (R : realType) (A B : finType) (PQ : R.-fdist (A * B)). Let P := PQ`1. Let Q := PQ`2. Let QP := fdistX PQ. (* 2.95 *) Lemma information_cant_hurt : cond_entropy PQ <= `H P. -Proof. by rewrite -subR_ge0 -mutual_infoE; exact: mutual_info_ge0. Qed. +Proof. by rewrite -subr_ge0 -mutual_infoE; exact: mutual_info_ge0. Qed. Lemma condentropy_indep : PQ = P `x Q -> cond_entropy PQ = `H P. -Proof. by move/mutual_info0P; rewrite mutual_infoE subR_eq0 => <-. Qed. +Proof. +by move/mutual_info0P; rewrite mutual_infoE => /eqP; rewrite subr_eq0 => /eqP <-. +Qed. + End prop. Section prop2. -Variables (A B C : finType) (PQR : {fdist A * B * C}). -Let P : {fdist A} := (fdistA PQR)`1. -Let Q : {fdist B} := (PQR`1)`2. -Let R := PQR`2. +Variables (R : realType) (A B C : finType) (PQR : R.-fdist (A * B * C)). +Let P : R.-fdist A := (fdistA PQR)`1. +Let Q : R.-fdist B := (PQR`1)`2. Lemma mi_bound : PQR`1 = P `x Q (* P and Q independent *) -> mutual_info (fdist_proj13 PQR) + mutual_info (fdist_proj23 PQR) <= mutual_info PQR. Proof. -move=> PQ; rewrite chain_rule_mutual_info leR_add2l /cond_mutual_info. +move=> PQ; rewrite chain_rule_mutual_info lerD2l /cond_mutual_info. rewrite [X in _ <= X - _](_ : _ = `H Q); last first. rewrite condentropy_indep; last first. rewrite fdist_proj13_fst fdistA1 fdistX1 fdistA21 -/Q. @@ -1154,10 +1155,10 @@ rewrite [X in _ <= X - _](_ : _ = `H Q); last first. by rewrite /fdist_proj13 fdistA21 fdistC12_fst fdistX1 fdistX2 fdistA21 -/Q. rewrite mutual_infoE. rewrite fdist_proj23_fst -/Q. -rewrite -oppRB leR_oppl oppRB -!addR_opp leR_add2r. +rewrite -[leLHS]opprB lerNl opprB lerD2r. (* conditioning cannot increase entropy *) (* Q|R,P <= Q|R, lemma *) -rewrite -subR_ge0. +rewrite -subr_ge0. move: (cond_mutual_info_ge0 (fdistC12 PQR)); rewrite /cond_mutual_info. rewrite /fdist_proj13 fdistC12I -/(fdist_proj23 _). by rewrite cond_entropy_fdistA /fdistAC fdistC12I. @@ -1168,26 +1169,25 @@ End conditioning_reduces_entropy. (* TODO: example 2.6.1 *) Section independence_bound_on_entropy. -Variables (A : finType) (n : nat) (P : {fdist 'rV[A]_n.+1}). +Variables (R : realType) (A : finType) (n : nat) (P : R.-fdist 'rV[A]_n.+1). (* thm 2.6.6 TODO: with equality in case of independence *) Lemma independence_bound_on_entropy : `H P <= \sum_(i < n.+1) `H (fdist_nth P i). Proof. -rewrite chain_rule_rV; apply leR_sumR => /= i _. +rewrite chain_rule_rV; apply ler_sum => /= i _. case: ifPn => [/eqP|] i0. rewrite (_ : i = ord0); last exact/val_inj. rewrite head_of_fdist_rV_fdist_nth. - by apply/RleP; rewrite lexx. -apply: leR_trans; first exact: information_cant_hurt. + by rewrite lexx. +apply: le_trans; first exact: information_cant_hurt. rewrite fdistX1 fdist_take_nth. -by apply/RleP; rewrite lexx. +by rewrite lexx. Qed. End independence_bound_on_entropy. Section markov_chain. - -Variables (A B C : finType) (PQR : {fdist A * B * C}). +Variables (R : realType) (A B C : finType) (PQR : R.-fdist (A * B * C)). Let P := PQR`1`1. Let Q := PQR`1`2. Let PQ := PQR`1. @@ -1201,27 +1201,29 @@ Definition markov_chain := forall (x : A) (y : B) (z : C), Let PRQ := fdistAC PQR. (* X and Z are conditionally independent given Y TODO: iff *) -Lemma markov_cond_mutual_info : markov_chain -> cond_mutual_info (PRQ : {fdist A * C * B}) = 0. +Lemma markov_cond_mutual_info : + markov_chain -> cond_mutual_info (PRQ : R.-fdist (A * C * B)) = 0. Proof. rewrite /markov_chain => mc. -rewrite cond_mutual_infoE (eq_bigr (fun=> 0)) ?big_const ?iter_addR ?mulR0 //= => x _. -case/boolP : (PRQ x == 0) => [/eqP ->|H0]; first by rewrite mul0R. -rewrite (_ : _ / _ = 1); first by rewrite /log Log_1 mulR0. -rewrite eqR_divr_mulr ?mul1R; last first. - rewrite mulR_neq0'; apply/andP; split. +rewrite cond_mutual_infoE (eq_bigr (fun=> 0)) ?big1// => x _. +have [->|H0] := eqVneq (PRQ x) 0; first by rewrite mul0r. +rewrite (_ : _ / _ = 1); first by rewrite log1 mulr0. +rewrite eqr_divr_mulr ?mul1r; last first. + rewrite mulf_neq0//. (* TODO: lemma? *) - rewrite /jcPr divR_neq0' //. + rewrite /jcPr mulf_neq0 (* TODO: lemma divf_neq0 *) //. rewrite setX1 Pr_set1. case: x => [[x11 x12] x2] in H0 *. exact: fdist_proj13_dominN H0. - rewrite Pr_set1 fdist_proj13_snd. + rewrite invr_eq0 Pr_set1 fdist_proj13_snd. case: x => [x1 x2] in H0 *. exact: dom_by_fdist_sndN H0. (* TODO: lemma? *) - rewrite /jcPr divR_neq0' //. + rewrite /jcPr mulf_neq0 //. rewrite setX1 Pr_set1. case: x => [[x11 x12] x2] in H0 *. exact: fdist_proj23_dominN H0. + rewrite invr_eq0. rewrite Pr_set1 fdist_proj23_snd. case: x => [x1 x2] in H0 *. exact: dom_by_fdist_sndN H0. @@ -1232,13 +1234,13 @@ transitivity (Pr PQ [set (x.1.1,x.2)] * \Pr_RQ[[set x.1.2]|[set x.2]] / Pr Q [se congr (_ / _). case: x H0 => [[a c] b] H0 /=. rewrite /PRQ [LHS]Pr_set1 fdistACE /= mc; congr (_ * _). - rewrite /jcPr {2}/QP fdistX2 -/P Pr_set1 mulRCA mulRV ?mulR1; last first. + rewrite /jcPr {2}/QP fdistX2 -/P Pr_set1 mulrCA mulfV ?mulr1; last first. apply dom_by_fdist_fstN with b. apply dom_by_fdist_fstN with c. by rewrite fdistACE in H0. by rewrite /QP Pr_fdistX setX1. -rewrite {1}/Rdiv -mulRA mulRCA mulRC; congr (_ * _). - rewrite /jcPr fdist_proj13_snd -/Q {2}/PRQ fdistAC2 -/Q -/(Rdiv _ _); congr (_ / _). +rewrite -mulrA mulrCA mulrC; congr (_ * _). + rewrite /jcPr fdist_proj13_snd -/Q {2}/PRQ fdistAC2 -/Q; congr (_ / _). by rewrite /PRQ /PQ setX1 fdist_proj13_AC. rewrite /jcPr fdist_proj23_snd; congr (_ / _). - by rewrite /RQ /PRQ /fdist_proj23 fdistA_AC_snd. @@ -1252,24 +1254,23 @@ Lemma data_processing_inequality : markov_chain -> Proof. move=> H. have H1 : mutual_info (fdistA PQR) = mutual_info PR + cond_mutual_info PQR. - rewrite /cond_mutual_info !mutual_infoE addRA; congr (_ - _). - by rewrite -/PR subRK /PR fdist_proj13_fst. + rewrite /cond_mutual_info !mutual_infoE addrA; congr (_ - _). + by rewrite -/PR subrK /PR fdist_proj13_fst. have H2 : mutual_info (fdistA PQR) = mutual_info PQ + cond_mutual_info PRQ. transitivity (mutual_info (fdistA PRQ)). by rewrite !mutual_infoE fdistA_AC_fst cond_entropy_fdistA. - rewrite /cond_mutual_info !mutual_infoE addRA; congr (_ - _). - by rewrite fdistA1 {1}/PRQ fdist_proj13_AC -/PQ subRK /PQ fdistAC_fst_fst. + rewrite /cond_mutual_info !mutual_infoE addrA; congr (_ - _). + by rewrite fdistA1 {1}/PRQ fdist_proj13_AC -/PQ subrK /PQ fdistAC_fst_fst. have H3 : cond_mutual_info PRQ = 0 by rewrite markov_cond_mutual_info. have H4 : 0 <= cond_mutual_info PQR by exact: cond_mutual_info_ge0. -move: H2; rewrite {}H3 addR0 => <-. -by rewrite {}H1 addRC -leR_subl_addr subRR. +move: H2; rewrite {}H3 addr0 => <-. +by rewrite {}H1 addrC -lerBlDr subrr. Qed. End markov_chain. Section markov_chain_prop. - -Variables (A B C : finType) (PQR : {fdist A * B * C}). +Variables (R : realType) (A B C : finType) (PQR : R.-fdist (A * B * C)). Lemma markov_chain_order : markov_chain PQR -> markov_chain (fdistC13 PQR). Proof. @@ -1280,25 +1281,27 @@ rewrite fdistC13_fst_fst. rewrite (jBayes _ [set a] [set b]). rewrite fdistXI. rewrite fdistX1 fdistX2. -rewrite (mulRC (_ a)) -mulRA. -rewrite [in RHS]mulRCA -[in RHS]mulRA. +rewrite (mulrC (_ a)) -[LHS]mulrA. +rewrite [in RHS]mulrCA -[in RHS]mulrA. congr (_ * _). by rewrite fdistA_C13_snd. rewrite (jBayes _ [set c] [set b]). rewrite fdistXI. -rewrite [in LHS]mulRCA -[in LHS]mulRA. -rewrite [in RHS](mulRC (_ c)) -[in RHS](mulRA _ (_ c)). -rewrite [in RHS]mulRCA. +rewrite [in LHS]mulrCA -[in LHS]mulrA. +rewrite [in RHS](mulrCA (_ c)). +rewrite -[in RHS]mulrA [in RHS]mulrCA. congr (_ * _). congr (\Pr_ _ [_ | _]). by rewrite fdistC13_fst fdistXI. rewrite !Pr_set1. -rewrite [in RHS]mulRCA. +rewrite [in LHS]mulrCA. +rewrite [in RHS]mulrCA. congr (_ * _). - by rewrite fdistX1 fdistA22. -congr (_ * / _). congr (_ a). by rewrite fdistA22 fdistC13_snd. +congr (_ / _). + by rewrite fdistX1 fdistA22. +congr (_ a). by rewrite fdistX2 fdistA21 fdistA_C13_snd fdistX1. Qed. @@ -1308,14 +1311,13 @@ Section Han_inequality. Local Open Scope ring_scope. -Lemma information_cant_hurt_cond (A : finType) (n' : nat) (n := n'.+1 : nat) - (P : {fdist 'rV[A]_n}) (i : 'I_n) (i0 : i != O :> nat) : +Lemma information_cant_hurt_cond (R : realType) (A : finType) (n' : nat) (n := n'.+1 : nat) + (P : R.-fdist 'rV[A]_n) (i : 'I_n) (i0 : i != O :> nat) : cond_entropy (fdist_prod_of_rV P) <= cond_entropy (fdist_prod_of_rV (fdist_take P (lift ord0 i))). Proof. -apply/RleP. -rewrite -subR_ge0. -set Q : {fdist A * 'rV[A]_i * 'rV[A]_(n' - i)} := fdist_take_drop P i. +rewrite -subr_ge0. +set Q : R.-fdist (A * 'rV[A]_i * 'rV[A]_(n' - i)) := fdist_take_drop P i. have H1 : fdist_proj13 (fdistAC Q) = fdist_prod_of_rV (fdist_take P (lift ord0 i)). rewrite /fdist_proj13 /fdistAC /fdist_prod_of_rV /fdist_take /fdist_snd /fdistA. rewrite /fdistC12 /fdistX /fdist_take_drop !fdistmap_comp; congr (fdistmap _ P). @@ -1362,8 +1364,8 @@ rewrite (_ : _ - _ = cond_mutual_info (fdistAC Q))%R; last by rewrite /cond_mutu exact/cond_mutual_info_ge0. Qed. -Lemma han_helper (A : finType) (n' : nat) (n := n'.+1 : nat) - (P : {fdist 'rV[A]_n}) (i : 'I_n) (i0 : i != O :> nat) : +Lemma han_helper (R : realType) (A : finType) (n' : nat) (n := n'.+1 : nat) + (P : R.-fdist 'rV[A]_n) (i : 'I_n) (i0 : i != O :> nat) : cond_entropy (fdist_prod_of_rV (fdist_perm P (put_front_perm i))) <= cond_entropy (fdistX (fdist_belast_last_of_rV (fdist_take P (lift ord0 i)))). Proof. @@ -1373,11 +1375,11 @@ rewrite (_ : fdistX _ = fdist_prod_of_rV (fdist_perm rewrite fdistXE fdist_belast_last_of_rVE fdist_prod_of_rVE /= fdist_permE. rewrite !(fdist_takeE _ (lift ord0 i)); apply eq_bigr => /= w _; congr (P _); apply/rowP => k. rewrite !castmxE /= cast_ord_id. - case/boolP : (k < i.+1)%nat => ki. + have [ki|ki] := ltnP k i.+1. have @k1 : 'I_i.+1 := Ordinal ki. rewrite (_ : cast_ord _ k = lshift (n - bump 0 i) k1); last exact/val_inj. rewrite 2!row_mxEl castmxE /= cast_ord_id [in RHS]mxE. - case/boolP : (k < i)%nat => [ki'|]. + have [ki'|] := ltnP k i. rewrite (_ : cast_ord _ _ = lshift 1%nat (Ordinal ki')) /=; last exact/val_inj. rewrite row_mxEl /put_front_perm permE /put_front ifF; last first. apply/negbTE/eqP => /(congr1 val) /=. @@ -1385,15 +1387,13 @@ rewrite (_ : fdistX _ = fdist_prod_of_rV (fdist_perm rewrite inordK //= ki' (_ : inord k.+1 = rshift 1%nat (Ordinal ki')); last first. by apply/val_inj => /=; rewrite inordK. by rewrite (@row_mxEr _ 1%nat 1%nat). - rewrite permE /put_front. - rewrite -leqNgt leq_eqVlt => /orP[|] ik. + rewrite permE /put_front leq_eqVlt => /orP[|] ik. rewrite ifT; last first. apply/eqP/val_inj => /=; rewrite inordK //; exact/esym/eqP. rewrite row_mx_row_ord0 (_ : cast_ord _ _ = rshift i ord0); last first. by apply val_inj => /=; rewrite addn0; apply/esym/eqP. by rewrite row_mxEr mxE. - move: (leq_ltn_trans ik ki); by rewrite ltnn. - rewrite -ltnNge ltnS in ki. + by move: (leq_ltn_trans ik ki); rewrite ltnn. move=> [:Hk1]. have @k1 : 'I_(n - bump 0 i). apply: (@Ordinal _ (k - i.+1)). @@ -1407,18 +1407,18 @@ rewrite (_ : fdist_perm (fdist_take _ _) _ = rewrite fdist_permE 2!(fdist_takeE _ (lift ord0 i)); apply eq_bigr => /= v _. rewrite fdist_permE; congr (P _); apply/rowP => /= k. rewrite /col_perm mxE !castmxE /= !cast_ord_id /=. - case/boolP : (k < bump 0 i)%nat => ki. + have [ki|ki] := ltnP k (bump 0 i). rewrite (_ : cast_ord _ _ = lshift (n - bump 0 i) (Ordinal ki)); last exact/val_inj. rewrite row_mxEl mxE /put_front_perm !permE /= /put_front /=. - case/boolP : (k == i) => ik. + have [ik|ik] := eqVneq k i. rewrite ifT; last first. - apply/eqP/val_inj => /=; rewrite inordK //; exact/eqP. + by apply/eqP/val_inj => //=; rewrite ik inordK. rewrite (_ : cast_ord _ _ = lshift (n - bump 0 i) ord0); last exact/val_inj. by rewrite row_mxEl. rewrite ifF; last first. apply/negbTE/eqP => /(congr1 val) /=. - apply/eqP; by rewrite inordK. - case/boolP : (k < i)%nat => {}ik. + by apply/eqP;rewrite inordK. + have [{}ik|{}ik] := ltnP k i. rewrite inordK // ik. move=> [:Hk1]. have @k1 : 'I_(bump 0 i). @@ -1430,13 +1430,12 @@ rewrite (_ : fdist_perm (fdist_take _ _) _ = by rewrite (leq_trans ik) // -ltnS. rewrite row_mxEl; congr (w _ _). by apply val_inj => /=; rewrite inordK. - rewrite -ltnNge in ik. rewrite ifF; last first. apply/negbTE. by rewrite -leqNgt -ltnS inordK. rewrite (_ : cast_ord _ _ = lshift (n - bump 0 i) (Ordinal ki)); last exact/val_inj. by rewrite row_mxEl. - rewrite -ltnNge /bump leq0n add1n ltnS in ki. + rewrite /bump leq0n add1n in ki. move=> [:Hk1]. have @k1 : 'I_(n - bump 0 i). apply: (@Ordinal _ (k - i.+1)). @@ -1457,25 +1456,25 @@ rewrite (_ : fdist_perm (fdist_take _ _) _ = exact/information_cant_hurt_cond. Qed. -Variables (A : finType) (n' : nat). +Variables (R : realType) (A : finType) (n' : nat). Let n := n'.+1. -Variable P : {fdist 'rV[A]_n}. +Variable P : R.-fdist 'rV[A]_n. Lemma han : n.-1%:R * `H P <= \sum_(i < n) `H (fdist_col' P i). Proof. -rewrite -subn1 natrB // -RmultE mulRBl mul1R. -apply/RleP; rewrite leR_subl_addr {2}(chain_rule_rV P). +rewrite -subn1 natrB // mulrBl mul1r. +rewrite lerBlDr {2}(chain_rule_rV P). rewrite -big_split /= -{1}(card_ord n) -sum1_card. -rewrite -INRE big_morph_natRD big_distrl /=. -apply leR_sumR => i _; rewrite mul1R. +rewrite natr_sum big_distrl /=. +apply ler_sum => i _; rewrite mul1r. case: ifPn => [/eqP|] i0. rewrite (_ : i = ord0); last exact/val_inj. rewrite -tail_of_fdist_rV_fdist_col' /tail_of_fdist_rV /head_of_fdist_rV. rewrite -{1}(fdist_rV_of_prodK P) entropy_fdist_rV_of_prod. move: (chain_rule (fdist_prod_of_rV P)); rewrite /joint_entropy => ->. - by rewrite [in X in (_ <= X)%R]addRC leR_add2l -fdistX1; exact: information_cant_hurt. -rewrite (chain_rule_multivar _ i0) leR_add2l. -by apply/RleP; exact/han_helper. + by rewrite [in X in (_ <= X)%R]addrC lerD2l -fdistX1; exact: information_cant_hurt. +rewrite (chain_rule_multivar _ i0) lerD2l. +exact/han_helper. Qed. End Han_inequality. diff --git a/information_theory/entropy_convex.v b/information_theory/entropy_convex.v index b9df3c49..c4fcd3c8 100644 --- a/information_theory/entropy_convex.v +++ b/information_theory/entropy_convex.v @@ -1,13 +1,15 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From HB Require Import structures. -From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. +From mathcomp Require Import all_ssreflect ssralg ssrnum matrix interval. +From mathcomp Require Import ring. From mathcomp Require boolp. -From mathcomp Require Import mathcomp_extra Rstruct reals. -Require Import Reals Ranalysis_ext Lra. -Require Import ssrR Reals_ext realType_ext logb ssr_ext ssralg_ext bigop_ext. -Require Import fdist jfdist_cond entropy convex binary_entropy_function. -Require Import log_sum divergence. +From mathcomp Require Import mathcomp_extra Rstruct reals set_interval. +From mathcomp Require Import functions topology normedtype realfun derive exp. +From mathcomp Require convex. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln. +Require Import derive_ext fdist jfdist_cond entropy convex. +Require Import binary_entropy_function log_sum divergence. (******************************************************************************) (* Section 2.7 of Elements of Information Theory *) @@ -40,16 +42,40 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. +Local Open Scope ring_scope. Local Open Scope reals_ext_scope. Local Open Scope fdist_scope. Local Open Scope convex_scope. Local Open Scope entropy_scope. Import Order.POrderTheory GRing.Theory Num.Theory. +Import numFieldTopology.Exports. +Import numFieldNormedType.Exports. + +Local Notation "{ 'fdist' T }" := (_ .-fdist T) : fdist_scope. + +Section analysis_ext. +Import boolp classical_sets. + +(* +Lemma near_eq_cvg_to (U : nbhsType) (T : Type) (F : set_system T) + (f g : T -> U) (x : U) : + Filter F -> + (\near F, f F = g F) -> + (fmap f F --> x)%classic = (fmap g F --> x)%classic. +Proof. +move=> FF nfg. +suff-> : (f x @[x --> F] = g x @[x --> F])%classic. by []. +rewrite eqEsubset; split; apply: near_eq_cvg=> //. +by move/filterS: nfg; apply=> ?; exact: fsym. +Qed. +Arguments near_eq_cvg_to [U T F]. +*) +End analysis_ext. Section entropy_log_div. -Variables (A : finType) (p : {fdist A}) (n : nat) (An1 : #|A| = n.+1). +Variable R : realType. +Variables (A : finType) (p : R.-fdist A) (n : nat) (An1 : #|A| = n.+1). Let u := @fdist_uniform R _ _ An1. Local Open Scope divergence_scope. @@ -59,29 +85,25 @@ Proof. rewrite /entropy /div. evar (RHS : A -> R). have H a : p a * log (p a / u a) = RHS a. - have /RleP[H|H] := FDist.ge0 p a. - - rewrite fdist_uniformE. - change (p a * log (p a / / #|A|%:R)) with (p a * log (p a * / / #|A|%:R)). - have H0 : 0 < #|A|%:R by rewrite An1 ltR0n. - have /eqP H1 : #|A|%:R <> 0 by apply/eqP/gtR_eqF. - rewrite -RinvE An1 /Rdiv invRK// logM //; last first. - by rewrite -INRE ltR0n. - rewrite mulRDr -INRE. - rewrite -An1. + have:= FDist.ge0 p a. + rewrite le_eqVlt=> /orP [/eqP H|H]; last first. + - rewrite fdist_uniformE invrK logM//; last by rewrite An1. + rewrite mulrDr. by instantiate (RHS := fun a => p a * log (p a) + p a * log #|A|%:R). - - by rewrite /RHS -H /= 3!mul0R add0R. + - by rewrite /RHS -H /= 3!mul0r add0r. have -> : \sum_(a in A) p a * log (p a / u a) = \sum_(a in A) RHS a. by move : H; rewrite /RHS => H; exact: eq_bigr. -rewrite /RHS big_split /= -big_distrl /= (FDist.f1 p) mul1R. -by rewrite -addR_opp oppRD addRC -addRA Rplus_opp_l addR0. +rewrite /RHS big_split /= -big_distrl /= (FDist.f1 p) mul1r. +by rewrite opprD addrC -addrA addNr addr0. Qed. End entropy_log_div. Section dominated_pair. +Variable R : realType. Variable A : finType. Implicit Types p q : {prob R}. -Definition dom_pair := {d : {fdist A} * {fdist A} | d.1 `<< d.2}. +Definition dom_pair := {d : R.-fdist A * {fdist A} | d.1 `<< d.2}. (* TODO: wouldn't be needed if dominates were on bool *) HB.instance Definition _ := boolp.gen_eqMixin dom_pair. @@ -92,11 +114,11 @@ Lemma dom_conv p (x y u v : {fdist A}) : Proof. move=> /dominatesP xy /dominatesP uv; apply/dominatesP => a. rewrite !fdist_convE. -rewrite paddR_eq0; [|exact/mulR_ge0 |exact/mulR_ge0]. -rewrite !mulR_eq0 => -[[->|/xy ->]]; last first. - by rewrite -RplusE -!RmultE mulR0 add0R => -[->|/uv ->]; rewrite !(mul0R,mulR0). -by rewrite -RplusE -!RmultE mul0R add0R => -[|/uv ->]; - [rewrite onem0 => /R1_neq_R0 | rewrite mulR0]. +move/eqP; rewrite paddr_eq0; [|exact/mulr_ge0 |exact/mulr_ge0]. +rewrite !mulf_eq0=> /andP [/orP [/eqP ->|/eqP /xy ->]]. + rewrite onem0 (negPf (oner_neq0 _)) /= => /eqP /uv ->. + by rewrite mul0r mulr0 addr0. +by case/orP=> [/eqP -> | /eqP /uv ->]; rewrite ?(mul0r, mulr0, addr0). Qed. Definition avg_dom_pair p (x y : dom_pair) : dom_pair := @@ -106,7 +128,8 @@ Definition avg_dom_pair p (x y : dom_pair) : dom_pair := let d_dom_c := proj2_sig y in exist _ (ab <| p |> cd) (dom_conv p b_dom_a d_dom_c). -Definition uncurry_dom_pair U (f : {fdist A} -> {fdist A} -> U) (x : dom_pair) := +Definition uncurry_dom_pair + U (f : {fdist A} -> {fdist A} -> U) (x : dom_pair) : U^o := f (sval x).1 (sval x).2. Let avg := avg_dom_pair. @@ -124,69 +147,66 @@ Let avgA p q x y z : avg p x (avg q y z) = avg [s_of p, q] (avg [r_of p, q] x y) z. Proof. by rewrite /avg /=; exact/boolp.eq_exist/convA. Qed. -HB.instance Definition _ := @isConvexSpace.Build dom_pair +HB.instance Definition _ := @isConvexSpace.Build R dom_pair avg avg1 avgI avgC avgA. End dominated_pair. Section divergence_convex. Local Open Scope divergence_scope. +Variable R : realType. Variables A : finType. -Lemma convex_div : convex_function (uncurry_dom_pair (@div A)). +Lemma convex_div : convex_function (uncurry_dom_pair (@div R A)). Proof. move=> [x Hx] [y Hy] p /=; rewrite /uncurry_dom_pair /=. rewrite /convex_function_at/= avgRE 2!big_distrr /= -big_split /= /div. -apply leR_sumR => a _; rewrite 2!fdist_convE. +have [->|p0] := eqVneq p 0%:pr. + apply/eqW/eq_bigr=> a _ /=. + by rewrite !conv0 mul0r add0r onem0 mul1r. +have [/onem_eq0 /val_inj ->|t0] := eqVneq (Prob.p p).~ 0. + apply/eqW/eq_bigr=> a _ /=. + by rewrite !conv1 mul1r onem1 mul0r addr0. +have quv (q u v : R) : q != 0 -> q * u / (q * v) = u / v. + by move=> ?; rewrite invfM mulrACA divff// mul1r. +apply ler_sum => a _; rewrite 2!fdist_convE. have [y2a0|y2a0] := eqVneq (y.2 a) 0. rewrite y2a0 (_ : y.1 a = 0) ?(mulR0,addR0,mul0R); last first. by move/dominatesP : Hy; exact. have [x2a0|x2a0] := eqVneq (x.2 a) 0. rewrite (_ : x.1 a = 0). - by rewrite -!RmultE -!RplusE ?(mul0R,mulR0,addR0). + by rewrite ?(mul0r,mulr0,addr0). exact/((dominatesP _ _).1 Hx). - have [p0|p0] := eqVneq p 0%:pr. - by rewrite p0 -!RmultE -!RplusE ?(mul0R,mulR0,addR0). - apply/Req_le; rewrite -!RmultE -!RplusE mulRA ?(mulR0,addR0); congr (_ * _ * log _). - set u := x.1 a. - set v := x.2 a. - by field; split; exact/eqP. + apply/eqW; rewrite !mulrA !(mul0r,mulr0,addr0); congr (_ * _ * ln _ * _). + by rewrite quv. have [x2a0|x2a0] := eqVneq (x.2 a) 0. - rewrite x2a0 (_ : x.1 a = 0)// -?RplusE -?RmultE ?(mulR0,add0R,mul0R); last first. + rewrite x2a0 (_ : x.1 a = 0)// ?(mulR0,add0R,mul0R); last first. by move/dominatesP : Hx; exact. - have [->|t0] := eqVneq (Prob.p p).~ 0; first by rewrite !mul0R. - apply/Req_le; rewrite mulRA; congr (_ * _ * log _). - set u := y.1 a. - set v := y.2 a. - by field; split; exact/eqP. + apply/eqW; rewrite !(mulrA, mulr0, mul0r, add0r); congr (_ * _ * ln _ * _). + by rewrite quv. set h : {fdist A} -> {fdist A} -> {ffun 'I_2 -> R} := fun p1 p2 => [ffun i => [eta (fun=> 0) with ord0 |-> Prob.p p * p1 a, lift ord0 ord0 |-> (Prob.p p).~ * p2 a] i]. have hdom : h x.1 y.1 `<< h x.2 y.2. - apply/dominatesP => i; rewrite /h /= !ffunE; case: ifPn => _. - by rewrite mulR_eq0 => -[->|/eqP]; [rewrite mul0R | rewrite (negbTE x2a0)]. + apply/dominatesP => i; rewrite /h /= !ffunE; case: ifPn => _ /eqP. + by rewrite mulf_eq0 (negPf x2a0) orbF => /eqP ->; rewrite mul0r. case: ifPn => // _. - by rewrite mulR_eq0 => -[->|/eqP]; [rewrite mul0R | rewrite (negbTE y2a0)]. -have h0 p1 p2 : [forall i, (0 <= h p1 p2 i)%mcR]. - apply/forallPP; first by move=> ?; exact/RleP. - move=> ?; rewrite /h /= ffunE. - case: ifPn => [_ | _]; first exact/mulR_ge0. - case: ifPn => [_ |//]. - by apply/mulR_ge0 => //; exact/onem_ge0/prob_le1. -have h01 (x0 : 'I_2) : 0 <= mkNNFinfun (h0 x.1 y.1) x0. - rewrite /= /h ffunE/=; case: ifPn => _; first exact: mulR_ge0. - by case: ifPn => // _; exact: mulR_ge0. -have h02 (x0 : 'I_2) : 0 <= mkNNFinfun (h0 x.2 y.2) x0. - rewrite /= /h ffunE/=; case: ifPn => _; first exact: mulR_ge0. - by case: ifPn => // _; exact: mulR_ge0. -have := log_sum setT (mkNNFinfun (h0 x.1 y.1)) (mkNNFinfun (h0 x.2 y.2)) h01 h02 hdom. -rewrite /= -!sumR_ord_setT !big_ord_recl !big_ord0 !addR0. -rewrite /h /= !ffunE => /leR_trans; apply. -rewrite !eqxx eq_sym (negbTE (neq_lift ord0 ord0)) -!mulRA; apply/Req_le. -congr (_ + _ ). - have [->|t0] := eqVneq p 0%:pr; first by rewrite !mul0R. - by congr (_ * (_ * log _)); field; split; exact/eqP. -have [->|t1] := eqVneq (Prob.p p).~ 0; first by rewrite !mul0R. -by congr (_ * (_ * log _)); field; split; exact/eqP. + by rewrite mulf_eq0 (negPf y2a0) orbF => /eqP ->; rewrite mul0r. +have h0 p1 p2 : [forall i, 0 <= h p1 p2 i]. + apply/forallP=> ?; rewrite /h /= ffunE. + case: ifPn => [_ | _]; first exact/mulr_ge0. + case: ifPn => [_ |]; last by move=>*; exact: lexx. + by apply/mulr_ge0 => //; exact/onem_ge0/prob_le1. +have h01 (x0 : 'I_2) : 0 <= h x.1 y.1 x0. + rewrite /= /h ffunE/=; case: ifPn => _; first exact: mulr_ge0. + by case: ifPn => // _; exact: mulr_ge0. +have h02 (x0 : 'I_2) : 0 <= h x.2 y.2 x0. + rewrite /= /h ffunE/=; case: ifPn => _; first exact: mulr_ge0. + by case: ifPn => // _; exact: mulr_ge0. +have := @log_sum _ _ setT (h x.1 y.1) (h x.2 y.2) h01 h02 hdom. +rewrite !big_set !big_mkcond !big_ord_recl !big_ord0 /= !addr0. +rewrite /h /= !ffunE /= => /le_trans; apply. +apply/eqW; rewrite !mulrA. +by congr (_ * _ * ln _ * _ + _ * _ * ln _ * _); rewrite quv. Qed. Lemma convex_relative_entropy (p1 p2 q1 q2 : {fdist A}) (r : {prob R}) : @@ -194,26 +214,25 @@ Lemma convex_relative_entropy (p1 p2 q1 q2 : {fdist A}) (r : {prob R}) : D(p1 <| r |> p2 || q1 <| r |> q2) <= D(p1 || q1) <| r |> D(p2 || q2). Proof. move=> pq1 pq2. -exact: (convex_div (exist _ (p1, q1) pq1) (exist _ (p2, q2) pq2)). +exact/(convex_div (exist _ (p1, q1) pq1) (exist _ (p2, q2) pq2)). Qed. End divergence_convex. Section entropy_concave. Local Open Scope divergence_scope. +Variable R : realType. Variable A : finType. Hypothesis cardA_gt0 : (0 < #|A|)%nat. Let cardApredS : #|A| = #|A|.-1.+1. Proof. by rewrite prednK. Qed. -Lemma entropy_concave : concave_function (fun P : {fdist A} => `H P). +Lemma entropy_concave : concave_function (fun P : R.-fdist A => `H P). Proof. apply RNconcave_function => p q t; rewrite /convex_function_at. -rewrite !(entropy_log_div _ cardApredS) /= /leconv /= [in X in _ <= X]avgRE. -rewrite oppRD oppRK 2!mulRN mulRDr mulRN mulRDr mulRN oppRD oppRK oppRD oppRK. -rewrite addRCA !addRA -2!mulRN -mulRDl (addRC _ (Prob.p t)). -rewrite !RplusE onemKC mul1R -!RplusE -addRA leR_add2l. +rewrite !(entropy_log_div _ cardApredS) [in X in _ <= X]avgRE. +rewrite !opprD !mulrDr addrACA -mulrDl add_onemK mul1r lerD ?lexx// !opprK. have := convex_relative_entropy t (dom_by_uniform p cardApredS) (dom_by_uniform q cardApredS). by rewrite convmm. @@ -221,139 +240,206 @@ Qed. End entropy_concave. +(* +Lemma unitiE (R : realType) (x : R) : uniti x = (0 < x < 1). +Proof. by []. Qed. +*) + Module entropy_concave_alternative_proof_binary_case. +Import classical_sets. + +Section realType. -Lemma pderivable_H2 : pderivable H2 uniti. +Variable R : realType. +Local Notation H2 := (@H2 R^o : R^o -> R^o). + +Definition sig_derive1_H2 (x : R) : + {D : R | x \in `]0, 1[%classic -> is_derive x 1 H2 D}. Proof. -move=> x /= [Hx0 Hx1]. -apply derivable_pt_plus. -apply derivable_pt_opp. -apply derivable_pt_mult; [apply derivable_pt_id|apply derivable_pt_Log]. -assumption. -apply derivable_pt_opp. -apply derivable_pt_mult. -apply derivable_pt_Rminus. -apply derivable_pt_comp. -apply derivable_pt_Rminus. -apply derivable_pt_Log. -lra. -(* NB : transparent definition is required to proceed with a forward proof, - later in concavity_of_entropy_x_le_y *) +evar (D0 : (R : Type)); evar (D1 : (R : Type)); exists D0. +rewrite inE /= => /andP [] x0 x1. +suff->: D0 = D1. + rewrite /H2. + apply: is_deriveD. + apply: is_deriveN. + apply: is_deriveM. + exact: is_derive_id. + exact: is_derive1_Logf. + apply: is_deriveN. + apply: is_deriveM. + apply: is_derive1_comp. + apply: is_derive1_Logf=> //. + by rewrite subr_gt0 //. +have ? : x != 0 by exact: lt0r_neq0. +have ? : 1 - x != 0 by rewrite lt0r_neq0// subr_gt0. +rewrite /D1. +rewrite -!mulr_regl !(add0r, mul1r, mulr1, mulrN, mulNr, opprD, opprK). +rewrite mulrCA divff// mulrCA divff//. +rewrite !mulr1 addrCA !addrA subrr add0r addrC. +by instantiate (D0 := log (1 - x) - log x). Defined. -Lemma expand_interval_closed_to_open a b c d : - a < b -> b < c -> c < d -> forall x, b <= x <= c -> a < x < d. +Definition sig_derive1_nH2 (x : R) : + {D : R | x \in `]0, 1[%classic -> is_derive x 1 (- H2) D}. Proof. -move=> ? ? ? x [? ?]; split; - [exact: (@ltR_leR_trans b)|exact: (@leR_ltR_trans c)]. +evar (D0 : (R : Type)); evar (D1 : (R : Type)); exists D0. +move/(svalP (sig_derive1_H2 x))=> is_derive1_H2. +suff->: D0 = D1. + exact: is_deriveN. +rewrite /D1 /= opprB. +by instantiate (D0 := log x - log (1 - x)). +Defined. + +Lemma derivable_nH2 v : {in `]0, 1[%classic, forall x : R, derivable (- H2) x v}. +Proof. +move=> x /(svalP (sig_derive1_nH2 x))/@ex_derive. +by move/derivable1_diffP/diff_derivable. Qed. -Lemma expand_internal_closed_to_closed a b c d : - a <= b -> b < c -> c <= d -> forall x, b <= x <= c -> a <= x <= d. +Local Notation DnH2 := (fun x : R => log x - log (1 - x)). + +Lemma DnH2E : {in `]0, 1[%classic, forall x : R, 'D_1 (- H2) x = DnH2 x}. +Proof. by move=> x /(svalP (sig_derive1_nH2 x))/@derive_val. Qed. + +Lemma near_DnH2E : + {in `]0, 1[%classic, forall x : R, \near x, 'D_1 (- H2) x = DnH2 x}. Proof. -move=> ? ? ? ? [? ?]; split; [exact: (@leR_trans b)|exact: (@leR_trans c)]. +apply: open_in_nearW; first exact: (@itv_open _ (R : realFieldType)). +exact: DnH2E. Qed. -Lemma expand_interval_open_to_open a b c d : - a < b -> b < c -> c < d -> forall x, b < x < c -> a < x < d. +Definition sig_derive1_DnH2 (x : R) : + {D : R | x \in `]0, 1[%classic -> is_derive x 1 ('D_1 (- H2)) D}. Proof. -move=> ? ? ? x [? ?]; split; [exact: (@ltR_trans b)|exact: (@ltR_trans c)]. +evar (D0 : (R : Type)); evar (D1 : (R : Type)); exists D0. +move/[dup]=> x01. +rewrite inE /= => /andP [] x0 x1. +rewrite (near_eq_is_derive _ DnH2) ?oner_neq0//; last exact: near_DnH2E. +suff->: D0 = D1. + apply: is_deriveB. + exact: is_derive1_Logf. + apply: is_derive1_Logf=> //. + by rewrite subr_gt0. +have ? : x != 0 by exact: lt0r_neq0. +have ? : 1 - x != 0 by rewrite lt0r_neq0// subr_gt0. +rewrite /D1. +rewrite !(add0r, mul1r, mulr1, mulrN, mulNr) opprK -mulrDr. +by instantiate (D0 := (ln 2)^-1 * (x^-1 + (1 - x)^-1)). +Defined. + +Local Notation DDnH2 := (fun x : R => (ln 2)^-1 * (x^-1 + (1 - x)^-1)). + +Lemma DDnH2E : {in `]0, 1[%classic, forall x : R, 'D_1 ('D_1 (- H2)) x = DDnH2 x}. +Proof. by move=> x /(svalP (sig_derive1_DnH2 x))/@derive_val. Qed. + +Lemma DDnH2_nonneg : {in `]0, 1[%classic, forall x : R, 0 <= DDnH2 x}. +Proof. +move=> x; rewrite inE /= => /andP [] x0 x1. +rewrite mulr_ge0//. + by rewrite invr_ge0 ln2_ge0. +by rewrite addr_ge0// invr_ge0 ltW // subr_gt0. +Qed. + +Lemma derivable_DnH2 v : {in `]0, 1[%classic, forall x : R, derivable ('D_1 (- H2)) x v}. +Proof. +move=> x /(svalP (sig_derive1_DnH2 x))/@ex_derive. +by move/derivable1_diffP/diff_derivable. +Qed. + +(* move to analysis *) +Lemma continuous_id (T : topologicalType) : continuous (@idfun T). +Proof. exact/continuousP. Qed. + +Lemma continuous_log (x : R) : 0 < x -> {for x, continuous log}. +Proof. by move=> x0 y; exact/differentiable_continuous/differentiable_Log. Qed. + +Lemma continuous_onem : continuous (@onem R). +Proof. +move=> ?; by apply: continuousB; [exact: cst_continuous | exact: continuous_id]. +Qed. + +Lemma continuous_H2 : {in `]0, 1[%classic, forall x : R, {for x, continuous H2}}. +Proof. +move=> x /(svalP (sig_derive1_H2 x)) /@ex_derive. +by move/derivable1_diffP/differentiable_continuous. Qed. -Lemma expand_interval_open_to_closed a b c d : - a <= b -> b < c -> c <= d -> forall x, b < x < c -> a <= x <= d. +From mathcomp Require Import -(notations) convex. + +(* TODO: introduce two notations and make two conventions more symmetric *) +Definition prob_itv (p : {prob R}) : + itv.Itv.def R `[(ssrint.Posz 0), (ssrint.Posz 1)]. +Proof. +apply (@itv.Itv.Def _ _ (p.~)). +rewrite /itv.Itv.itv_cond. +by rewrite in_itv /=; apply/andP; split. +Defined. +Lemma conv_conv (x y : R^o) (p : {prob R}) : + x <| p |> y = mathcomp.analysis.convex.conv (prob_itv p) x y. Proof. -move=> ? ? ? x [? ?]; split; - [exact/ltRW/(@leR_ltR_trans b)|exact/ltRW/(@ltR_leR_trans c)]. +by rewrite avgRE /= /conv /isConvexSpace.conv /= /conv /= -!mulr_regl onemK. Qed. Lemma concavity_of_entropy_x_le_y x y (t : {prob R}) : - uniti x -> uniti y -> x < y -> + x \in `]0, 1[%classic -> y \in `]0, 1[%classic -> x < y -> concave_function_at H2 x y t. Proof. -move=> -[H0x Hx1] [H0y Hy1] Hxy. -apply RNconcave_function_at. -set Df := fun z : R => log z - log (1 - z). -have @f_derive : pderivable (fun x0 => - H2 x0) (fun z => x <= z <= y). - move => z Hz. - exact/derivable_pt_opp/pderivable_H2/(@expand_interval_closed_to_open 0 x y 1). -have @derive_pt_f : forall z (Hz : x <= z <= y), - Df z = derive_pt (fun x1 => - H2 x1) _ (f_derive _ Hz). - move => z Hz. - rewrite derive_pt_opp. - set H := expand_interval_closed_to_open _ _ _ _. - rewrite /pderivable_H2. - case H => [H0z Hz1]. - rewrite derive_pt_plus. - rewrite 2!derive_pt_opp. - rewrite 2!derive_pt_mult. - rewrite derive_pt_id derive_pt_comp 2!derive_pt_Log /=. - rewrite mul1R mulN1R mulRN1. - rewrite [X in z * X]mulRC [X in (1 - z) * - X]mulRC mulRN 2!mulRA. - rewrite !mulRV ?gtR_eqF // ?subR_gt0 // mul1R -2!oppRD oppRK. - by rewrite [X in X + - _]addRC oppRD addRA addRC !addRA Rplus_opp_l add0R addR_opp. -have @pderivable_Df : pderivable Df (fun z => x <= z <= y). - move => z [Hxz Hzy]. - apply derivable_pt_minus. - apply derivable_pt_Log. - apply (ltR_leR_trans H0x Hxz). - apply derivable_pt_comp. - apply derivable_pt_Rminus. - apply derivable_pt_Log. - apply subR_gt0. - exact: leR_ltR_trans Hzy Hy1. -set DDf := fun z => / (z * (1 - z) * ln 2). -have derive_pt_Df : forall z (Hz : x <= z <= y), DDf z = derive_pt Df z (pderivable_Df z Hz). - rewrite -/Df => z [Hxz Hzy]. - rewrite derive_pt_minus derive_pt_comp 2!derive_pt_Log /=. - rewrite mulRN1 -[X in _ = X]addR_opp oppRK. - rewrite -mulRDr [X in _ = X]mulRC. - have Hzn0 : z != 0 by apply/gtR_eqF/(ltR_leR_trans H0x Hxz). - have H1zn0 : 1 - z != 0. - by rewrite subR_eq0' ?gtR_eqF //; apply/leR_ltR_trans; [exact Hzy| exact Hy1]. - have Hzn0' : z <> 0 by move : Hzn0 => /eqP. - have H1zn0' : 1 - z <> 0 by move : H1zn0 => /eqP. - have /eqP Hz1zn0 : z * (1 - z) <> 0 by rewrite mulR_neq0. - have -> : / z = (1 - z) / (z * (1 - z)). - change (/ z = (1 - z) * / (z * (1 - z))). - by rewrite invRM // [X in _ = _ * X]mulRC mulRA mulRV // mul1R. - have -> : / (1 - z) = z / (z * (1 - z)). - change (/ (1 - z) = z * / (z * (1 - z))). - by rewrite invRM // mulRA mulRV // mul1R. - by rewrite -Rdiv_plus_distr -addRA Rplus_opp_l addR0 div1R -invRM // ln2_neq0. -have DDf_nonneg : forall z, x <= z <= y -> 0 <= DDf z. - move => z [Hxz Hzy]. - have Hz : 0 < z by apply /ltR_leR_trans; [exact H0x| exact Hxz]. - have H1z : 0 < 1 - z by apply /subR_gt0 /leR_ltR_trans; [exact Hzy| exact Hy1]. - by apply/or_introl/invR_gt0/mulR_gt0; [exact/mulR_gt0 | exact/ln2_gt0]. -exact: (@second_derivative_convexf_pt _ _ _ _ Df _ _ DDf). +move=> x01 y01 xy. +have zxycc01 z : z \in `[x, y]%classic -> z \in `]0, 1[%classic. + rewrite !inE. + have:= x01; rewrite inE. + move/subset_itv_oo_oc/andP=> [] /subset_itvr=> + _ => /[apply]. + have:= y01; rewrite inE. + by move/subset_itv_oo_co/andP=> [] _ /subset_itvl /[apply] z01. +have zxyoo01 z : z \in `]x, y[%classic -> z \in `]0, 1[%classic. + by move=> /[1!inE] zxy; apply: zxycc01; rewrite inE; apply/subset_itv_oo_cc. +have cnH2: {within `[x, y], continuous (- H2)}%classic. + by apply: continuous_in_subspaceT=> z /zxycc01 /continuous_H2 /continuousN. +apply/RNconcave_function_at. +rewrite /convex_function_at /=. +rewrite !conv_conv. +have:= @mathcomp.analysis.convex.second_derivative_convex R (fun z => - (H2 z)) x y. +apply. +- move=> z xzy. + have/zxyoo01 z01: z \in `]x, y[%classic by rewrite inE. + by rewrite DDnH2E// DDnH2_nonneg. +- have:= cnH2 => /(continuous_within_itvP _ xy). + by case. +- have:= cnH2 => /(continuous_within_itvP _ xy). + by case. +- move=> z; rewrite -inE => /zxyoo01 z01. + exact/derivable_nH2. +- move=> z; rewrite -inE => /zxyoo01 z01. + exact/derivable_DnH2. +- exact: ltW. Qed. Lemma concavity_of_entropy : concave_function_in uniti H2. Proof. rewrite /concave_function_in => x y t Hx Hy. apply: RNconcave_function_at. -(* wlogつかう. まず関係ない変数を戻し, *) +(* wlogをつかう. convex_function_symのためにtを戻し, *) move: t. -(* 不等号をorでつないだやつを用意して *) -have Hxy := Rtotal_order x y. -(* その不等号のひとつを固定してwlogする *) -wlog : x y Hx Hy Hxy / x < y. +(* 不等号のひとつを固定してwlogする *) +wlog : x y Hx Hy / x < y. move=> H. - case: Hxy. - by apply H => //; lra. - case => [-> t|Hxy' t]; first exact/convex_function_atxx. + (* 全順序性で場合分け *) + have [xy|] := ltrP x y; first exact: H. + (* x = y の場合はかんたん*) + rewrite le_eqVlt=> /orP [/eqP ->|yx]; first exact: convex_function_atxx. + (* 逆の場合は対称性を使う *) apply: convex_function_sym => // t0. - by apply H => //; left. -move=> Hxy' t. -by apply/R_convex_function_atN /concavity_of_entropy_x_le_y => //; apply/classical_sets.set_mem. + exact: H. +by move=> *; exact/R_convex_function_atN /concavity_of_entropy_x_le_y. Qed. +End realType. + End entropy_concave_alternative_proof_binary_case. Section mutual_information_concave. Local Open Scope fdist_scope. -Variables (A B : finType) (W : A -> {fdist B}). +Variables (R : realType) (A B : finType) (W : A -> R.-fdist B). Hypothesis B_not_empty : (0 < #|B|)%nat. Lemma mutual_information_concave : @@ -365,42 +451,42 @@ suff : concave_function suff -> : f = g by []. by rewrite boolp.funeqE => d; rewrite {}/f {}/g /= -mutual_infoE -mutual_info_sym. apply: R_concave_functionB. - have /RNconvex_function concave_H := entropy_concave B_not_empty. + have /RNconvex_function concave_H := @entropy_concave R B B_not_empty. apply: R_concave_functionN => p q t /=. rewrite /convex_function_at 3!fdistX1. - apply: leR_trans (concave_H (p `X W)`2 (q `X W)`2 t). + apply: le_trans (concave_H (p `X W)`2 (q `X W)`2 t). under eq_bigr do rewrite fdist_prod2_conv. - by apply/RleP; rewrite lexx. + by rewrite lexx. suff : affine (fun x : {fdist A} => cond_entropy (fdistX (x `X W))). - by move=> /affine_functionP[]. + by case/affine_functionP. move=> t p q. rewrite /= avgRE /cond_entropy /cond_entropy1. rewrite 2!big_distrr -big_split /=; apply eq_bigr => a _. -rewrite !fdistX2 !fdist_fstE !mulRN -oppRD; congr (- _). +rewrite !fdistX2 !fdist_fstE !mulrN -opprD; congr (- _). rewrite !big_distrr -big_split /=; apply eq_bigr => b _. rewrite !big_distrl !big_distrr -big_split /=; apply eq_bigr => b0 _. -rewrite !fdist_prodE /= fdist_convE /= !(mulRA (Prob.p t)) !(mulRA (Prob.p t).~). -rewrite -!(RmultE,RplusE). -have [Hp|/eqP Hp] := eqVneq (Prob.p t * p a) 0. +rewrite !fdist_prodE /= fdist_convE /= !(mulrA (Prob.p t)) !(mulrA (Prob.p t).~). +have [Hp|Hp] := eqVneq (Prob.p t * p a) 0. rewrite Hp ?(add0R,mul0R). have [->|/eqP Hq] := eqVneq ((Prob.p t).~ * q a) 0. - by rewrite ?(mul0R). + by rewrite ?(mul0r,add0r). rewrite jcPr_fdistX_prod /=; last first. - by rewrite fdist_convE -RplusE -!RmultE Hp add0R. - by rewrite jcPr_fdistX_prod //=; move: Hq; rewrite mulR_neq0 => -[]. + by rewrite fdist_convE Hp add0r. + rewrite !mul0r !add0r; congr (_ * _). + rewrite jcPr_fdistX_prod//; apply/eqP; move/eqP: Hq; apply: contraNN. + by move/eqP->; rewrite mulr0. have [Hq|Hq] := eqVneq ((Prob.p t).~ * q a) 0. - rewrite Hq !(mul0R,addR0). + rewrite Hq !(mul0r,addr0). rewrite jcPr_fdistX_prod; last first. - by rewrite fdist_convE -RplusE -!RmultE Hq addR0. - by rewrite jcPr_fdistX_prod //=; move: Hp; rewrite mulR_neq0 => -[]. + by rewrite fdist_convE Hq addr0; apply/eqP. + congr (_ * _). + rewrite jcPr_fdistX_prod//; apply/eqP; move: Hp; apply: contraNN. + by move/eqP->; rewrite mulr0. rewrite jcPr_fdistX_prod; last first. - by rewrite /= fdist_convE paddR_eq0; [tauto|exact/mulR_ge0|exact/mulR_ge0]. -rewrite jcPr_fdistX_prod; last by move: Hp; rewrite mulR_neq0 => -[]. -rewrite jcPr_fdistX_prod //=; last by move/eqP: Hq; rewrite mulR_neq0 => -[]. -move/eqP in Hq. -rewrite /onem -RminusE (_ : 1%mcR = 1)//. -rewrite /onem -RminusE (_ : 1%mcR = 1)// in Hq. -by rewrite -!mulRDl. + rewrite fdist_convE. + by apply/eqP; rewrite paddr_eq0// ?(negPf Hp) ?(negPf Hq)//; exact: mulr_ge0. +by rewrite !jcPr_fdistX_prod ?mulrDl//; apply/eqP; + [move: Hq | move: Hp]; apply: contraNN => /eqP ->; rewrite mulr0. Qed. End mutual_information_concave. @@ -408,10 +494,10 @@ End mutual_information_concave. Section mutual_information_convex. Local Open Scope divergence_scope. Local Open Scope fdist_scope. -Variables (A B : finType) (P : {fdist A}). +Variables (R : realType) (A B : finType) (P : R.-fdist A). Lemma mutual_information_convex : - convex_function (fun W : A -> {fdist B} => mutual_info (P `X W)). + convex_function (fun W : A -> R.-fdist B => mutual_info (P `X W)). Proof. move=> /= p1yx p2yx t. pose p1xy := P `X p1yx. @@ -434,13 +520,11 @@ have -> : qlambdaxy = q1xy <| t |> q2xy. rewrite !fdist_prodE !fdist_convE /= /q1xy /q2xy !fdist_prodE /= /p1 /plambday. rewrite !fdist_sndE !big_distrr /= -big_split /=; apply eq_bigr => a0 _. rewrite /plambdaxy /= !fdist_prodE /= /p1xy /plambdayx fdist_convE /=. - rewrite -!(RmultE,RplusE). - field. + by field. have -> : plambdaxy = p1xy <| t |> p2xy. apply/fdist_ext => -[a b]. rewrite !fdist_prodE !fdist_convE /= /p1xy /p2xy !fdist_prodE /=. - rewrite -!(RmultE,RplusE). - field. + by field. have -> : mutual_info (P `X p1yx) = D(p1xy || q1xy). rewrite mutual_infoE0 /div pair_big /=; apply: eq_bigr => -[a b] _ /=. congr (_ * log (_ / _)). @@ -450,12 +534,13 @@ have -> : mutual_info (P `X p2yx) = D(p2xy || q2xy). by congr (_ * log (_ / _)); rewrite /q2xy fdist_prodE fdist_prod1. apply: convex_relative_entropy. - apply/dominatesP => -[a b]. - rewrite /q1xy /p1xy fdist_prodE /= mulR_eq0 /p1 /p1xy => -[|]. + rewrite /q1xy /p1xy fdist_prodE /=. + move/eqP; rewrite mulf_eq0 /p1 /p1xy => /orP -[/eqP|/eqP]. by rewrite fdist_prodE => ->; rewrite /= mul0r. by rewrite fdist_sndE => /psumr_eq0P ->. - apply/dominatesP => -[a b]. - rewrite /q1xy /p1xy fdist_prodE /= mulR_eq0. - rewrite /p1 /p1xy => -[|]. + rewrite /q1xy /p1xy fdist_prodE /=. + move/eqP; rewrite mulf_eq0 /p1 /p1xy => /orP -[/eqP|/eqP]. by rewrite fdist_prodE => ->; rewrite mul0r. by rewrite fdist_sndE => /psumr_eq0P /= ->. Qed. diff --git a/information_theory/erasure_channel.v b/information_theory/erasure_channel.v index c178b5ea..229d42f0 100644 --- a/information_theory/erasure_channel.v +++ b/information_theory/erasure_channel.v @@ -3,7 +3,7 @@ From mathcomp Require Import all_ssreflect all_algebra matrix. Require Import Reals. From mathcomp Require Import mathcomp_extra Rstruct. -Require Import ssrR Reals_ext realType_ext ssr_ext ssralg_ext logb fdist. +Require Import ssr_ext ssralg_ext realType_ext realType_ln fdist. Require Import entropy binary_entropy_function channel hamming channel_code. (******************************************************************************) diff --git a/information_theory/error_exponent.v b/information_theory/error_exponent.v index 71011ce7..4dd62365 100644 --- a/information_theory/error_exponent.v +++ b/information_theory/error_exponent.v @@ -1,11 +1,11 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum. -Require Import Reals Lra. -From mathcomp Require Import Rstruct reals. -Require Import ssrR realType_ext Reals_ext Ranalysis_ext logb ln_facts. -Require Import fdist entropy channel_code channel divergence. -Require Import conditional_divergence variation_dist pinsker. +From mathcomp Require Import all_ssreflect ssralg ssrnum lra ring. +From mathcomp Require Import Rstruct reals classical_sets topology normedtype. +From mathcomp Require Import sequences exp. +Require Import ssr_ext bigop_ext realType_ext realType_ln fdist. +Require Import entropy channel_code channel divergence conditional_divergence. +Require Import variation_dist pinsker. (******************************************************************************) (* Error exponent bound *) @@ -34,89 +34,110 @@ Local Open Scope fdist_scope. Local Open Scope entropy_scope. Local Open Scope channel_scope. Local Open Scope reals_ext_scope. -Local Open Scope R_scope. +Local Open Scope ring_scope. Import Order.TTheory GRing.Theory Num.Theory. Section mutinfo_distance_bound. - +Let R := Rdefinitions.R. Variables (A B : finType) (V W : `Ch(A, B)) (P : {fdist A}). Hypothesis V_dom_by_W : P |- V << W. -Hypothesis cdiv_ub : D(V || W | P) <= (exp(-2)) ^ 2 * / 2. +Hypothesis cdiv_ub : D(V || W | P) <= (expR (-2) ^+ 2) / 2. -Let cdiv_bounds : 0 <= sqrt (2 * D(V || W | P)) <= exp (-2). +Let cdiv_bounds : 0 <= Num.sqrt (2 * D(V || W | P)) <= expR (-2). Proof. -split; first exact: sqrt_pos. -apply pow2_Rle_inv; [ exact: sqrt_pos | exact/ltRW/exp_pos | ]. -rewrite [in X in X <= _]/= mulR1 sqrt_sqrt; last first. - apply mulR_ge0; [lra | exact: cdiv_ge0]. -apply/RleP; rewrite -(@ler_pM2r _ (/ 2)); last first. - by rewrite RinvE invr_gt0// (_ : 2%coqR = 2%:R)// INRE ltr0n. -rewrite RmultE -mulrA mulrCA RinvE (_ : 2%coqR = 2%:R)// INRE. -rewrite mulfV ?mulr1 ?gt_eqF//. -by apply/RleP; rewrite -RdivE. +apply/andP; split. + by rewrite sqrtr_ge0. +rewrite -(@ler_pXn2r _ 2) ?nnegrE ?expR_ge0 ?sqrtr_ge0//. +rewrite -(@ler_pM2r _ (2^-1)) ?invr_gt0//. +rewrite sqr_sqrtr; last by rewrite mulr_ge0// cdiv_ge0. +by rewrite mulrAC divff ?mul1r// pnatr_eq0. Qed. Local Open Scope variation_distance_scope. Lemma out_entropy_dist_ub : `| `H(P `o V) - `H(P `o W) | <= - / ln 2 * #|B|%:R * - xlnx (sqrt (2 * D(V || W | P))). + (ln 2)^-1 * #|B|%:R * - xlnx (Num.sqrt (2 * D(V || W | P))). Proof. rewrite 2!xlnx_entropy. -rewrite -addR_opp -mulRN -mulRDr normRM gtR0_norm; last exact/invR_gt0/ln2_gt0. -rewrite -mulRA; apply leR_pmul2l; first exact/invR_gt0/ln2_gt0. -rewrite oppRK big_morph_oppR -big_split /=. -apply: leR_trans; first exact: leR_sumR_Rabs. -rewrite -iter_addR -big_const; apply leR_sumR => b _; rewrite addRC. +rewrite -mulrN -mulrDr normrM gtr0_norm; last first. + by rewrite invr_gt0// ln_gt0// ltr1n. +rewrite -mulrA ler_pM2l; last first. + by rewrite invr_gt0// ln_gt0// ltr1n. +rewrite opprK big_morph_oppr -big_split /=. +apply: le_trans; first exact: ler_norm_sum. +rewrite -sum1_card. +rewrite natr_sum. +rewrite [leRHS]big_distrl/=. +apply: ler_sum => b _. +rewrite mul1r. +rewrite addrC. apply: Rabs_xlnx => //. -rewrite 2!fdist_outE -addR_opp big_morph_oppR -big_split /=. -apply: leR_trans; first exact: leR_sumR_Rabs. -apply: (@leR_trans (d((P `X V), (P `X W)))). + by apply/andP; split. + by apply/andP; split. +rewrite 2!fdist_outE big_morph_oppr -big_split /=. +apply: le_trans; first exact: ler_norm_sum. +apply: (@le_trans _ _ (d((P `X V), (P `X W)))). - rewrite /var_dist /=. - apply (@leR_trans (\sum_a \sum_b `| ((P `X V)) (a, b) - ((P `X W)) (a, b) | )); last first. - by apply Req_le; rewrite pair_bigA /=; apply eq_bigr => -[]. - apply: leR_sumR => a _. - rewrite (bigD1 b) //= distRC -[X in X <= _]addR0. - rewrite 2!fdist_prodE /= !(mulrC (P a)) addR_opp. - by apply/leR_add2l/RleP/sumr_ge0 => ? _; exact/RleP/normR_ge0. + apply (@le_trans _ _ (\sum_a \sum_b `| ((P `X V)) (a, b) - ((P `X W)) (a, b) | )); last first. + by apply/eqW; rewrite pair_bigA /=; apply eq_bigr => -[]. + apply: ler_sum => a _. + rewrite (bigD1 b) //= distrC -[X in X <= _]addr0. + rewrite 2!fdist_prodE /= !(mulrC (P a)). + by rewrite lerD2l sumr_ge0//. - rewrite cdiv_is_div_joint_dist => //. - exact/Pinsker_inequality_weak/joint_dominates. + exact/Pinsker_inequality_weak/dominates_prodl. Qed. Lemma joint_entropy_dist_ub : `| `H(P , V) - `H(P , W) | <= - / ln 2 * #|A|%:R * #|B|%:R * - xlnx (sqrt (2 * D(V || W | P))). + (ln 2)^-1 * #|A|%:R * #|B|%:R * - xlnx (Num.sqrt (2 * D(V || W | P))). Proof. rewrite 2!xlnx_entropy. -rewrite -addR_opp -mulRN -mulRDr normRM gtR0_norm; last exact/invR_gt0/ln2_gt0. -rewrite -2!mulRA; apply leR_pmul2l; first exact/invR_gt0/ln2_gt0. -rewrite oppRK big_morph_oppR -big_split /=. -apply: leR_trans; first exact: leR_sumR_Rabs. -rewrite -2!iter_addR -2!big_const pair_bigA /=. -apply: leR_sumR; case => a b _; rewrite addRC /=. -apply Rabs_xlnx => //. -apply (@leR_trans (d(P `X V, P `X W))). -- rewrite /var_dist /R_dist (bigD1 (a, b)) //= distRC. - rewrite -[X in X <= _]addR0. - by apply/leR_add2l/RleP/sumr_ge0 => ? _; exact/RleP/normR_ge0. +rewrite -mulrN -mulrDr normrM gtr0_norm; last first. + by rewrite invr_gt0// ln_gt0 ?ltr1n. +rewrite -2!mulrA ler_pM2l//; last first. + by rewrite invr_gt0// ln_gt0// ltr1n. +rewrite opprK big_morph_oppr -big_split /=. +apply: le_trans; first exact: ler_norm_sum. +rewrite -(sum1_card B). +rewrite natr_sum. +rewrite [in leRHS]big_distrl/=. +under [in leRHS]eq_bigr do rewrite mul1r. +rewrite -(sum1_card A). +rewrite natr_sum. +rewrite [in leRHS]big_distrl/=. +under [in leRHS]eq_bigr do rewrite mul1r. +rewrite pair_bigA/=. +apply: ler_sum; case => a b _; rewrite addrC /=. +apply: Rabs_xlnx => //. + by rewrite FDist.ge0//=. + by rewrite FDist.ge0//=. +apply: (@le_trans _ _ (d(P `X V, P `X W))). +- by rewrite /var_dist (bigD1 (a, b)) //= distrC ler_wpDr// sumr_ge0. - rewrite cdiv_is_div_joint_dist => //. - exact/Pinsker_inequality_weak/joint_dominates. + exact/Pinsker_inequality_weak/dominates_prodl. Qed. Lemma mut_info_dist_ub : `| `I(P, V) - `I(P, W) | <= - / ln 2 * (#|B|%:R + #|A|%:R * #|B|%:R) * - xlnx (sqrt (2 * D(V || W | P))). + (ln 2)^-1 * (#|B|%:R + #|A|%:R * #|B|%:R) * + - xlnx (Num.sqrt (2 * D(V || W | P))). Proof. rewrite /mutual_info_chan. -rewrite (_ : _ - _ = `H(P `o V) - `H(P `o W) + (`H(P, W) - `H(P, V))); last by field. -apply: leR_trans; first exact: Rabs_triang. -rewrite -mulRA mulRDl mulRDr. -apply leR_add. -- by rewrite mulRA; apply out_entropy_dist_ub. -- by rewrite distRC 2!mulRA; apply joint_entropy_dist_ub. +rewrite (_ : _ - _ = + `H(P `o V) - `H(P `o W) + (`H(P, W) - `H(P, V))); last by field. +apply: le_trans; first exact: ler_normD. +rewrite -mulrA mulrDl mulrDr lerD//. +- by rewrite mulrA; apply out_entropy_dist_ub. +- by rewrite distrC 2!mulrA; apply joint_entropy_dist_ub. Qed. End mutinfo_distance_bound. +Import numFieldTopology.Exports. +Import numFieldNormedType.Exports. + Section error_exponent_lower_bound. +Let R := Rdefinitions.R. Variables A B : finType. Hypothesis Bnot0 : (0 < #|B|)%nat. Variables (W : `Ch(A, B)) (minRate : R). @@ -129,83 +150,96 @@ Lemma error_exponent_bound : exists Delta, 0 < Delta /\ P |- V << W -> Delta <= D(V || W | P) + +| minRate - `I(P, V) |. Proof. -set gamma := / (#|B|%:R + #|A|%:R * #|B|%:R) * (ln 2 * ((minRate - capacity W) / 2)). -have : min(exp (-2), gamma) > 0. - apply Rmin_Rgt_r; split; apply Rlt_gt; first exact: exp_pos. - apply mulR_gt0. - - by apply/invR_gt0/addR_gt0wl; [exact/ltR0n | apply/mulR_ge0; exact/leR0n]. - - by apply mulR_gt0 => //; apply mulR_gt0; [rewrite subR_gt0|exact:invR_gt0]. -move/(continue_xlnx 0) => [] /= mu [mu_gt0 mu_cond]. -set x := min(mu / 2, exp (-2)). -have x_gt0 : 0 < x. - by apply: Rmin_pos; [apply: mulR_gt0 => //; exact: invR_gt0|exact: exp_pos]. -have /mu_cond : D_x no_cond 0 x /\ R_dist x 0 < mu. - split. - - by split => //; exact/eqP/ltR_eqF. - - rewrite /R_dist subR0 gtR0_norm // /x. - apply (@leR_ltR_trans (mu * / 2)); first exact/geR_minl. - by rewrite ltR_pdivr_mulr //; lra. -rewrite /R_dist {2}/xlnx ltxx subR0 ltR0_norm; last first. - apply xlnx_neg; split => //; rewrite /x. - exact: leR_ltR_trans (geR_minr _ _) ltRinve21. -move=> Hx. -set Delta := min((minRate - capacity W) / 2, x ^ 2 / 2). +set gamma := + (#|B|%:R + #|A|%:R * #|B|%:R)^-1 * (ln 2 * ((minRate - capacity W) / 2)). +rewrite /=. +have := @continuous_at_xlnx R 0 => /cvgrPdist_lt. +have : Num.min (expR (-2)) gamma > 0. + rewrite lt_min expR_gt0/= mulr_gt0//. + - by rewrite invr_gt0// ltr_wpDr ?ltr0n// mulr_ge0. + - by rewrite mulr_gt0// ?ln2_gt0// divr_gt0// subr_gt0. +move=> /[swap] /[apply] -[]/= mu mu_gt0 mu_cond. +set x : R := Num.min (mu / 2) (expR (-2)). +have x_gt0 : 0 < x by rewrite lt_min expR_gt0 andbT divr_gt0. +have xmu : x < mu. + by rewrite gt_min ltr_pdivrMr// ltr_pMr// ltr1n. +set Delta := Num.min ((minRate - capacity W) / 2) (x ^+ 2 / 2). exists Delta; split. - apply Rmin_case. - - by apply mulR_gt0; [exact/subR_gt0 | exact/invR_gt0]. - - by apply mulR_gt0; [exact: expR_gt0 | exact: invR_gt0]. + rewrite lt_min; apply/andP; split. + - by rewrite divr_gt0// subr_gt0//. + - by rewrite divr_gt0// exprn_gt0//. move=> P V v_dom_by_w. -case/boolP : (Delta <= D(V || W | P))%mcR => [/RleP| /RleP/ltRNge] Hcase. - apply (@leR_trans (D(V || W | P))) => //. - by rewrite -{1}(addR0 (D(V || W | P))); exact/leR_add2l/leR_maxl. +have [Hcase|Hcase] := leP Delta (D(V || W | P)). + apply: (@le_trans _ _ (D(V || W | P))) => //. + by rewrite ler_wpDr// le_max lexx. suff HminRate : (minRate - capacity W) / 2 <= minRate - (`I(P, V)). clear -Hcase v_dom_by_w HminRate. - apply (@leR_trans +| minRate - `I(P, V) |); last first. - by rewrite -[X in X <= _]add0R; exact/leR_add2r/cdiv_ge0. - apply: leR_trans; last exact: leR_maxr. - by apply: (leR_trans _ HminRate); exact: geR_minl. -have : `I(P, V) <= capacity W + / ln 2 * (#|B|%:R + #|A|%:R * #|B|%:R) * - (- xlnx (sqrt (2 * D(V || W | P)))). - apply (@leR_trans (`I(P, W) + / ln 2 * (#|B|%:R + #|A|%:R * #|B|%:R) * - - xlnx (sqrt (2 * D(V || W | P))))); last first. - apply/leR_add2r/Rstruct.RleP/Rstruct.Rsup_ub; last by exists P. + apply (@le_trans _ _ +| minRate - `I(P, V) |); last first. + by rewrite ler_wpDl// cdiv_ge0. + rewrite le_max; apply/orP; right. + by rewrite (le_trans _ HminRate)// ge_min lexx. +have : `I(P, V) <= capacity W + (ln 2)^-1 * (#|B|%:R + #|A|%:R * #|B|%:R) * + (- xlnx (Num.sqrt (2 * D(V || W | P)))). + apply (@le_trans _ _ (`I(P, W) + (ln 2)^-1 * (#|B|%:R + #|A|%:R * #|B|%:R) * + - xlnx (Num.sqrt (2 * D(V || W | P))))); last first. + rewrite lerD2r//. + apply/Rsup_ub; last exists P => //. split; first by exists (`I(P, W)), P. case: set_of_I_has_ubound => y Hy. by exists y => _ [Q _ <-]; apply Hy; exists Q. - rewrite addRC -leR_subl_addr. - apply (@leR_trans `| `I(P, V) + - `I(P, W) |); first exact: Rle_abs. - suff : D(V || W | P) <= exp (-2) ^ 2 * / 2 by apply mut_info_dist_ub. + rewrite addrC -lerBlDr. + apply (@le_trans _ _ `| `I(P, V) + - `I(P, W) |). + by rewrite ler_norm. + suff : D(V || W | P) <= expR (-2) ^+ 2 / 2 by apply mut_info_dist_ub. clear -Hcase x_gt0. - apply/ltRW/(ltR_leR_trans Hcase). - apply (@leR_trans (x ^ 2 * / 2)); first exact: geR_minr. - apply leR_wpmul2r; first exact/invR_ge0. - by apply pow_incr; split; [exact: ltRW | exact: geR_minr]. -rewrite -[X in _ <= X]oppRK => /leR_oppr/(@leR_add2l minRate). -move/(leR_trans _); apply. -suff x_gamma : - xlnx (sqrt (2 * (D(V || W | P)))) <= gamma. - rewrite oppRD addRA addRC -leR_subl_addr. - rewrite [X in X <= _](_ : _ = - ((minRate + - capacity W) / 2)); last by field. - rewrite leR_oppr oppRK -mulRA mulRC. - rewrite leR_pdivr_mulr // mulRC -leR_pdivl_mulr; last first. - by apply addR_gt0wl; [exact/ltR0n|rewrite -natRM; exact/leR0n]. - by rewrite [in X in _ <= X]mulRC /Rdiv (mulRC _ (/ (_ + _))). -suff x_D : xlnx x <= xlnx (sqrt (2 * (D(V || W | P)))). - clear -Hx x_D. - rewrite leR_oppl; apply (@leR_trans (xlnx x)) => //. - rewrite leR_oppl; apply/ltRW/(ltR_leR_trans Hx). - by rewrite /gamma; exact: geR_minr. -apply/ltRW/Rgt_lt. -have ? : sqrt (2 * D(V || W | P)) < x. - apply pow2_Rlt_inv; [exact: sqrt_pos | exact: ltRW | ]. - rewrite [in X in X < _]/= mulR1 sqrt_sqrt; last first. - by apply mulR_ge0; [exact/ltRW | exact/cdiv_ge0]. - by rewrite mulRC -ltR_pdivl_mulr //; exact/(ltR_leR_trans Hcase)/geR_minr. -have ? : x <= exp (- 1). - apply (@leR_trans (exp (-2))); first exact: geR_minr. - by apply/ltRW/exp_increasing; lra. -apply xlnx_sdecreasing_0_Rinv_e => //. -- by split; [exact/sqrt_pos|exact: (@leR_trans x _ _ (ltRW _))]. -- by split => //; exact: ltRW. + apply/ltW/(lt_le_trans Hcase). + apply (@le_trans _ _ (x ^+ 2 / 2)). + by rewrite ge_min lexx orbT. + rewrite ler_wpM2r ?invr_ge0// lerXn2r// ?nnegrE ?expR_ge0//. + - exact: ltW. + - by rewrite ge_min lexx orbT. +rewrite -[X in _ <= X]opprK. +rewrite -lerNr. +rewrite -(lerD2l minRate). +apply: le_trans. +suff x_gamma : - xlnx (Num.sqrt (2 * (D(V || W | P)))) <= gamma. + rewrite opprD addrA [in leRHS]addrC -lerBlDr. + rewrite [X in X <= _](_ : _ = - ((minRate + - capacity W) / 2)); last first. + lra. + rewrite lerNr opprK -mulrA mulrC. + rewrite ler_pdivrMr ?ln2_gt0// mulrC -ler_pdivlMr; last first. + by rewrite ltr_wpDr ?ltr0n// mulr_ge0. + rewrite (le_trans x_gamma)//. + by rewrite /gamma mulrC (mulrC (ln 2)). +suff x_D : xlnx x <= xlnx (Num.sqrt (2 * (D(V || W | P)))). + rewrite lerNl (@le_trans _ _ (xlnx x))//. + rewrite lerNl; apply/ltW. + apply: (@lt_le_trans _ _ (Num.min (expR (-2)) gamma)). + have /= := mu_cond x. + rewrite sub0r normrN gtr0_norm// => /(_ xmu). + rewrite xlnx_0 sub0r normrN. + rewrite ltr0_norm//. + rewrite /xlnx x_gt0. + rewrite pmulr_rlt0//. + rewrite (@le_lt_trans _ _ (ln (expR (-2))))//. + by rewrite exp.ler_ln ?posrE// ?expR_gt0// ge_min lexx orbT. + by rewrite exp.expRK ltrNl oppr0. + by rewrite ge_min lexx orbT. +apply/ltW. +have ? : Num.sqrt (2 * D(V || W | P)) < x. + rewrite -(@ltr_pXn2r _ 2) ?nnegrE ?sqrtr_ge0//; last exact/ltW. + rewrite sqr_sqrtr//; last first. + by rewrite mulr_ge0// cdiv_ge0. + rewrite mulrC -ltr_pdivlMr //. + apply: (lt_le_trans Hcase). + by rewrite ge_min lexx orbT. +have xN1 : x <= expR (- 1). + apply: (@le_trans _ _ (expR (-2))). + by rewrite ge_min lexx orbT. + by rewrite ler_expR lerN2 ler1n. +rewrite xlnx_sdecreasing_0_Rinv_e//. +- by rewrite sqrtr_ge0/= (le_trans _ xN1)// ltW. +- by rewrite (ltW x_gt0) xN1. Qed. End error_exponent_lower_bound. diff --git a/information_theory/joint_typ_seq.v b/information_theory/joint_typ_seq.v index eb0aa812..7fd37efa 100644 --- a/information_theory/joint_typ_seq.v +++ b/information_theory/joint_typ_seq.v @@ -1,9 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssrnum ssralg matrix. -Require Import Reals Lra. -From mathcomp Require Import Rstruct. -Require Import ssrZ ssrR Reals_ext ssr_ext logb ssralg_ext bigop_ext. +From mathcomp Require Import all_ssreflect ssrnum ssrint ssralg matrix. +From mathcomp Require Import lra ring archimedean. +From mathcomp Require Import mathcomp_extra Rstruct reals exp. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln. Require Import fdist proba entropy aep typ_seq channel. (******************************************************************************) @@ -43,12 +43,15 @@ Local Open Scope typ_seq_scope. Local Open Scope fdist_scope. Local Open Scope channel_scope. Local Open Scope entropy_scope. -Local Open Scope R_scope. +Local Open Scope ring_scope. +#[local] Definition R := Rdefinitions.R. + +Import Order.Theory GRing.Theory Num.Theory. Section joint_typ_seq_definition. Variables A B : finType. -Variable P : R.-fdist A. +Variable P : {fdist A}. Variable W : `Ch(A, B). Variable n : nat. Variable epsilon : R. @@ -63,19 +66,13 @@ Definition set_jtyp_seq : {set 'rV[A * B]_n} := [set tab | jtyp_seq tab]. Local Notation "'`JTS'" := (set_jtyp_seq). Lemma typical_sequence1_JTS x : prod_rV x \in `JTS -> - exp2 (- INR n * (`H P + epsilon)) <= P `^ n x.1 <= exp2 (- INR n * (`H P - epsilon)). -Proof. -rewrite inE => /and3P[/andP[/RleP JTS11 /RleP JTS12] _ _]. -by rewrite prod_rVK in JTS11, JTS12. -Qed. + 2 `^ (- n%:R * (`H P + epsilon)) <= (P `^ n)%fdist x.1 <= 2 `^ (- n%:R * (`H P - epsilon)). +Proof. by rewrite inE /jtyp_seq prod_rVK => /and3P[] /andP[-> ->]. Qed. Lemma typical_sequence1_JTS' x : prod_rV x \in `JTS -> - exp2 (- INR n * (`H (`O( P , W)) + epsilon)) <= (`O( P , W)) `^ n x.2 <= - exp2 (- INR n * (`H (`O( P , W)) - epsilon)). -Proof. -rewrite inE => /and3P[_ /andP[/RleP JTS11 /RleP JTS12] _]. -by rewrite prod_rVK in JTS11, JTS12. -Qed. + 2 `^ (- n%:R * (`H (`O( P , W)) + epsilon)) <= (`O( P , W) `^ n)%fdist x.2 <= + 2 `^ (- n%:R * (`H (`O( P , W)) - epsilon)). +Proof. by rewrite inE /jtyp_seq prod_rVK => /and3P[_] /andP[-> ->]. Qed. End joint_typ_seq_definition. @@ -88,14 +85,15 @@ Variables (A B : finType) (P : {fdist A}) (W : `Ch(A, B)). Variable n : nat. Variable epsilon : R. -Lemma JTS_sup : INR #| `JTS P W n epsilon| <= exp2 (INR n * (`H(P , W) + epsilon)). +Lemma JTS_sup : + #| `JTS P W n epsilon|%:R <= 2 `^ (n%:R * (`H(P , W) + epsilon)). Proof. -have : INR #|`JTS P W n epsilon| <= INR #|`TS ((P `X W)) n epsilon|. +have : #|`JTS P W n epsilon|%:R <= #|`TS ((P `X W)) n epsilon|%:R :> R. suff : `JTS P W n epsilon \subset `TS ((P `X W)) n epsilon. - by move/subset_leq_card/leP/le_INR. + by rewrite ler_nat => /subset_leq_card. apply/subsetP => tab. by rewrite /set_jtyp_seq inE /jtyp_seq inE => /and3P[]. -move/leR_trans; apply; exact: (@TS_sup _ ((P `X W)) epsilon n). +move/le_trans; apply; exact: TS_sup. Qed. End jtyp_seq_upper. @@ -103,135 +101,117 @@ End jtyp_seq_upper. Section jtyp_seq_transmitted. Variables (A B : finType) (P : {fdist A}) (W : `Ch(A, B)). Variable epsilon : R. - -Local Open Scope zarith_ext_scope. +Definition Nup (x : R) := `| Num.floor x |.+1. +Lemma Nup_gt x : x < (Nup x)%:R. +Proof. +apply: (lt_le_trans (lt_succ_floor x)). +by rewrite /Nup -intrD1 -natr1 lerD // natr_absz ler_int ler_norm. +Qed. Definition JTS_1_bound := - maxn '| up (aep_bound P (epsilon / 3)) | - (maxn '| up (aep_bound (`O(P , W)) (epsilon / 3)) | - '| up (aep_bound ((P `X W)) (epsilon / 3)) |). + maxn (Nup (aep_bound P (epsilon / 3))) + (maxn (Nup (aep_bound (`O(P , W)) (epsilon / 3))) + (Nup (aep_bound ((P `X W)) (epsilon / 3)))). Variable n : nat. Hypothesis He : 0 < epsilon. Lemma JTS_1 : (JTS_1_bound <= n)%nat -> - 1 - epsilon <= Pr ((P `X W) `^ n) (`JTS P W n epsilon). + 1 - epsilon <= Pr ((P `X W) `^ n)%fdist (`JTS P W n epsilon). Proof. have : (JTS_1_bound <= n)%nat -> - Pr ( (P `^ n `X (W ``^ n)) ) + Pr ( ((P `^ n)%fdist `X (W ``^ n)) ) [set x | x.1 \notin `TS P n epsilon] + - Pr ( (P `^ n `X (W ``^ n)) ) + Pr ( ((P `^ n)%fdist `X (W ``^ n)) ) [set x | x.2 \notin `TS (`O(P , W)) n epsilon] + - Pr ( (P `^ n `X (W ``^ n))) + Pr ( ((P `^ n)%fdist `X (W ``^ n))) [set x | prod_rV x \notin `TS ( (P `X W) ) n epsilon] <= epsilon. - have H1 : forall n, Pr ((P `X W) `^ n) [set x | (rV_prod x).1 \notin `TS P n epsilon ] <= - Pr (P `^ n) [set x | x \notin `TS P n (epsilon / 3)]. + have H1 : forall n, Pr ((P `X W) `^ n)%fdist [set x | (rV_prod x).1 \notin `TS P n epsilon ] <= + Pr (P `^ n)%fdist [set x | x \notin `TS P n (epsilon / 3)]. move=> m. - have : 1 <= 3 by lra. - move/(set_typ_seq_incl P m (ltRW He)) => Hincl. + move: (set_typ_seq_incl P m (ltW He)) => Hincl. rewrite (Pr_DMC_fst P W (fun x => x \notin `TS P m epsilon)). apply/subset_Pr/subsetP => i /=; rewrite !inE. apply contra. by move/subsetP : Hincl => /(_ i); rewrite !inE. - have {H1}HnP : forall n, ('| up (aep_bound P (epsilon / 3)) | <= n)%nat -> - Pr ((P `X W) `^ n) [set x | (rV_prod x).1 \notin `TS P n epsilon ] <= epsilon /3. + have {H1}HnP : forall n, (Nup (aep_bound P (epsilon / 3)) <= n)%N -> + Pr ((P `X W) `^ n)%fdist [set x | (rV_prod x).1 \notin `TS P n epsilon ] <= epsilon /3. move=> m Hm. - apply: leR_trans; first exact: (H1 m). - have m_prednK : m.-1.+1 = m. - rewrite prednK // (leq_trans _ Hm) // (_ : O = '| 0 |) //. - by apply/ltP/Zabs_nat_lt; split; [by [] | apply/up_pos/aep_bound_ge0; lra]. - have : 1 - (epsilon / 3) <= Pr (P `^ m) (`TS P m (epsilon/3)). + apply: le_trans; first exact: (H1 m). + have m_prednK : m.-1.+1 = m by rewrite prednK // (leq_trans _ Hm). + have : 1 - (epsilon / 3) <= Pr (P `^ m)%fdist (`TS P m (epsilon / 3)). rewrite -m_prednK. - apply Pr_TS_1. - - by apply divR_gt0 => //; lra. + apply: Pr_TS_1. + - by rewrite divr_gt0. - rewrite m_prednK. - move/leP/le_INR : Hm; apply leR_trans. - rewrite INR_Zabs_nat; last first. - apply/ltZW/up_pos/aep_bound_ge0 => //. - apply divR_gt0 => //; lra. - exact/ltRW/(proj1 (archimed _ )). - rewrite leR_subl_addr addRC -leR_subl_addr; apply: leR_trans. - rewrite Pr_to_cplt setCK. - by apply/RleP; rewrite Order.POrderTheory.lexx. + move: Hm; rewrite -(ler_nat R); exact/le_trans/ltW/Nup_gt. + rewrite lerBlDr addrC -lerBlDr; apply: le_trans. + by rewrite Pr_to_cplt setCK. have H1 m : - Pr ((P `X W) `^ m) [set x | (rV_prod x).2 \notin `TS ( `O(P , W) ) m epsilon ] <= - Pr ( (`O( P , W) ) `^ m) (~: `TS ( `O( P , W) ) m (epsilon / 3)). - have : 1 <= 3 by lra. - move/(set_typ_seq_incl (`O(P , W)) m (ltRW He)) => Hincl. + Pr ((P `X W) `^ m)%fdist [set x | (rV_prod x).2 \notin `TS ( `O(P , W) ) m epsilon ] <= + Pr ( (`O( P , W) ) `^ m)%fdist (~: `TS ( `O( P , W) ) m (epsilon / 3)). + have Hincl := set_typ_seq_incl (`O(P , W)) m (ltW He). rewrite Pr_DMC_out. apply/subset_Pr/subsetP => i /=; rewrite !inE. apply contra. move/subsetP : Hincl => /(_ i). by rewrite !inE. - have {H1}HnPW m : ('| up (aep_bound (`O(P , W)) (epsilon / 3)) | <= m)%nat -> - Pr ((P `X W) `^ m) [set x | (rV_prod x).2 \notin `TS (`O(P , W)) m epsilon] <= epsilon /3. + have {H1}HnPW m : (Nup (aep_bound (`O(P , W)) (epsilon / 3)) <= m)%nat -> + Pr ((P `X W) `^ m)%fdist [set x | (rV_prod x).2 \notin `TS (`O(P , W)) m epsilon] <= epsilon /3. move=> Hm. - apply: leR_trans; first exact: (H1 m). - have m_prednK : m.-1.+1 = m. - rewrite prednK // (leq_trans _ Hm) // (_ : O = '| 0 |) //. - apply/ltP/Zabs_nat_lt (* TODO: ssrZ? *); split; [by []|apply/up_pos/aep_bound_ge0; lra]. - have : 1 - epsilon / 3 <= Pr ((`O(P , W)) `^ m) (`TS (`O(P , W)) m (epsilon / 3)). + apply: le_trans; first exact: (H1 m). + have m_prednK : m.-1.+1 = m by rewrite prednK // (leq_trans _ Hm). + have : 1 - epsilon / 3 <= Pr ((`O(P , W)) `^ m)%fdist (`TS (`O(P , W)) m (epsilon / 3)). rewrite -m_prednK. - apply Pr_TS_1. - - apply divR_gt0 => //; lra. - - move/leP/le_INR : Hm. - rewrite m_prednK. - apply leR_trans. - rewrite INR_Zabs_nat; last first. - apply/ltZW/up_pos/aep_bound_ge0; lra. - exact/ltRW/(proj1 (archimed _ )). - rewrite leR_subl_addr addRC -leR_subl_addr; apply: leR_trans. - rewrite Pr_to_cplt setCK. - by apply/RleP; rewrite Order.POrderTheory.lexx. - have H1 m : Pr ((P `X W) `^ m) (~: `TS ((P `X W)) m epsilon) <= - Pr (((P `X W) ) `^ m) (~: `TS ((P `X W)) m (epsilon / 3)). - have : 1 <= 3 by lra. - move/(set_typ_seq_incl ((P `X W)) m (ltRW He)) => Hincl. + apply: Pr_TS_1. + - by rewrite divr_gt0. + - move: Hm. + rewrite m_prednK -(ler_nat R). + exact/le_trans/ltW/Nup_gt. + rewrite lerBlDr addrC -lerBlDr; apply: le_trans. + by rewrite Pr_to_cplt setCK. + have H1 m : Pr ((P `X W) `^ m)%fdist (~: `TS ((P `X W)) m epsilon) <= + Pr ((P `X W) `^ m)%fdist (~: `TS ((P `X W)) m (epsilon / 3)). + have Hincl := set_typ_seq_incl ((P `X W)) m (ltW He). apply/subset_Pr/subsetP => /= v; rewrite !inE. apply contra. by move/subsetP : Hincl => /(_ v); by rewrite !inE. - have {H1}HnP_W m : ('| up (aep_bound ((P `X W)) (epsilon / 3)) | <= m)%nat -> - Pr ((P `X W) `^ m) (~: `TS ((P `X W)) m epsilon) <= epsilon /3. + have {H1}HnP_W m : (Nup (aep_bound ((P `X W)) (epsilon / 3)) <= m)%nat -> + Pr ((P `X W) `^ m)%fdist (~: `TS ((P `X W)) m epsilon) <= epsilon /3. move=> Hm. - apply: leR_trans; first exact: (H1 m). - have m_prednK : m.-1.+1 = m. - rewrite prednK // (leq_trans _ Hm) // (_ : O = '| 0 |) //. - apply/ltP/Zabs_nat_lt; split; [by []|apply/up_pos/aep_bound_ge0; lra]. - have : 1 - epsilon / 3 <= Pr (((P `X W)) `^ m) (`TS ((P `X W)) m (epsilon / 3)). - rewrite -m_prednK; apply Pr_TS_1. - - apply divR_gt0 => //; lra. - - rewrite m_prednK. - move/leP/le_INR : Hm; apply leR_trans. - rewrite INR_Zabs_nat; last first. - apply/ltZW/up_pos/aep_bound_ge0; lra. - exact/Rlt_le/(proj1 (archimed _ )). - rewrite leR_subl_addr addRC -leR_subl_addr; apply: leR_trans. - rewrite Pr_to_cplt setCK. - by apply/RleP; rewrite Order.POrderTheory.lexx. + apply: le_trans; first exact: (H1 m). + have m_prednK : m.-1.+1 = m by rewrite prednK // (leq_trans _ Hm). + have : 1 - epsilon / 3 <= Pr ((P `X W) `^ m)%fdist (`TS (P `X W) m (epsilon / 3)). + rewrite -m_prednK; apply: Pr_TS_1. + - by rewrite divr_gt0. + - move: Hm; rewrite m_prednK -(ler_nat R). + exact/le_trans/ltW/Nup_gt. + rewrite lerBlDr addrC -lerBlDr; apply: le_trans. + by rewrite Pr_to_cplt setCK. move=> Hn. - rewrite [in X in _ <= X](_ : epsilon = epsilon / 3 + epsilon / 3 + epsilon / 3)%R; last by field. + rewrite [in X in _ <= X](_ : epsilon = epsilon / 3 + epsilon / 3 + epsilon / 3); last by field. move: Hn; rewrite 2!geq_max => /andP[Hn1 /andP[Hn2 Hn3]]. rewrite !Pr_DMC_rV_prod. - apply leR_add; first by apply leR_add; [exact: HnP | exact: HnPW]. - apply: leR_trans; last exact/HnP_W/Hn3. - by apply/Req_le; congr Pr; apply/setP => /= tab; by rewrite !inE rV_prodK. + apply lerD; first by apply lerD; [exact: HnP | exact: HnPW]. + apply: le_trans; last exact/HnP_W/Hn3. + by apply/eqW; congr Pr; apply/setP => /= tab; rewrite !inE rV_prodK. move=> Hn_Pr Hn. -suff H : Pr ((P `X W) `^ n ) (~: `JTS P W n epsilon) <= epsilon. - rewrite -(Pr_cplt ((P `X W) `^ n) (`JTS P W n epsilon)). - by rewrite leR_subl_addr leR_add2l. -apply (@leR_trans (Pr ((P `X W) `^ n) - ([set x | ((rV_prod x).1 \notin `TS P n epsilon)] :|: - ([set x | ((rV_prod x).2 \notin `TS (`O( P , W)) n epsilon)] :|: - (~: `TS ((P `X W)) n epsilon))))). - by apply Req_le; congr Pr; apply/setP => xy; rewrite !inE 2!negb_and orbA. -apply: leR_trans; last exact: Hn_Pr. -apply (@leR_trans ( - Pr ((P `X W) `^ n) [set x | (rV_prod x).1 \notin `TS P n epsilon] + - Pr ((P `X W) `^ n) ([set x | ((rV_prod x).2 \notin `TS (`O( P , W)) n epsilon)] :|: +suff H : Pr ((P `X W) `^ n)%fdist (~: `JTS P W n epsilon) <= epsilon. + rewrite -(Pr_cplt ((P `X W) `^ n)%fdist (`JTS P W n epsilon)). + by rewrite lerBlDr lerD2l. +apply (@le_trans _ _ (Pr ((P `X W) `^ n)%fdist + ([set x | ((rV_prod x).1 \notin `TS P n epsilon)] :|: + ([set x | ((rV_prod x).2 \notin `TS (`O( P , W)) n epsilon)] :|: + (~: `TS (P `X W) n epsilon))))). + by apply/eqW; congr Pr; apply/setP => xy; rewrite !inE 2!negb_and orbA. +apply: le_trans; last exact: Hn_Pr. +apply (@le_trans _ _ ( + Pr ((P `X W) `^ n)%fdist [set x | (rV_prod x).1 \notin `TS P n epsilon] + + Pr ((P `X W) `^ n)%fdist ([set x | ((rV_prod x).2 \notin `TS (`O( P , W)) n epsilon)] :|: (~: `TS ((P `X W)) n epsilon)))). exact: le_Pr_setU. -rewrite -addRA !Pr_DMC_rV_prod; apply/leR_add2l; apply: leR_trans (le_Pr_setU _ _ _). -by apply/Req_le; congr Pr; apply/setP => t; rewrite !inE rV_prodK. +rewrite -addrA !Pr_DMC_rV_prod lerD2l //; apply: le_trans (le_Pr_setU _ _ _). +by apply/eqW; congr Pr; apply/setP => t; rewrite !inE rV_prodK. Qed. End jtyp_seq_transmitted. @@ -239,31 +219,31 @@ End jtyp_seq_transmitted. Section non_typicality. Variables (A B : finType) (P : {fdist A}) (W : `Ch(A, B)) (n : nat) (epsilon : R). -Lemma non_typical_sequences : Pr ((P `^ n) `x ((`O(P , W)) `^ n)) - [set x | prod_rV x \in `JTS P W n epsilon] <= exp2 (- n%:R * (`I(P, W) - 3 * epsilon)). +Lemma non_typical_sequences : Pr ((P `^ n) `x ((`O(P , W)) `^ n))%fdist + [set x | prod_rV x \in `JTS P W n epsilon] <= 2 `^ (- n%:R * (`I(P, W) - 3 * epsilon)). Proof. rewrite /Pr /=. -apply (@leR_trans (\sum_(i | i \in `JTS P W n epsilon) - (exp2 (- INR n * (`H P - epsilon)) * exp2 (- n%:R * (`H( P `o W ) - epsilon))))) => /=. +apply (@le_trans _ _ (\sum_(i | i \in `JTS P W n epsilon) + (2 `^ (- n%:R * (`H P - epsilon)) * 2 `^ (- n%:R * (`H( P `o W ) - epsilon))))) => /=. rewrite (reindex_onto (fun y => prod_rV y) (fun x => rV_prod x)) /=; last first. by move=> ? ?; rewrite rV_prodK. apply: leR_sumRl => i; rewrite inE => iJTS. - - rewrite fdist_prodE; apply leR_pmul => //. - exact: proj2 (typical_sequence1_JTS iJTS). - exact: proj2 (typical_sequence1_JTS' iJTS). - - exact/mulR_ge0. + - rewrite fdist_prodE ler_pM //. + by case/andP: (typical_sequence1_JTS iJTS). + by case/andP: (typical_sequence1_JTS' iJTS). + - by rewrite mulr_ge0 ?powR_ge0. - by rewrite prod_rVK eqxx andbC. rewrite (_ : \sum_(_ | _) _ = - INR #| `JTS P W n epsilon| * - exp2 (- n%:R * (`H P - epsilon)) * exp2 (- INR n * (`H( P `o W) - epsilon))); last first. - by rewrite big_const iter_addR mulRA. -apply (@leR_trans (exp2 (INR n * (`H( P , W ) + epsilon)) * - exp2 (- n%:R * (`H P - epsilon)) * exp2 (- INR n * (`H( P `o W ) - epsilon)))). - do 2 apply leR_wpmul2r => //. - exact/JTS_sup. -apply Req_le; rewrite -2!ExpD; congr (exp2 _). -rewrite /mutual_info_chan !mulRDr 2!Rmult_opp_opp. -by rewrite (_ : 3 * epsilon = epsilon + epsilon + epsilon); field. + #| `JTS P W n epsilon|%:R * + 2 `^ (- n%:R * (`H P - epsilon)) * 2 `^ (- n%:R * (`H( P `o W) - epsilon))); + last by rewrite big_const iter_addr addr0 -mulr_natl mulrA. +apply (@le_trans _ _ (2 `^ (n%:R * (`H( P , W ) + epsilon)) * + 2 `^ (- n%:R * (`H P - epsilon)) * 2 `^ (- n%:R * (`H( P `o W ) - epsilon)))). + by rewrite !ler_wpM2r ?powR_ge0 // JTS_sup. +apply/eqW. +rewrite -!powRD; try by rewrite (@eqr_nat R 2 0) implybT. +rewrite /mutual_info_chan !mulrDr !mulrNN; congr exp.powR. +by rewrite (_ : 3 * epsilon = epsilon + epsilon + epsilon) //; field. Qed. End non_typicality. diff --git a/information_theory/jtypes.v b/information_theory/jtypes.v index 4a87c90b..6cf6faf9 100644 --- a/information_theory/jtypes.v +++ b/information_theory/jtypes.v @@ -3,9 +3,8 @@ From HB Require Import structures. (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum fingroup perm. From mathcomp Require boolp. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext realType_ext ssr_ext ssralg_ext logb fdist entropy. +From mathcomp Require Import Rstruct reals exp. +Require Import ssr_ext ssralg_ext realType_ext realType_ln fdist entropy. Require Import num_occ channel types. (******************************************************************************) @@ -37,10 +36,10 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. Local Open Scope channel_scope. +Local Open Scope ring_scope. -Import Num.Theory. +Import Order.POrderTheory GRing.Theory Num.Theory. Module JType. Section def. @@ -53,8 +52,8 @@ Record t : predArgType := mk { sum_f : \sum_(a in A) \sum_(b in B) f a b == n ; c_f : forall a b, c a b = let row := \sum_(b in B) f a b in if row == O - then / #|B|%:R - else ((f a b)%:R / row%:R)%R }. + then #|B|%:R^-1 + else (f a b)%:R / row%:R }. End def. End JType. @@ -93,52 +92,49 @@ Qed. HB.instance Definition _ A B n := @hasDecEq.Build _ _ (@jtype_eqP A B n). -Definition nneg_fun_of_pre_jtype (A B : finType) (Bnot0 : (0 < #|B|)%nat) n - (f : {ffun A -> {ffun B -> 'I_n.+1}}) : A -> nneg_finfun B. +Definition nneg_fun_of_pre_jtype (A B : finType) n + (f : {ffun A -> {ffun B -> 'I_n.+1}}) : A -> {ffun B -> Rdefinitions.R}. pose pf := fun a => [ffun b : B => let ln := (\sum_(b1 in B) (f a b1))%nat in if ln == O - then / #|B|%:R + then #|B|%:R^-1 else (f a b)%:R / ln%:R]. -move=> a. -refine (@mkNNFinfun _ (pf a) _); apply/forallPP; first by move=> ?; exact/RleP. -move=> b; rewrite /pf ffunE. -case: ifPn => [_ | Hcase]. -- exact/invR_ge0/ltR0n. -- apply divR_ge0; first exact/leR0n. - apply/RltP; rewrite lt0r; apply/andP; split. - by apply: contra Hcase; rewrite INR_eq0'. - exact/RleP/leR0n. +exact: pf. Defined. -Definition chan_of_jtype (A B : finType) (Anot0 : (0 < #|A|)%nat) (Bnot0 : (0 < #|B|)%nat) +Definition nneg_fun_of_pre_jtype_ge0 (A B : finType) (Bnot0 : (0 < #|B|)%nat) n + (f : {ffun A -> {ffun B -> 'I_n.+1}}) a b : + 0 <= nneg_fun_of_pre_jtype f a b. +Proof. +rewrite /nneg_fun_of_pre_jtype ffunE. +case: ifPn => [_ | Hcase]. +- by rewrite invr_ge0. +- by rewrite divr_ge0. +Qed. + +Definition chan_of_jtype (A B : finType) (Anot0 : (0 < #|A|)%nat) + (Bnot0 : (0 < #|B|)%nat) n (f : {ffun A -> {ffun B -> 'I_n.+1}}) : `Ch*(A, B). set pf := fun a b => let ln := (\sum_(b1 in B) (f a b1))%nat in if ln == O - then / #|B|%:R - else (f a b)%:R / ln%:R. + then #|B|%:R^-1 + else ((f a b)%:R / ln%:R) : Rdefinitions.R. refine (@Channel1.mkChan A B _ Anot0) => a. -apply: (@FDist.make _ _ (@nneg_fun_of_pre_jtype _ _ Bnot0 n f a)). +apply: (@FDist.make _ _ (@nneg_fun_of_pre_jtype _ _ n f a)). move=> b. - rewrite /nneg_fun_of_pre_jtype/= ffunE. - case: ifPn => // ?. - by apply/RleP/invR_ge0/ltR0n. - apply/RleP/divR_ge0. - exact/leR0n. - rewrite ltR_neqAle; split. - apply/eqP. - by rewrite eq_sym INR_eq0'. - exact: leR0n. -rewrite /=. + by apply: nneg_fun_of_pre_jtype_ge0. under eq_bigr do rewrite ffunE. -case/boolP : (\sum_(b1 in B) (f a b1) == O)%nat => Hcase. -- by rewrite /Rle big_const iter_addR mulRV // INR_eq0' -lt0n. -- under eq_bigr=> b bB do rewrite RdivE. - rewrite big_morph_natRD /Rdiv. - rewrite -big_distrl /=. - rewrite GRing.mulfV//. - by rewrite -big_morph_natRD // INR_eq0'. +have [->|Hcase] := eqVneq (\sum_(b1 in B) (f a b1))%nat 0%nat. +- rewrite big_const iter_addr addr0. + by rewrite -[LHS]mulr_natl divff// gt_eqF// ltr0n. +- under eq_bigr=> b bB. + rewrite /=. + case: ifPn. + by rewrite (negbTE Hcase). + move=> _. + over. + by rewrite /= -big_distrl//= -natr_sum divff// (_ : 0 = 0%:R)// eqr_nat. Defined. Definition jtype_choice_f (A B : finType) n (f : {ffun A -> {ffun B -> 'I_n.+1}}) : option (P_ n ( A , B )). @@ -158,7 +154,8 @@ end). move=> a b; by rewrite ffunE. Defined. -Lemma jtype_choice_pcancel (A B : finType) n : pcancel (@JType.f A B n) (@jtype_choice_f A B n). +Lemma jtype_choice_pcancel (A B : finType) n : + pcancel (@JType.f A B n) (@jtype_choice_f A B n). Proof. case=> d f Hf H /=. rewrite /jtype_choice_f /=. @@ -275,16 +272,16 @@ have -> : tmp = pmap (fun f => JType.c_f := fun a b => eq_ind_r (eq^~ (if (\sum_(b0 in B) sval f a b0)%nat == 0%N - then / #|B|%:R + then #|B|%:R^-1 else (sval f a b)%:R / (\sum_(b0 in B) sval f a b0)%:R)) (erefl (if (\sum_(b0 in B) sval f a b0)%nat == 0%N - then / #|B|%:R + then #|B|%:R^-1 else (sval f a b)%:R / (\sum_(b0 in B) sval f a b0)%:R)) (ffunE (fun b0 : B => if (\sum_(b1 in B) sval f a b1)%nat == 0%N - then / #|B|%:R + then #|B|%:R^-1 else (sval f a b0)%:R / (\sum_(b1 in B) sval f a b1)%:R) b) (*(if \sum_(b0 in B) (sval f a) b0 == 0%N then / #|B|%:R @@ -323,13 +320,19 @@ Lemma jtype_0_jtypef (V : P_ n ( A , B )) a b : V a b = 0%R -> (JType.f V) a b = Proof. destruct V as [V1 V2 V3 V4] => /=. rewrite V4 /=. -case: ifP => [| H']. +case: ifPn => [| H']. rewrite sum_nat_eq0. move/forallP/(_ b)/implyP/(_ Logic.eq_refl)/eqP => H _; exact: val_inj. -rewrite /Rdiv mulR_eq0 => -[|abs]. - rewrite INR_eq0 => ?; exact/val_inj. +move=> /eqP. +rewrite mulf_eq0 => -/orP[|abs]. + rewrite (_ : 0%R = 0%:R)%R// eqr_nat => /eqP ?. + exact/val_inj. exfalso. -by apply/eqP : abs; apply/invR_neq0'; rewrite INR_eq0' H'. +move/negP : abs; apply. +apply/negP. +rewrite invr_eq0. +rewrite (_ : 0%R = 0%:R)//. +by rewrite eqr_nat. Qed. Lemma bound_card_jtype : #| P_ n (A , B) | <= expn n.+1 (#|A| * #|B|). @@ -367,7 +370,7 @@ have [tmp Htmp] : {f : {ffun A -> {ffun B -> 'I_n.+1}} | have Htmp' : (forall a b, (chan_of_jtype Anot0 Bnot0 tmp) a b = (let ln := \sum_(b0 in B) (tmp a) b0 in - if ln == 0 then / #|B|%:R else (((tmp a) b)%:R / ln%:R)%R)). + if ln == 0 then #|B|%:R^-1 else ((tmp a) b)%:R / ln%:R)). by move=> a0 b0; rewrite ffunE. exists (@JType.mk _ _ _ (chan_of_jtype Anot0 Bnot0 tmp) tmp Htmp Htmp'). by rewrite inE. @@ -640,7 +643,6 @@ Proof. by rewrite ltnS -(H Hta) (bigD1 b) // leq_addr. Qed. End row_num_occ_sect. Section take_shell_row_num_occ. - Variables A B : finType. Variable n : nat. Variable V : P_ n ( A , B). @@ -653,18 +655,17 @@ Local Open Scope nat_scope. Definition type_of_row (a : A) (Ha : N(a | ta) != 0) : P_ N(a | ta) ( B ). pose f := [ffun b => Ordinal (ctyp_element_ub Hrow_num_occ Hta a b)]. -pose d := [ffun b => ((f b)%:R / N(a | ta)%:R)%R]. +pose d := [ffun b => ((f b)%:R / N(a | ta)%:R) : Rdefinitions.R]. assert (d0 : forall b, (0 <= d b)%mcR). move=> b. - apply/RleP. - rewrite /d /= ffunE. - apply mulR_ge0; first exact/leR0n. - apply/invR_ge0/ltR0n; by rewrite lt0n. + by rewrite /d /= ffunE mulr_ge0// invr_ge0. assert (d1 : (\sum_(b : B) d b)%R = 1%R). under eq_bigr do rewrite ffunE /=. - rewrite -big_distrl /= -big_morph_natRD. + rewrite -big_distrl /=. + rewrite -natr_sum. set lhs := \sum_i _. - suff -> : lhs = N(a | ta) by rewrite mulRV // INR_eq0'. + suff -> : lhs = N(a | ta). + by rewrite mulfV // (_ : 0%R = 0%:R)// eqr_nat. rewrite /lhs /f /= -[in X in _ = X](Hrow_num_occ Hta a). apply eq_bigr => b _; by rewrite ffunE. by apply (@type.mkType _ _ (FDist.make d0 d1) f) => b; rewrite ffunE. @@ -718,7 +719,7 @@ apply/andP; split. have Ht2 : tval t = drop (sum_num_occ ta k) (take (sum_num_occ ta k.+1) tb). rewrite Ht {1}sum_num_occ_rec take_drop take_takel; last by rewrite addnC. by rewrite addnC sum_num_occ_rec. - congr (_ %:R / _%:R)%R. + congr (_ %:R / _%:R). exact/esym/num_occ_num_co_occ. Qed. @@ -756,26 +757,26 @@ elim. rewrite (bigD1 (Ordinal HSk)) //=. rewrite (eq_bigl (fun i : 'I_#|A| => i < k) _); last first. move=> i /=. - case/boolP : (i < k) => Hcase. + have [ik|ki] := ltnP i k. - have -> : i != Ordinal HSk by rewrite neq_ltn; apply/orP; apply or_introl. by rewrite andbC /= ltnW. - rewrite andbC -ltn_neqAle. - by move/negbTE : Hcase => ->. + by apply/negbTE; rewrite -leqNgt. rewrite /card_type_of_row; case: Bool.bool_dec => [e|/Bool.eq_true_not_negb e]. - rewrite mul1n. - eapply leq_trans; [exact: (card_take_shell0 e) | by []]. - apply (leq_trans (card_take_shell e)). - rewrite mulnC leq_pmul2l //. + by rewrite mul1n (leq_trans (card_take_shell0 e)). + rewrite (leq_trans (card_take_shell e))// mulnC leq_pmul2l //. apply/card_gt0P. set Q := type_of_row e. case: (typed_tuples_not_empty_alt e Q) => tb Htb. by exists tb. Qed. -Lemma card_shelled_tuples_leq_prod_card : #| V.-shell ta | <= \prod_ ( i < #|A|) card_type_of_row i. +Lemma card_shelled_tuples_leq_prod_card : + #| V.-shell ta | <= \prod_ ( i < #|A|) card_type_of_row i. Proof. -rewrite -full_take_shell [X in _ <= X](_ : _ = \prod_(i < #|A| | i < #|A|) card_type_of_row i); last first. - apply eq_bigl => ?; symmetry; by apply ltn_ord. +rewrite -full_take_shell. +rewrite [leqRHS](_ : _ = \prod_(i < #|A| | i < #|A|) card_type_of_row i); last first. + by apply eq_bigl => ?; exact/esym/ltn_ord. exact (split_nocc_rec (leqnn #|A|)). Qed. @@ -795,34 +796,35 @@ Hypothesis ta_sorted : sorted (@le_rank _) ta. Hypothesis Bnot0 : (0 < #|B|)%nat. Lemma card_shell_leq_exp_entropy : - #| V.-shell ta |%:R <= exp2 (n%:R * `H(V | P)). + #| V.-shell ta |%:R <= 2 `^ (n%:R * `H(V | P)). Proof. rewrite cond_entropy_chanE2. -apply (@leR_trans (\prod_ ( i < #|A|) card_type_of_row Hta Vctyp i)%:R). -- exact/le_INR/leP/card_shelled_tuples_leq_prod_card. -- rewrite exp2_pow big_morph_natRM. - rewrite (@big_morph _ _ (fun r : R => ((exp2 r) ^ n)%R) 1%R Rmult _ Rplus _); last 2 first. - move=> a b /=; rewrite -!exp2_pow mulRDr /exp2 !ExpD; by field. - by rewrite -exp2_pow mulR0 /exp2 Exp_0. - rewrite (reindex_onto (fun x => enum_rank x) (fun y => enum_val y)) => [|i _]; last by rewrite enum_valK. +apply (@le_trans _ _ (\prod_(i < #|A|) card_type_of_row Hta Vctyp i)%:R). +- rewrite ler_nat. + exact/card_shelled_tuples_leq_prod_card. +- rewrite (mulrC n%:R) powRrM' natr_prod. + rewrite (@big_morph _ _ (fun r => (2%:R `^ r) ^+ n) 1%R *%R _ +%R _); last 2 first. + by move=> a b /=;rewrite powR2D exprMn_comm// /GRing.comm mulrC. + by rewrite powRr0 expr1n. + rewrite (reindex_onto enum_rank enum_val) => [|i _]; last by rewrite enum_valK. rewrite (_ : \prod_(j | enum_val (enum_rank j) == j) _ = \prod_(j : A) (card_type_of_row Hta Vctyp (enum_rank j))%:R); last first. - apply eq_bigl => a; rewrite enum_rankK; by apply/eqP. - apply leR_prodR => a. - split; first exact/leR0n. - rewrite -exp2_pow mulRA. + by apply eq_bigl => a; rewrite enum_rankK; exact/eqP. + apply ler_prod => a aA; apply/andP; split => //. + rewrite -powRrM'. rewrite /card_type_of_row; case: Bool.bool_dec => [e|/Bool.eq_true_not_negb e]. - rewrite -[X in X <= _]exp2_0. - apply Exp_le_increasing, mulR_ge0 => //. - apply mulR_ge0 => //; exact: leR0n. - exact: entropy_ge0. + rewrite -[X in X <= _](powRr0 2). + by rewrite gt1_ler_powRr ?ltr1n// !mulr_ge0//; exact: entropy_ge0. set pta0 := type_of_row Hta Vctyp _. - rewrite (_ : exp2 _ = exp2 (N(a | ta)%:R * `H pta0)%R). - by rewrite -[in X in _ <= exp2 (X * _)](enum_rankK a); apply card_typed_tuples. - congr (exp2 (_ * _)). + rewrite (_ : _ `^ _ = 2 `^ (N(a | ta)%:R * `H pta0)). + by rewrite -[in X in _ <= _ _ (X * _)](enum_rankK a); apply card_typed_tuples. + congr (_ `^ _). + rewrite mulrC mulrA. + congr *%R. + by rewrite -type_fun_type // (type_numocc Hta). + rewrite /entropy. - apply Ropp_eq_compat, eq_bigr => b _. + congr (- _)%R. + apply: eq_bigr => b _. rewrite /pta0 (JType.c_f V) /= (Vctyp Hta a) -{1 4}(enum_rankK a). by move/negbTE : (e) => ->; rewrite !ffunE /= enum_rankK. Qed. @@ -833,11 +835,8 @@ End card_shell_ub. Lemma map_pred1_nseq {A : eqType} : forall (l : seq A) n a, a \notin l -> map (pred1 a) (flatten [seq nseq (n x) x | x <- l]) = nseq (\sum_(i <- l) (n i)) false. Proof. -elim. - move=> n0 a Ha /=; by rewrite big_nil. -move=> h t IH n0 a. -rewrite in_cons negb_or. -case/andP => H1 H2 /=. +elim=> [n0 a Ha /=|h t IH n0 a]; first by rewrite big_nil. +rewrite in_cons negb_or => /andP[H1 H2] /=. rewrite map_cat IH // (_ : map _ _ = nseq (n0 h) false); last first. by rewrite map_nseq /= -(negbTE H1) eqtype.eq_sym. by rewrite big_cons nseq_add. @@ -855,8 +854,7 @@ rewrite IH. apply eq_in_filter => a /nseqP[-> _]. apply/negP/negP/H; by rewrite in_cons eqxx. by rewrite filter_pred0. -move=> x0 Hx0. -apply H; by rewrite in_cons Hx0 orbC. +by move=> x0 Hx0; rewrite H// in_cons Hx0 orbC. Qed. (* TODO: move? *) @@ -883,7 +881,6 @@ by rewrite filter_pred0. Qed. Section shell_not_empty_sorted. - Variables A B : finType. Variable n : nat. Variable ta : n.-tuple A. @@ -984,16 +981,15 @@ have -> : x2 = JType.f V a b. rewrite /x2 -size_filter (_ : filter _ _ = nseq (JType.f V a b) b); last first. by rewrite filter_flatten map_filter_pred1_nseq // ?enum_uniq // ?mem_enum. by rewrite size_nseq. -by apply/minn_idPl. +exact/minn_idPl. Qed. Lemma shell_not_empty_sorted : exists tb, tb \in V.-shell ta. -Proof. case: (shell_not_empty') => tb [Htb H]; by exists (Tuple Htb). Qed. +Proof. by case: (shell_not_empty') => tb [Htb H]; exists (Tuple Htb). Qed. End shell_not_empty_sorted. Section shell_not_empty. - Variables A B : finType. Variable n : nat. Variable ta : n.-tuple A. @@ -1021,9 +1017,7 @@ Qed. End shell_not_empty. Section cond_type_def. - -Variable A : finType. -Variable n : nat. +Variables (A : finType) (n : nat). Variable P : P_ n ( A ). Variable B : finType. @@ -1037,19 +1031,14 @@ Notation "'\nu_' n '^{' A ',' B '}' '(' P ')'" := Notation "'\nu^{' B '}' '(' P ')'" := (@cond_type _ _ P B) : types_scope. Section cond_type_prop. - -Variable A : finType. -Variable n : nat. +Variables (A : finType) (n : nat). Variable P : P_ n ( A ). Variable B : finType. Local Open Scope nat_scope. -Lemma card_nu : #|\nu^{B}( P )| <= expn n.+1 (#|A| * #|B|). -Proof. -apply: (leq_trans _ (bound_card_jtype A B n)). -apply subset_leq_card; by apply/subsetP. -Qed. +Lemma card_nu : #|\nu^{B}( P )| <= n.+1 ^ (#|A| * #|B|). +Proof. exact/(leq_trans _ (bound_card_jtype A B n))/subset_leq_card/subsetP. Qed. Lemma shell_injective (V V' : P_ n (A , B)) (Vctyp : V \in \nu^{B}(P)) ta (Hta : ta \in T_{P}) : V.-shell ta = V'.-shell ta -> @@ -1071,14 +1060,13 @@ Qed. End cond_type_prop. Section cond_type_equiv_sect. - -Variable A : finType. -Variable n : nat. +Variables (A : finType) (n : nat). Variable P : P_ n ( A ). Variable B : finType. Variable V : P_ n ( A , B ). -Lemma cond_type_equiv : row_num_occ P V <-> [forall ta, (ta \in T_{P}) ==> (V.-shell ta != set0)]. +Lemma cond_type_equiv : + row_num_occ P V <-> [forall ta, (ta \in T_{P}) ==> (V.-shell ta != set0)]. Proof. split=> H. - apply/forallP => ta. @@ -1102,24 +1090,23 @@ Local Open Scope fdist_scope. Module OutType. Section OutType_sect. - -Local Open Scope nat_scope. - Variables A B : finType. Variable n' : nat. Let n := n'.+1. Variable V : P_ n ( A , B ). -Definition f := [ffun b => ((\sum_(a in A) (JType.f V) a b)%:R / n%:R)%R]. +Definition f := [ffun b => (\sum_(a in A) (JType.f V) a b)%:R / n%:R : Rdefinitions.R]. -Lemma f0 (b : B) : (0 <= f b)%mcR. -Proof. rewrite ffunE; apply/RleP/ divR_ge0; [exact/leR0n | exact/ltR0n]. Qed. +Lemma f0 (b : B) : 0 <= f b. +Proof. rewrite ffunE; apply/divr_ge0; [exact/ler0n | exact: ler0n]. Qed. -Lemma f1 : (\sum_(b in B) f b = 1)%R. +Lemma f1 : \sum_(b in B) f b = 1. Proof. under eq_bigr do rewrite ffunE /=. -rewrite -big_distrl /= -big_morph_natRD exchange_big /=. -by move/eqP : (JType.sum_f V) => ->; rewrite mulRV // INR_eq0'. +rewrite -big_distrl /=. +rewrite -natr_sum exchange_big /=. +move/eqP : (JType.sum_f V) => ->; rewrite mulfV //. +by rewrite (_ : 0%R = 0%:R)// eqr_nat. Qed. Definition d : {fdist B} := FDist.make f0 f1. @@ -1162,7 +1149,9 @@ Hypothesis Vctyp : V \in \nu^{B}(P). Lemma output_type_out_fdist : forall b, type.d (`tO( V )) b = `O( P , V ) b. Proof. rewrite /fdist_of_ffun /= /OutType.d /OutType.f => b /=. -rewrite ffunE big_morph_natRD /Rdiv (big_morph _ (morph_mulRDl _) (mul0R _)). +rewrite ffunE. +rewrite natr_sum. +rewrite big_distrl//=. rewrite fdist_outE; apply eq_bigr => a _. case: (typed_tuples_not_empty P) => /= ta Hta. move: (Vctyp). @@ -1173,16 +1162,17 @@ case: ifP => [/eqP |] Hcase. rewrite Hcase in sum_V. rewrite in_set in Hta. move/forallP/(_ a) : Hta. - rewrite -sum_V div0R. - move/eqP => ->; rewrite -RmultE mulR0. + rewrite -sum_V mul0r. + move/eqP => ->; rewrite mulr0. move/eqP in Hcase. rewrite sum_nat_eq0 in Hcase. move/forallP/(_ b) : Hcase. move/implyP/(_ Logic.eq_refl)/eqP => ->. - by rewrite mul0R. -- rewrite -RmultE -mulRA sum_V; congr (_ * _). + by rewrite mul0r. +- rewrite -mulrA sum_V; congr *%R. move: Hta; rewrite in_set => /forallP/(_ a)/eqP ->. - by rewrite mulRA -{1}(mul1R (/ n%:R)) mulVR // INR_eq0' -sum_V Hcase. + rewrite mulrA mulVf ?div1r// -sum_V. + by rewrite (_ : 0%R = 0%:R)// eqr_nat Hcase. Qed. Lemma output_type_out_entropy : `H (`tO( V )) = `H(P `o V). @@ -1194,7 +1184,6 @@ Qed. End output_type_facts. Section card_perm_shell. - Variables A B : finType. Variable n' : nat. Let n := n'.+1. @@ -1205,7 +1194,7 @@ Hypothesis Hta : ta \in T_{P}. Hypothesis Vctyp : V \in \nu^{B}(P). Hypothesis Bnot0 : (0 < #|B|)%nat. -Lemma card_shelled_tuples : #| V.-shell ta |%:R <= exp2 (n%:R * `H(V | P)). +Lemma card_shelled_tuples : (#| V.-shell ta |%:R <= 2 `^ (n%:R * `H(V | P)))%R. Proof. case: (tuple_exist_perm_sort (@le_rank A) ta) => /= s Hta'. have H : sort (@le_rank _) ta = @@ -1247,12 +1236,12 @@ assert (Hf : \sum_(a in A) \sum_(b in B) f a b == n). apply eq_big => a //= _. apply eq_big => b //= _. by rewrite 2!ffunE. -assert (Htmp' : (forall a b, +assert (H : forall a b, (chan_of_jtype Anot0 Bnot0 f) a b = (let ln := (\sum_(b0 in B) (f a) b0)%nat in - if ln == O then / #|B|%:R else (((f a) b)%:R / ln%:R))%R)). + if ln == O then #|B|%:R^-1 else (((f a) b)%:R / ln%:R))). by move=> a b; rewrite ffunE. -exact (@JType.mk _ _ _ (chan_of_jtype Anot0 Bnot0 f) f Hf Htmp'). +exact (@JType.mk _ _ _ (chan_of_jtype Anot0 Bnot0 f) f Hf H). Defined. Definition relYn (ta : n.-tuple A) (tb tb' : n.-tuple B) := @@ -1261,7 +1250,7 @@ Definition relYn (ta : n.-tuple A) (tb tb' : n.-tuple B) := Lemma reflexive_relYn ta : reflexive (relYn ta). Proof. rewrite /reflexive /relYn => tb. -apply/forallP => a; apply/forallP => b; by rewrite eqxx. +by apply/forallP => a; apply/forallP => b; rewrite eqxx. Qed. Variable ta : n.-tuple A. @@ -1286,8 +1275,11 @@ exists (num_co_occ_jtype ta tb).-shell ta. move: Hta'; rewrite in_set => /forallP/(_ a)/eqP => Hta'. move: Hta. rewrite in_set => /forallP/(_ a)/eqP. - rewrite Hta' eqR_mul2r; last by apply/invR_neq0; rewrite INR_eq0. - by move/INR_eq. + rewrite Hta'. + move=> /(congr1 (fun x => x * n%:R)%R). + rewrite -!mulrA mulVf ?mulr1; last first. + by rewrite (_ : 0%R = 0%:R)// eqr_nat. + by move=> /eqP; rewrite eqr_nat => /eqP. - rewrite in_set. apply/forallP => a. apply/forallP => b. by rewrite /num_co_occ_jtype /= 2!ffunE. @@ -1320,15 +1312,17 @@ Qed. End shell_partition. Section sum_tuples_ctypes. +Context {R : ringType}. Variables (A B : finType) (n' : nat). Let n := n'.+1. Variable ta : n.-tuple A. Variable P : P_ n ( A ). Hypothesis Hta : ta \in T_{P}. +Local Open Scope ring_scope. -Let sum_tuples_ctypes'' f : - \sum_ (S | S \in shell_partition B ta P) \sum_(tb in S) f tb = - \sum_ (V | V \in \nu^{B}(P)) \sum_ (tb in V.-shell ta) f tb. +Let sum_tuples_ctypes'' (f : _ -> R) : + \sum_(S | S \in shell_partition B ta P) \sum_(tb in S) f tb = + \sum_(V | V \in \nu^{B}(P)) \sum_ (tb in V.-shell ta) f tb. Proof. rewrite big_imset // => V V' HV HV' /=. move/(shell_injective _) => /(_ P HV Hta) V_V' {HV HV'}. @@ -1342,7 +1336,7 @@ Qed. Hypothesis Anot0 : (0 < #|A|)%nat. Hypothesis Bnot0 : (0 < #|B|)%nat. -Let sum_tuples_ctypes' f : \sum_ (tb : _ ) f tb = +Let sum_tuples_ctypes' f : \sum_ (tb : _ ) (f : _ -> R) tb = \sum_ (V | V \in \nu^{B}(P)) \sum_ (tb in V.-shell ta) f tb. Proof. transitivity (\sum_ (tb in [set: n.-tuple B]) f tb). @@ -1353,7 +1347,7 @@ Qed. Lemma sum_tuples_ctypes f F : \sum_(tb | F tb) f tb = - \sum_(V | V \in \nu^{B}(P)) \sum_ (tb in V.-shell ta | F tb) f tb. + \sum_(V | V \in \nu^{B}(P)) \sum_ (tb in V.-shell ta | F tb) f tb :> R. Proof. rewrite big_mkcond /=. transitivity (\sum_(V | V \in \nu^{B}(P)) \sum_(tb in V.-shell ta) diff --git a/information_theory/kraft.v b/information_theory/kraft.v index cb2ba05e..3289b886 100644 --- a/information_theory/kraft.v +++ b/information_theory/kraft.v @@ -17,10 +17,6 @@ Require Import ssr_ext. (* University Press, 2002 *) (******************************************************************************) -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - (* OUTLINE: 1. Section prefix. 2. Section ary_of_nat. @@ -34,20 +30,23 @@ Unset Printing Implicit Defensive. 10. wip *) +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + Lemma empty_finType_nil (T : finType) : (#|T| = 0) -> forall c : seq T, c = [::]. Proof. move/card0_eq => T0; by case=> // h; move: (T0 h); rewrite !inE. Qed. Lemma sorted_leq_last s : sorted leq s -> forall i, i \in s -> i <= last 0 s. Proof. move=> H /= i; case/(nthP O) => {}i Hi <-; rewrite -nth_last. -case/boolP : (i == (size s).-1) => [/eqP <- //|si]. +have [<-//|si] := eqVneq i (size s).-1. apply (sorted_ltn_nth leq_trans) => //. -by rewrite inE prednK // (leq_trans _ Hi). + by rewrite inE prednK // (leq_trans _ Hi). by rewrite ltn_neqAle si /= -ltnS prednK // (leq_trans _ Hi). Qed. Section prefix. - Variable T : eqType. Implicit Types a b : seq T. @@ -85,8 +84,8 @@ Proof. case/prefixP => t /eqP <-{s} /prefixP[t']. wlog : t t' a b / size a <= size b. move=> H. - case/boolP : (size a <= size b) => [? K|]; first exact: (H t t'). - rewrite leqNgt negbK => /ltnW /(H t' t) {}H /eqP/esym/eqP; tauto. + have [? K|] := leqP (size a) (size b); first exact: (H t t'). + by move=> /ltnW /(H t' t) {}H /eqP/esym/eqP; tauto. move=> ab H; left; apply/prefixP; exists (take (size b - size a) t). move/eqP : H => /(congr1 (take (size b))). by rewrite take_cat ltnn subnn take0 cats0 take_cat ltnNge ab /= => <-. @@ -326,7 +325,7 @@ Lemma empty_finType_code_set (C : code_set) : (#|T| = 0) -> C = [::] :> seq _ \/ C = [:: [::]] :> seq _. Proof. move=> T0. -case/boolP : (C == [::] :> seq _); first by move/eqP; left. +have [|] := eqVneq (C : seq _) [::]; first by left. rewrite -size_eq0 => C0; right. have : size C <= 1. rewrite leqNgt. @@ -368,8 +367,8 @@ split. move=> H c c' cC c'C cc' _. by apply H. move=> H c c' cC c'C cc'. - case/boolP : (size c <= size c') => [K|]; first exact: H. - apply: contra => /eqP K. + have [K|] := leqP (size c) (size c'); first exact: H. + rewrite ltnNge; apply: contra => /eqP K. by rewrite -(cat_take_drop (size c) c') {1}K size_cat leq_addr. Qed. @@ -413,18 +412,18 @@ Qed. Lemma injective_w : injective w. Proof. -move=> i j; case/boolP : (w i == 0); rewrite w_eq0 => i0. +move=> i j; have [/eqP|] := eqVneq (w i) 0; rewrite w_eq0 => i0. rewrite (eqP i0) wE0. - case/boolP : (w j == 0); rewrite w_eq0 => j0; first by rewrite (eqP j0). + have [/eqP|] := eqVneq (w j) 0; rewrite w_eq0 => j0; first by rewrite (eqP j0). by move/esym/eqP; rewrite w_eq0 (negbTE j0). -case/boolP : (w j == 0) => [|]; rewrite w_eq0 => j0. +have [/eqP|] := eqVneq (w j) 0; rewrite w_eq0 => j0. by rewrite (eqP j0) wE0 => /eqP; rewrite w_eq0 (negbTE i0). -case/boolP : (i == j) => [/eqP //|ij]. +have [//|ij] := eqVneq i j. wlog : i j i0 j0 ij / i < j. move=> Hwlog H. move: ij; rewrite neq_ltn => /orP[|] ij. - - apply Hwlog => //; by move/negbT : (ltn_eqF ij). - - apply/esym; apply Hwlog => //; by move/negbT : (ltn_eqF ij). + - by apply Hwlog => //; move/negbT : (ltn_eqF ij). + - by apply/esym; apply Hwlog => //; move/negbT : (ltn_eqF ij). move=> {}ij /esym. rewrite /w (bigID (fun i1 : 'I__ => i1 < i)) /=. set a := (X in X + _ = _ -> _). set b := (X in _ = X -> _). @@ -623,7 +622,7 @@ have H' : (\sum_(i < n) #|T|%:R^-(nth O l i) <= (1 : R))%R. move: H; by rewrite /kraft_cond (_ : size l = n). rewrite -(@ler_nat R) -(@ler_pM2l _ (#|T|%:R ^- nth O l j))%R; last first. by rewrite -exprVn exprn_gt0 // invr_gt0 ltr0n card_ord. -case/boolP : (j == ord0) => [/eqP ->|i0]. +have [->|i0] := eqVneq j ord0. by rewrite wE0 mulr0 mulr_ge0 // -exprVn exprn_ge0 // invr_ge0 ler0n. rewrite !natrB ?expn_gt0 ?card_ord // -!natrX. rewrite mulrBr mulVr ?unitfE ?mulr1 ?pnatr_eq0 ?expn_eq0 //. @@ -720,9 +719,9 @@ have H1 : (r >= (w j)%:R + (1 : R))%R. (*\color{comment}{\framebox{here we prove (*\framebox{\color{comment}{let $u = \sum_{j \leq i < k} |T|^{\ell_j}|T|^{-\ell_i}$}} *) have -> : (r' = (w j)%:R + u :> R)%R. (* \color{comment}{\framebox{$r' = w_j + u$, Eqn (\ref{eqn:kraft_converse2})}} *) pose f := (fun i : nat => #|T|%:R^+l``_j * #|T|%:R^-l``_i : R)%R. - case/boolP : (j == ord0) => j0. - rewrite /u (eqP j0) wE0 add0r big_mkord /r'. - apply/eq_bigr => i _; by rewrite (eqP j0). + have [j0|j0] := eqVneq j ord0. + rewrite /u j0 wE0 add0r big_mkord /r'. + by apply/eq_bigr => i _; rewrite j0. rewrite /r' /u -(big_mkord xpredT f)%R natr_sum. rewrite (eq_bigr (fun i : 'I__ => f i)); last first. move=> i _; rewrite natrX exprB //. @@ -768,7 +767,8 @@ Record code_set_cw M := CodeSetCw { codesetcw :> {set M.-bseq T} }. -Definition code_set_cw_of_code_set (c : code_set T) : code_set_cw (foldr maxn O (map size c)). +Definition code_set_cw_of_code_set (c : code_set T) : + code_set_cw (foldr maxn O (map size c)). Proof. set M := foldr maxn O (map size c). pose l : seq (M.-bseq T) := map (@insub_bseq M T) (codeset c). diff --git a/information_theory/pproba.v b/information_theory/pproba.v index 927744f1..a8e109f3 100644 --- a/information_theory/pproba.v +++ b/information_theory/pproba.v @@ -1,9 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect all_algebra zmodp matrix. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext ssr_ext ssralg_ext bigop_ext fdist proba. +From mathcomp Require Import Rstruct reals. +Require Import ssr_ext ssralg_ext realType_ext bigop_ext fdist proba. Require Import channel jfdist_cond. (******************************************************************************) @@ -33,9 +32,9 @@ Import Prenex Implicits. Local Open Scope fdist_scope. Local Open Scope proba_scope. Local Open Scope channel_scope. -Local Open Scope R_scope. +Local Open Scope ring_scope. -Import Num.Theory. +Import Order.POrderTheory GRing.Theory Num.Theory. Section receivable. Variables (A B : finType) (n : nat) (P : {fdist 'rV[A]_n}) (W : `Ch(A, B)). @@ -60,16 +59,16 @@ Proof. apply/idP/idP => [|H]. - case/existsP => /= x /andP[Px0]. apply: contra => /eqP /psumr_eq0P => /= H. - apply/eqP; rewrite -(@eqR_mul2l (P x)); last exact/eqP. - by rewrite mulR0 H // => /= x' _; rewrite RmultE mulr_ge0//. + rewrite -(@mulrI_eq0 _ (P x)); last by rewrite /GRing.lreg; apply: mulfI. + by rewrite H// => /= x' _; rewrite mulr_ge0//. - have /= : \sum_(x in setT) P x * W ``(y | x) != 0. apply: contra H => /eqP H; apply/eqP. - rewrite -[RHS]H; apply/eq_bigl => /= x; by rewrite !inE. + by rewrite -[RHS]H; apply/eq_bigl => /= x; rewrite !inE. apply: contraNT. rewrite /receivable_prop negb_exists => /forallP /= {}H. apply/eqP/big1 => x _. by move: (H x); rewrite negb_and 2!negbK => /orP[|] /eqP ->; - rewrite ?(mul0R,mulR0). + rewrite ?(mul0r,mulr0). Qed. End receivable_prop. @@ -85,7 +84,7 @@ Lemma not_receivable_prop_uniform : Proof. apply/idP/idP => [|/eqP]. - rewrite negb_exists => /forallP H. - rewrite (eq_bigr (fun=> 0)) ?big_const ?iter_addR ?mulR0 // => i iC. + rewrite big1// => i iC. move: (H i). rewrite negb_and !negbK => /orP[|/eqP //]. by rewrite -(negbK (_ == _)) fdist_uniform_supp_neq0 iC. @@ -111,17 +110,16 @@ Proof. by apply/sumr_ge0 => x _; exact: mulr_ge0. Qed. Let f0 x : 0 <= f x. Proof. -rewrite ffunE; apply/RleP; rewrite -RdivE. -apply: divR_ge0; first exact: mulR_ge0. -apply/RltP; rewrite lt0r {1}/den -receivable_propE receivableP. +rewrite ffunE. +apply: mulr_ge0; first exact: mulr_ge0. +rewrite invr_ge0// ltW// lt0r {1}/den -receivable_propE receivableP. exact/fdist_post_prob_den_ge0. Qed. Let f1 : \sum_(x in 'rV_n) f x = 1. Proof. under eq_bigr do rewrite ffunE /=. -rewrite -big_distrl /= -RmultE mulRC -RinvE. -by rewrite mulVR // -receivable_propE receivableP. +by rewrite -big_distrl /= mulrC mulVf// -receivable_propE receivableP. Qed. Definition fdist_post_prob : {fdist 'rV[A]_n} := locked (FDist.make f0 f1). @@ -139,9 +137,9 @@ Variables (A B : finType) (W : `Ch(A, B)) (n : nat) (P : {fdist 'rV[A]_n}). Lemma post_probE (x : 'rV[A]_n) (y : P.-receivable W) : P `^^ W (x | y) = \Pr_(P `X (W ``^ n))[ [set x] | [set receivable_rV y]]. Proof. -rewrite fdist_post_probE /jcPr setX1 2!Pr_set1 fdist_prodE /= -RdivE. +rewrite fdist_post_probE /jcPr setX1 2!Pr_set1 fdist_prodE /=. congr (_ / _). -by rewrite fdist_sndE /=; apply eq_bigr => x' _; rewrite fdist_prodE /= -RmultE mulRC. +by rewrite fdist_sndE /=; apply eq_bigr => x' _; rewrite fdist_prodE /= mulrC. Qed. End posterior_probabilityE. @@ -153,7 +151,7 @@ Hypothesis HC : (0 < #| C |)%nat. Variable y : (`U HC).-receivable W. Local Open Scope ring_scope. -Definition post_prob_uniform_cst := / \sum_(c in C) W ``(y | c). +Definition post_prob_uniform_cst := (\sum_(c in C) W ``(y | c))^-1. Let K := post_prob_uniform_cst. @@ -161,40 +159,34 @@ Lemma post_prob_uniformF (x : 'rV[A]_n) : x \notin C -> (`U HC) `^^ W (x | y) = 0. Proof. move=> xC; rewrite fdist_post_probE fdist_uniform_supp_notin //. -by rewrite -!RmultE !mul0R. +by rewrite !mul0r. Qed. Lemma post_prob_uniformT (x : 'rV[A]_n) : x \in C -> (`U HC) `^^ W (x | y) = K * W ``(y | x). Proof. move=> Ht. -have C0 : INR #|C| != 0 by rewrite INR_eq0' -lt0n. -rewrite fdist_post_probE fdist_uniform_supp_in // -RinvE. -rewrite -!RmultE mulRC -RinvE mulRA. +have C0 : #|C|%:R != 0 :> Rdefinitions.R by rewrite pnatr_eq0 -lt0n. +rewrite fdist_post_probE fdist_uniform_supp_in //. +rewrite mulrC mulrA. congr (_ * _). -rewrite /den fdist_uniform_supp_restrict. -rewrite -invRM//. -3: by rewrite -INRE. - rewrite /K /post_prob_uniform_cst; congr Rinv. - rewrite !RmultE -INRE. - rewrite big_distrl /=. - apply eq_bigr => i iC. - rewrite fdist_uniform_supp_in //. - rewrite GRing.mulrAC INRE GRing.mulVr ?GRing.mul1r//. - by rewrite GRing.unitfE -INRE. -rewrite (eq_bigr (fun t => 1 / INR #|C| * W ``(y | t))); last first. +rewrite fdist_uniform_supp_restrict. +rewrite -invfM//. +rewrite (eq_bigr (fun t => 1 / #|C|%:R * W ``(y | t))); last first. move=> *; rewrite fdist_uniform_supp_in//. - by rewrite GRing.div1r INRE. -apply/eqP; rewrite -big_distrr /= mulR_eq0 => -[]. - by rewrite -RdivE// div1R; apply/invR_neq0/eqP. -by apply/eqP; rewrite -not_receivable_prop_uniform receivableP. + by rewrite mul1r. +rewrite /K /post_prob_uniform_cst; congr (_^-1)%R. +rewrite big_distrl /=. +apply eq_bigr => i iC. +rewrite mul1r. +by rewrite mulrAC mulVf// mul1r. Qed. Lemma post_prob_uniform_kernel (x : 'rV[A]_n) : (`U HC) `^^ W (x | y) = (K * (x \in C)%:R * W ``(y | x))%R. Proof. case/boolP : (x \in C) => xC. -- by rewrite post_prob_uniformT // ?inE // mulR1. -- by rewrite post_prob_uniformF ?inE // mulR0 mul0R. +- by rewrite post_prob_uniformT // ?inE // mulr1. +- by rewrite post_prob_uniformF ?inE // mulr0 mul0r. Qed. End posterior_probability_prop. @@ -209,26 +201,24 @@ Local Open Scope ring_scope. Let f' := fun x : 'rV_n => P `^^ W (x | y). -Definition marginal_post_prob_den : R := / \sum_(t in 'rV_n) f' t. +Definition marginal_post_prob_den : Rdefinitions.R := (\sum_(t in 'rV_n) f' t)^-1. Let f'_neq0 : \sum_(t in 'rV_n) f' t <> 0. Proof. -under eq_bigr do rewrite /f' fdist_post_probE /Rdiv. -rewrite -big_distrl /= mulR_eq0 => -[/eqP|]. -- by apply/negP; rewrite -receivable_propE receivableP. -- by rewrite -RinvE; apply/invR_neq0/eqP; rewrite -receivable_propE receivableP. +under eq_bigr do rewrite /f' fdist_post_probE. +apply/eqP; rewrite -big_distrl /= mulf_eq0 negb_or; apply/andP; split. +- by rewrite -receivable_propE receivableP. +- by rewrite invr_eq0 -receivable_propE receivableP. Qed. Let f (i : 'I_n) := [ffun a => marginal_post_prob_den * \sum_(t in 'rV_n | t ``_ i == a) f' t]. Let f0 i a : 0 <= f i a. Proof. -rewrite ffunE; apply/RleP/mulR_ge0. -- rewrite / marginal_post_prob_den. - apply/invR_ge0/RltP; rewrite lt0r/=; apply/andP; split; [apply/eqP |apply/RleP]; last first. - exact/RleP/sumr_ge0. - exact/f'_neq0. -- exact/RleP/sumr_ge0. +rewrite ffunE; apply/mulr_ge0. +- rewrite /marginal_post_prob_den. + by rewrite invr_ge0//; apply/sumr_ge0. +- by apply/sumr_ge0 => //. Qed. Let f1 i : \sum_(a in A) f i a = 1. @@ -239,7 +229,7 @@ set tmp1 := \sum_( _ | _ ) _. set tmp2 := \sum_( _ | _ ) _. suff : tmp1 = tmp2. move=> tp12; rewrite -tp12. - by rewrite -RmultE mulVR //; exact/eqP/f'_neq0. + by rewrite mulVf//; exact/eqP/f'_neq0. by rewrite {}/tmp1 {}/tmp2 (partition_big (fun x : 'rV_n => x ``_ i) xpredT). Qed. @@ -262,3 +252,4 @@ End marginal_post_prob_prop. Notation "P ''_' n0 '`^^' W '(' a '|' y ')'" := (@fdist_marginal_post_prob _ _ W _ P y n0 a) : proba_scope. + diff --git a/information_theory/shannon_fano.v b/information_theory/shannon_fano.v index 21495e93..e8311263 100644 --- a/information_theory/shannon_fano.v +++ b/information_theory/shannon_fano.v @@ -1,10 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrZ ssrR logb Reals_ext realType_ext ssr_ext fdist. -Require Import entropy kraft. +From mathcomp Require Import all_ssreflect all_algebra archimedean. +From mathcomp Require Import Rstruct mathcomp_extra reals exp. +Require Import ssr_ext bigop_ext realType_ext realType_ln fdist entropy kraft. (******************************************************************************) (* Shannon-Fano codes *) @@ -19,13 +17,13 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope R_scope. +Local Open Scope ring_scope. -Import Order.POrderTheory Num.Theory. +Import Order.POrderTheory Num.Theory GRing.Theory. Definition kraft_condR (T : finType) (sizes : seq nat) := let n := size sizes in - (\sum_(i < n) #|T|%:R^-(nth O sizes i) <= (1 : R))%R. + (\sum_(i < n) #|T|%:R^-(nth O sizes i) <= (1 : Rdefinitions.R))%R. Local Open Scope fdist_scope. @@ -41,10 +39,8 @@ Section shannon_fano_def. Variables (A T : finType) (P : {fdist A}). -Local Open Scope zarith_ext_scope. - Definition is_shannon_fano (f : Encoding.t A T) := - forall s, size (f s) = '| ceil (Log #|T|%:R (1 / P s)%R) |. + forall s, size (f s) = `| Num.ceil (Log #|T|%:R (P s)^-1%R) |%N. End shannon_fano_def. @@ -65,36 +61,27 @@ Lemma shannon_fano_is_kraft : is_shannon_fano P f -> kraft_condR T sizes. Proof. move=> H. rewrite /kraft_condR. -rewrite (_ : 1 = 1%mcR)//. rewrite -(FDist.f1 P) /sizes size_map. rewrite (eq_bigr (fun i:'I_(size(enum A)) => #|'I_t|%:R ^- size (f (nth a (enum A) i)))); last first. - move=> i _; by rewrite /= (nth_map a). + by move=> i _; rewrite /= (nth_map a)// FDist.f1. rewrite -(big_mkord xpredT (fun i => #|T|%:R ^- size (f (nth a (enum A) i)))). rewrite -(big_nth a xpredT (fun i => #|'I_t|%:R ^- size (f i))). rewrite enumT. -apply leR_sumR => i _. +apply ler_sum => i _. rewrite H. -have Pi0 : 0 < P i by apply/RltP; rewrite lt0r Pr0/=. -apply (@leR_trans (Exp #|T|%:R (- Log #|T|%:R (1 / P i)))); last first. - rewrite div1R LogV// oppRK LogK //; first by apply/RleP; rewrite lexx. - by rewrite (_ : 1 = 1%:R) // ltR_nat card_ord. -rewrite pow_Exp; last by apply ltR0n; rewrite card_ord. -rewrite Exp_Ropp. -apply/leR_inv/Exp_le_increasing => //. - by rewrite (_ : 1 = 1%:R) // ltR_nat card_ord. -rewrite INR_Zabs_nat; last first. - case/boolP : (P i == 1) => [/eqP ->|Pj1]. - by rewrite divR1 Log_1 /ceil fp_R0 eqxx /=; apply/Int_part_ge0. - apply/leR0ceil/ltRW/ltR0Log. - by rewrite (_ : 1 = 1%:R) // ltR_nat card_ord. - rewrite div1R invR_gt1 // ltR_neqAle; split => //; exact/eqP. -by set x := Log _ _; case: (ceilP x). +have Pi0 : 0 < P i by rewrite lt0r Pr0/=. +apply (@le_trans _ _ (#|T|%:R `^ (- Log #|T|%:R (P i)^-1))%R); last first. + by rewrite LogV// opprK natn LogK// card_ord. +rewrite -powR_mulrn; last by rewrite card_ord. +rewrite powRN card_ord lef_pV2// ?posrE ?powR_gt0//. +rewrite gt1_ler_powRr ?ltr1n//. +rewrite (le_trans (ceil_ge _))//. +by rewrite natr_absz// ler_int ler_norm. Qed. End shannon_fano_is_kraft. Section average_length. - Variables (A T : finType) (P : {fdist A}). Variable f : {ffun A -> seq T}. (* encoding function *) @@ -116,38 +103,38 @@ Lemma shannon_fano_average_entropy : is_shannon_fano P f -> average P f < `H P + 1. Proof. move=> H; rewrite /average. -apply (@ltR_leR_trans (\sum_(x in A) P x * (- Log #|T|%:R (P x) + 1))). +apply (@lt_le_trans _ _ (\sum_(x in A) P x * (- Log #|T|%:R (P x) + 1))). apply: ltR_sumR. apply: fdist_card_neq0. exact: P. move=> i. - apply ltR_pmul2l; first by apply/RltP; rewrite lt0r Pr_pos /=. + rewrite ltr_pM2l//; last by apply/fdist_gt0. rewrite H. rewrite (_ : #|T|%:R = 2) // ?card_ord // -!/(log _). - set x := log _; case: (ceilP x) => _ Hx. - have Pi0 : 0 < P i by apply/RltP; rewrite lt0r Pr_pos /=. - rewrite INR_Zabs_nat; last first. - apply/leR0ceil. - rewrite /x div1R /log LogV //. - apply oppR_ge0. - by rewrite -(Log_1 2); apply Log_increasing_le. - case: (ceilP x) => _. - by rewrite -LogV // -/(log _) -(div1R _) /x. -under eq_bigr do rewrite mulRDr mulR1 mulRN. -rewrite big_split /= FDist.f1 leR_add2r. -apply Req_le. -rewrite /entropy big_morph_oppR; apply eq_bigr => i _. -by rewrite card_ord (_ : 2%:R = 2). + set x := log _. + rewrite -ltrBlDr. + rewrite (le_lt_trans _ (gt_pred_ceil _))// ?num_real//. + rewrite natr_absz. + rewrite intrD lerB// ler_int. + rewrite /x logV -?fdist_gt0//. + rewrite -[leRHS]gez0_abs//. + rewrite -mathcomp_extra.ceil_ge0//. + rewrite (@lt_le_trans _ _ 0)// ?ltrN10// lerNr oppr0. + by rewrite -log1 ler_log// ?posrE// -fdist_gt0. +under eq_bigr do rewrite mulrDr mulr1 mulrN. +rewrite big_split /= FDist.f1 lerD2r. +apply/eqW. +rewrite /entropy big_morph_oppr; apply eq_bigr => i _. +by rewrite card_ord. Qed. End shannon_fano_suboptimal. (* wip *) Section kraft_code_is_shannon_fano. - Variables (A : finType) (P : {fdist A}). -Variable (t' : nat). +Variable t' : nat. Let n := #|A|.-1.+1. Let t := t'.+2. Let T := 'I_t. @@ -163,14 +150,14 @@ move=> x y. rewrite !ffunE => /eqP xy. rewrite -(enum_rankK x) -(enum_rankK y); congr enum_val. apply/ord_inj/eqP. -rewrite -(@nth_uniq _ [::] C (enum_rank x) (enum_rank y)) //; last first. - rewrite /C /ACode /= /acode map_inj_uniq //. - exact/enum_uniq. +rewrite -(@nth_uniq _ [::] C (enum_rank x) (enum_rank y)) //. +- rewrite /C /ACode /= /acode size_map size_enum_ord prednK //. + exact: (fdist_card_neq0 P). +- rewrite /C /ACode /= /acode size_map size_enum_ord prednK //. + exact: (fdist_card_neq0 P). +- rewrite /C /ACode /= /acode map_inj_uniq //. + exact/enum_uniq. exact/injective_sigma. -rewrite /C /ACode /= /acode size_map size_enum_ord prednK //. -exact: (fdist_card_neq0 P). -rewrite /C /ACode /= /acode size_map size_enum_ord prednK //. -exact: (fdist_card_neq0 P). Qed. Let f := Encoding.mk f_inj. diff --git a/information_theory/source_code.v b/information_theory/source_code.v index bb9146e5..fd6ee618 100644 --- a/information_theory/source_code.v +++ b/information_theory/source_code.v @@ -1,9 +1,8 @@ -(* infotheo: information theory and error-correcting codes in Coq *) -(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) +(* infotheo: information theory and error-correcting codes in Coq *) +(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext logb fdist proba. +From mathcomp Require Import Rstruct reals. +Require Import realType_ln fdist proba. (******************************************************************************) (* Definition of a source code *) @@ -17,8 +16,6 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. - Declare Scope source_code_scope. Section scode_definition. @@ -36,27 +33,30 @@ Local Open Scope fdist_scope. Local Open Scope proba_scope. Section scode_vl_definition. +Let R := Rdefinitions.R. Variables (A : finType) (k n : nat). Definition scode_vl := scode A (seq bool) k. Variables (P : R.-fdist A) (f : {RV (P `^ n) -> seq bool}). -Definition E_leng_cw := `E ((INR \o size) `o f). +Definition E_leng_cw := `E (((fun x => x%:R)%R \o size) `o f). End scode_vl_definition. Section scode_fl_definition. +Let R := Rdefinitions.R. Variables (A : finType) (k n : nat). Definition scode_fl := scode A 'rV[bool]_n k. -Definition SrcRate (sc : scode_fl) := n%:R / k%:R. +Definition SrcRate (sc : scode_fl) : R := (n%:R / k%:R)%R. End scode_fl_definition. Section code_error_rate. -Variables (A : finType) (B : Type) (P : {fdist A}). +Let R := Rdefinitions.R. +Variables (A : finType) (B : Type) (P : R.-fdist A). Variables (k : nat) (sc : scode A B k). Definition SrcErrRate := Pr (P `^ k) [set ta | dec sc (enc sc ta) != ta]. diff --git a/information_theory/source_coding_fl_converse.v b/information_theory/source_coding_fl_converse.v index 03eab1d8..5f61d07d 100644 --- a/information_theory/source_coding_fl_converse.v +++ b/information_theory/source_coding_fl_converse.v @@ -1,9 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. -Require Import Reals Lra. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext realType_ext logb fdist proba entropy aep. +From mathcomp Require Import all_ssreflect ssralg ssrnum matrix lra ring. +From mathcomp Require Import Rstruct reals exp. +Require Import realType_ext realType_ln fdist proba entropy aep. Require Import typ_seq source_code. (******************************************************************************) @@ -23,16 +22,31 @@ Import Prenex Implicits. Local Open Scope source_code_scope. Local Open Scope entropy_scope. Local Open Scope reals_ext_scope. -Local Open Scope R_scope. +Local Open Scope ring_scope. Local Open Scope fdist_scope. -Import Order.POrderTheory GRing.Theory Num.Theory. +Import Order.POrderTheory GRing.Theory Num.Theory Num.Def Order.TotalTheory. -Section source_coding_converse'. +(* TODO: move *) +Lemma minr_case_strong (R : realType) (r1 r2 : R) + (P : R -> Prop) : + (r1 <= r2 -> P r1) -> +(r2 <= r1 -> P r2) -> P (minr r1 r2). +Proof. +move=> H1 H2. +rewrite /minr. +case: ifPn => r12. + apply: H1. + exact: ltW. +apply: H2. +by rewrite leNgt. +Qed. +Section source_coding_converse'. +Let R := Rdefinitions.R. Variables (A : finType) (P : {fdist A}). Variables num den : nat. -Let r := num%:R / den.+1%:R. +Let r : R := num%:R / den.+1%:R. Hypothesis Hr : 0 < r < `H P. Variable n : nat. @@ -43,10 +57,10 @@ Hypothesis r_sc : r = SrcRate sc. Variable epsilon : R. Hypothesis Hepsilon : 0 < epsilon < 1. -Local Notation "'max(' x ',' y ')'" := (Rmax x y) : reals_ext_scope. +Local Notation "'max(' x ',' y ')'" := (maxr x y) : reals_ext_scope. -Definition lambda := min((1 - epsilon) / 2, (`H P - r) / 2). -Definition delta := min((`H P - r) / 2, lambda / 2). +Definition lambda := minr ((1 - epsilon) / 2) ((`H P - r) / 2). +Definition delta := minr ((`H P - r) / 2) (lambda / 2). Definition SrcConverseBound := max(max( aep_bound P delta, - ((log delta) / (`H P - r - delta))), n%:R / r). @@ -55,27 +69,28 @@ Hypothesis Hk : SrcConverseBound <= k.+1%:R. Lemma Hr1 : 0 < (`H P - r) / 2. Proof. -apply divR_gt0; last lra. -by case: Hr => ? ?; lra. +apply divr_gt0; last lra. +by case/andP: Hr => ? ?; lra. Qed. Lemma Hepsilon1 : 0 < (1 - epsilon) / 2. Proof. -apply divR_gt0; last lra. -by case: Hepsilon => ? ?; lra. +apply divr_gt0; last lra. +by case/andP: Hepsilon => ? ?; lra. Qed. Lemma lambda0 : 0 < lambda. Proof. -by rewrite /lambda; apply Rmin_case => //; [exact Hepsilon1 | exact Hr1]. +by rewrite /lambda lt_min; apply/andP; split; [exact Hepsilon1 | exact Hr1]. Qed. -Lemma Hdelta : 0 < delta. +Lemma Hdelta : (0 < delta)%mcR. Proof. rewrite /delta. -apply Rmin_pos. -case: Hr => ? ?; apply divR_gt0; lra. -apply divR_gt0; [exact lambda0 | lra]. +rewrite lt_min. +apply/andP; split. +case/andP: Hr => ? ?; apply divr_gt0; lra. +apply divr_gt0; [exact lambda0 | lra]. Qed. Definition e0 := `H P - r. @@ -83,168 +98,177 @@ Definition e0 := `H P - r. Lemma e0_delta : e0 <> delta. Proof. rewrite /e0 /delta /lambda -/r. -apply Rmin_case_strong => H1; first by lra. -apply Rmin_case_strong => H2. -- apply/eqP/gtR_eqF; apply: leR_ltR_trans. - + apply: (leR_trans _ H2). - rewrite leR_pdivr_mulr //; apply leR_pmulr; [lra|exact/ltRW/Hepsilon1]. - * rewrite ltR_pdivr_mulr //; lra. -- by rewrite /Rdiv -mulRA (_ : ( _ * / 2 ) = / 4); [lra | field]. +apply/eqP. +apply: (@minr_case_strong _ ((`H P - r) / 2) (minr ((1 - epsilon) / 2) ((`H P - r) / 2) / 2) (fun x => `H P - r != x)) => H1. + case/andP : Hr => ? ?. + lra. +apply: (@minr_case_strong _ ((1 - epsilon) / 2) (((`H P - r) / 2)) ((fun x => `H P - r != x / 2))) => H2. +- rewrite gt_eqF//; apply: le_lt_trans. + + apply: (le_trans _ H2). + rewrite ler_pdivrMr // ler_pMr ?ler1n// divr_gt0// subr_gt0. + by case/andP : Hepsilon. + + rewrite ltr_pdivrMr //. + case/andP : Hr => ? ?. + lra. +- case/andP : Hr => ? ?. + lra. Qed. Definition no_failure := [set x : 'rV[A]_k.+1 | dec sc (enc sc x) == x]. -Lemma no_failure_sup : #| no_failure |%:R <= exp2 (k.+1%:R * (`H P - e0)). +Lemma no_failure_sup : #| no_failure |%:R <= ((2:R) `^ (k.+1%:R * (`H P - e0)))%R. Proof. -apply (@leR_trans (exp2 n%:R)). +apply (@le_trans _ _ (2%R `^ n%:R)%R). rewrite /no_failure. have Hsubset : [set x | dec sc (enc sc x) == x] \subset dec sc @: (enc sc @: [set: 'rV[A]_k.+1]). apply/subsetP => x; rewrite inE => /eqP Hx. by apply/imsetP; exists (enc sc x) => //; rewrite imset_f. - apply (@leR_trans #| dec sc @: (enc sc @: [set: 'rV[A]_k.+1]) |%:R). - by apply/le_INR/leP; case/subset_leqif_cards : Hsubset. - apply (@leR_trans #| dec sc @: [set: 'rV[bool]_n] |%:R). - by apply/le_INR/leP/subset_leqif_cards/imsetS/subsetP => x Hx; rewrite inE. - apply (@leR_trans #| [set: 'rV[bool]_n] |%:R). - exact/le_INR/leP/leq_imset_card. - rewrite cardsT card_mx /= card_bool natRexp2 mul1n. - by apply/RleP; rewrite lexx. -apply Exp_le_increasing => //. + apply (@le_trans _ _ #| dec sc @: (enc sc @: [set: 'rV[A]_k.+1]) |%:R). + by rewrite ler_nat; case/subset_leqif_cards : Hsubset. + apply (@le_trans _ _ #| dec sc @: [set: 'rV[bool]_n] |%:R). + by rewrite ler_nat; apply/subset_leqif_cards/imsetS/subsetP => x Hx; rewrite inE. + apply (@le_trans _ _ #| [set: 'rV[bool]_n] |%:R). + by rewrite ler_nat; exact/leq_imset_card. + rewrite cardsT card_mx /= card_bool mul1n. + by rewrite powR_mulrn// natrX. +rewrite gt1_ler_powRr ?ltr1n//. rewrite /e0 [X in _ <= _ * X](_ : _ = r); last by field. -apply (@leR_pmul2r (1 / r)) => //. - by apply divR_gt0; [lra | tauto]. -rewrite -mulRA div1R mulRV ?mulR1; last first. - by case: Hr => /RltP; rewrite lt0r => /andP[]. -by case/leR_max : Hk. +rewrite -(@ler_pM2r _ (r^-1)) => //; last first. + by rewrite invr_gt0//; case/andP : Hr. +rewrite -mulrA mulfV ?mulr1; last first. + by case/andP : Hr => r0 _; rewrite gt_eqF. +rewrite (le_trans _ Hk)//. +by rewrite /SrcConverseBound le_max lexx orbT. Qed. Local Open Scope fdist_scope. -Lemma step1 : (1 - esrc(P , sc)) = \sum_(x in no_failure) P `^ k.+1 x. +Lemma step1 : (1 - esrc(P , sc)) = \sum_(x in no_failure) (P `^ k.+1)%fdist x. Proof. rewrite /SrcErrRate /no_failure /Pr. set a := \sum_(_ | _) _. set b := \sum_(_ | _) _. suff : 1 = a + b by move=> ->; field. rewrite /a {a}. -have -> : b = \sum_(i in [set i | dec sc (enc sc i) == i]) P `^ k.+1 i. - apply eq_big => // i /=; by rewrite inE. -rewrite (_ : 1 = 1%mcR)//. +have -> : b = \sum_(i in [set i | dec sc (enc sc i) == i]) (P `^ k.+1)%fdist i. + by apply eq_big => // i /=; rewrite inE. rewrite -(FDist.f1 (P `^ k.+1)). -rewrite (bigID [pred a | a \in [set i0 | dec sc (enc sc i0) == i0]]) /= addRC. +rewrite (bigID [pred a | a \in [set i0 | dec sc (enc sc i0) == i0]]) /= addrC. by congr (_ + _); apply eq_bigl => t /=; rewrite !inE. Qed. Local Open Scope typ_seq_scope. Lemma step2 : 1 - (esrc(P , sc)) = - \sum_(x in 'rV[A]_k.+1 | x \in no_failure :&: ~: `TS P k.+1 delta) P `^ k.+1 x + - \sum_(x in 'rV[A]_k.+1 | x \in no_failure :&: `TS P k.+1 delta) P `^ k.+1 x. + \sum_(x in 'rV[A]_k.+1 | x \in no_failure :&: ~: `TS P k.+1 delta) (P `^ k.+1)%fdist x + + \sum_(x in 'rV[A]_k.+1 | x \in no_failure :&: `TS P k.+1 delta) (P `^ k.+1)%fdist x. Proof. -rewrite step1 (bigID [pred x | x \in `TS P k.+1 delta]) /= addRC. +rewrite step1 (bigID [pred x | x \in `TS P k.+1 delta]) /= addrC. f_equal. -- apply eq_bigl => x; by rewrite in_setI in_setC. -- apply eq_bigl => x; by rewrite in_setI. +- by apply eq_bigl => x; rewrite in_setI in_setC. +- by apply eq_bigl => x; rewrite in_setI. Qed. Lemma step3 : 1 - (esrc(P , sc)) <= - \sum_(x in 'rV[A]_k.+1 | x \in ~: `TS P k.+1 delta) P `^ k.+1 x + - \sum_(x in 'rV[A]_k.+1 | x \in no_failure :&: `TS P k.+1 delta) P `^ k.+1 x. + \sum_(x in 'rV[A]_k.+1 | x \in ~: `TS P k.+1 delta) (P `^ k.+1)%fdist x + + \sum_(x in 'rV[A]_k.+1 | x \in no_failure :&: `TS P k.+1 delta) (P `^ k.+1)%fdist x. Proof. -rewrite step2; apply/leR_add2r/leR_sumRl => //= i Hi. - by apply/RleP; rewrite lexx. -by move: Hi; rewrite in_setI => /andP[]. +rewrite step2 lerD2r//. +apply: bigop_ext.ler_suml => //= i. +by rewrite in_setI => /andP[]. Qed. Lemma step4 : 1 - (esrc(P , sc)) <= delta + - #| no_failure :&: `TS P k.+1 delta|%:R * exp2 (- k.+1%:R * (`H P - delta)). + #| no_failure :&: `TS P k.+1 delta|%:R * 2 `^ (- k.+1%:R * (`H P - delta)). Proof. -apply/(leR_trans step3)/leR_add. -- move: Hk => /leR_max[] /leR_max[]. +apply/(le_trans step3); rewrite lerD//. +- move: Hk. + rewrite !ge_max => /andP[] /andP[]. move/(Pr_TS_1 Hdelta) => Hdelta _ _. - rewrite -[in X in _ <= X](oppRK delta) leR_oppr -(@leR_add2l 1) 2!addR_opp. - move/leR_trans : Hdelta; apply. - rewrite Pr_to_cplt. - by apply/RleP; rewrite lexx. -- apply (@leR_trans + rewrite -[in X in _ <= X](opprK delta) lerNr -(@lerD2l _ 1). + apply: (le_trans Hdelta). + by rewrite Pr_to_cplt lexx. +- apply (@le_trans _ _ (\sum_(x in 'rV[A]_k.+1 | x \in no_failure :&: `TS P k.+1 delta) - exp2 (- k.+1%:R * (`H P - delta)))). - apply leR_sumR => /= i. - rewrite in_setI => /andP[i_B i_TS]. - move: (typ_seq_definition_equiv2 i_TS) => [H1 _]. - apply (@Log_le_inv 2) => //. - + move: i_TS. - rewrite /`TS inE /typ_seq => /andP[/RleP i_TS _]. - exact: (ltR_leR_trans (exp2_gt0 _) i_TS). - + rewrite /exp2 ExpK //. - rewrite mulRC mulRN -mulNR -leR_pdivr_mulr; last exact/ltR0n. - rewrite leR_oppr /Rdiv mulRC; by rewrite div1R mulNR in H1. - rewrite big_const iter_addR. - by apply/RleP; rewrite lexx. + 2 `^ (- k.+1%:R * (`H P - delta)))); last first. + by rewrite big_const iter_addr mulr_natl addr0. + apply ler_sum => /= i. + rewrite in_setI => /andP[i_B i_TS]. + move: (typ_seq_definition_equiv2 i_TS) => /andP[+ _]. + rewrite -[in X in X -> _](@ler_nM2l _ (- (k.+1%:R))); last first. + by rewrite ltrNl oppr0 ltr0n. + rewrite mulrA mulrN !mulNr opprK divff ?pnatr_eq0// mul1r => H2. + have := FDist.ge0 (P `^ k.+1) i. + rewrite le_eqVlt => /predU1P[<-|Pki0]; first by rewrite powR_ge0. + rewrite -ler_log ?posrE ?powR_gt0//. + by rewrite log_powR log2 mulr1. Qed. -Lemma step5 : 1 - (esrc(P , sc)) <= delta + exp2 (- k.+1%:R * (e0 - delta)). +Lemma step5 : 1 - (esrc(P , sc)) <= delta + 2 `^ (- k.+1%:R * (e0 - delta)). Proof. -apply (@leR_trans (delta + #| no_failure |%:R * exp2 (- k.+1%:R * (`H P - delta)))). -- apply/(leR_trans step4)/leR_add2l/leR_wpmul2r => //. - exact/le_INR/leP/subset_leqif_cards/subsetIl. -- apply leR_add2l. - apply (@leR_trans (exp2 (k.+1%:R * (`H P - e0)) * exp2 (- k.+1%:R * (`H P - delta)))); +apply (@le_trans _ _ (delta + #| no_failure |%:R * 2 `^ (- k.+1%:R * (`H P - delta)))). +- apply/(le_trans step4); rewrite lerD2l ler_wpM2r ?powR_ge0// ler_nat. + exact/subset_leqif_cards/subsetIl. +- rewrite lerD2l. + apply (@le_trans _ _ (2 `^ (k.+1%:R * (`H P - e0)) * 2 `^ (- k.+1%:R * (`H P - delta)))); last first. - rewrite -ExpD; apply Exp_le_increasing => //; apply Req_le; by field. - apply leR_wpmul2r => //; exact no_failure_sup. + rewrite -powRD; last by rewrite pnatr_eq0 implybT. + by rewrite gt1_ler_powRr ?ltr1n//; lra. + by rewrite ler_wpM2r ?powR_ge0//; exact: no_failure_sup. Qed. Lemma step6 : 1 - 2 * delta <= esrc(P , sc). Proof. -have H : exp2 (- k.+1%:R * (e0 - delta)) <= delta. - apply (@Log_le_inv 2) => //. - - exact Hdelta. - - rewrite /exp2 ExpK //. - apply (@leR_pmul2r (1 / (e0 - delta))) => //. - + apply divR_gt0; first lra. - apply subR_gt0. - rewrite /e0 /delta /r. - have H1 : (`H P - r) / 2 < `H P - r. - rewrite -[X in _ < X]mulR1. - apply ltR_pmul2l; last lra. - by apply/RltP; rewrite RminusE subr_gt0; apply/RltP; case: Hr. - apply Rmin_case_strong => H2 //; exact: (leR_ltR_trans H2 H1). - + rewrite -mulRA div1R mulRV; last by rewrite subR_eq0'; exact/eqP/e0_delta. - rewrite mulNR mulR1 leR_oppl. - by move: Hk => /leR_max[] /leR_max[]. -suff : 1 - (esrc(P , sc)) <= delta + delta by move=> *; lra. -exact/(leR_trans step5)/leR_add2l. +have H : (2 `^ (- k.+1%:R * (e0 - delta)) <= delta)%R; last first. + suff : 1 - (esrc(P , sc)) <= delta + delta by move=> *; lra. + by apply/(le_trans step5); rewrite lerD2l. +rewrite -ler_log ?posrE ?powR_gt0 ?Hdelta//. +rewrite log_powR log2 mulr1. +rewrite -(@ler_pM2r _ ((e0 - delta)^-1)) ?invr_gt0 ?subr_gt0//; last first. + rewrite /e0 /delta /r. + have H1 : (`H P - r) / 2 < `H P - r. + rewrite -[X in _ < X]mulr1. + rewrite ltr_pM2l ?subr_gt0 ?invf_lt1 ?ltr1n//. + by case/andP : Hr. + apply: (@minr_case_strong _ ((`H P - num%:R / den.+1%:R) / 2) (lambda / 2) (fun x => x < `H P - num%:R / den.+1%:R)) => H2. + exact: H1. + by rewrite (le_lt_trans H2)//. +rewrite -mulrA mulfV ?subr_eq0//; last first. + apply/eqP. + exact: e0_delta. +rewrite mulNr mulr1 lerNl. +by move: Hk; rewrite !ge_max => /andP[/andP[]]. Qed. Theorem source_coding_converse' : epsilon <= esrc(P , sc). Proof. -apply: (leR_trans _ step6). -rewrite -[X in _ <= X]oppRK leR_oppr oppRB leR_subl_addr addRC. -apply (@leR_pmul2l (/ 2)); first lra. -rewrite mulRA mulVR ?mul1R /delta; last exact/eqP. -have H1 : lambda / 2 <= / 2 * (1 - epsilon). - apply (@leR_trans lambda). - by rewrite leR_pdivr_mulr //; apply leR_pmulr; [lra | exact/ltRW/lambda0]. - by rewrite /lambda mulRC; exact: geR_minl. -apply Rmin_case_strong => ? //; exact: (@leR_trans (lambda / 2)). +apply: (le_trans _ step6). +rewrite -[X in _ <= X]opprK lerNr opprB lerBlDr addrC. +rewrite -(@ler_pM2l _ (2^-1)%R) ?invr_gt0//. +rewrite mulrA mulVf ?mul1r /delta ?pnatr_eq0//. +have H1 : lambda / 2 <= 2^-1 * (1 - epsilon). + apply (@le_trans _ _ lambda). + by rewrite ler_pdivrMr// ler_peMr// ?ler1n// ltW// lambda0. + by rewrite /lambda mulrC ge_min lexx. +apply: (@minr_case_strong _ ((`H P - r) / 2) (lambda / 2) + (fun x => x <= 2^-1 * (1 - epsilon))) => //. +by move/le_trans; exact. Qed. End source_coding_converse'. Section source_coding_converse. - Variables (A : finType) (P : {fdist A}). -Theorem source_coding_converse : forall epsilon, 0 < epsilon < 1 -> - forall r : Qplus, 0 < r < `H P -> +Theorem source_coding_converse epsilon : 0 < epsilon < 1 -> + forall nu de : nat, 0 < (nu%:R / de.+1%:R : Rdefinitions.R) < `H P -> forall n k (sc : scode_fl A k.+1 n), - SrcRate sc = r -> - SrcConverseBound P (num r) (den r) n epsilon <= k.+1%:R -> + SrcRate sc = nu%:R / de%:R -> + SrcConverseBound P nu de n epsilon <= k.+1%:R -> epsilon <= esrc(P , sc). Proof. -move=> epsilon Hespilon r r_HP n k sc r_sc Hk_bound. -exact: (@source_coding_converse' _ _ (num r) (den r)). +move=> espilon01 nu de r_HP n k sc r_sc Hk_bound. +exact: (@source_coding_converse' _ _ nu de). Qed. End source_coding_converse. diff --git a/information_theory/source_coding_fl_direct.v b/information_theory/source_coding_fl_direct.v index c73ddde4..2bc6f515 100644 --- a/information_theory/source_coding_fl_direct.v +++ b/information_theory/source_coding_fl_direct.v @@ -1,9 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. -Require Import Reals Lra. -From mathcomp Require Import Rstruct. -Require Import ssrZ ssrR Reals_ext ssr_ext ssralg_ext logb natbin fdist. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint matrix. +From mathcomp Require Import archimedean lra ring. +From mathcomp Require Import Rstruct reals exp. +Require Import ssr_ext ssralg_ext realType_ln natbin fdist. Require Import proba entropy aep typ_seq source_code. (******************************************************************************) @@ -20,10 +20,11 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope ring_scope. Local Open Scope fdist_scope. +Local Open Scope ring_scope. Section encoder_and_decoder. +Let R := Rdefinitions.R. Variables (A : finType) (P : R.-fdist A) (n k : nat). Variable S : {set 'rV[A]_k.+1}. @@ -40,7 +41,7 @@ Hypothesis def_S : def \in S. Definition phi : decT A 'rV_n k.+1 := fun x => let i := tuple2N (tuple_of_row x) in - if i is N0 then def else + if i is BinNat.N0 then def else if (i.-1 < #| S |)%nat then nth def (enum S) i.-1 else def. Lemma phi_f i : phi (f i) = i -> i \in S. @@ -68,7 +69,7 @@ case: eq1 Heq1 => [|i0 Heq1]. - case/tuple2N_0 => Heq1. have : (seq.index i (enum S)).+1 <> O by []. by move=> /bitseq_of_nat_nseq_false/(_ H); rewrite Heq1. -- move Heq : ((Npos i0).-1 < #| S |)%nat => []. +- move Heq : ((BinNat.Npos i0).-1 < #| S |)%nat => []. - by rewrite -Heq1 /= N_of_bitseq_bitseq_of_nat // nth_index // mem_enum. - move: Heq. by rewrite -Heq1 /tuple2N N_of_bitseq_bitseq_of_nat// seq_index_enum_card // enum_uniq. @@ -76,27 +77,29 @@ Qed. End encoder_and_decoder. -Local Open Scope R_scope. -Local Open Scope zarith_ext_scope. +(*Local Open Scope R_scope. +Local Open Scope zarith_ext_scope.*) + +Import Order.POrderTheory GRing.Theory Num.Theory Num.Def Order.TotalTheory. Section source_direct_bound. +Let R := Rdefinitions.R. -Let source_direct_bound' d D : { k | D <= (k * d.+1)%:R }. +Let source_direct_bound' d (D : R) : { k | D <= (k * d.+1)%:R }. Proof. -exists '| up D |. -rewrite -multE (natRM '| up D | d.+1). -apply (@leR_trans (IZR `| up D |)); first exact: Rle_up. -rewrite INR_IZR_INZ inj_Zabs_nat -{1}(mulR1 (IZR _)). -apply:leR_wpmul2l; first exact/IZR_le/normZ_ge0. -by rewrite (_ : 1 = 1%:R)//; exact/le_INR/leP. +exists `| Num.ceil D |%N. +rewrite natrM. +apply: (@le_trans _ _ `| Num.ceil D |%:R). + by rewrite (le_trans (le_ceil _))// natr_absz ler_int ler_norm. +by rewrite ler_peMr// ler1n. Qed. -Lemma source_direct_bound d D : { k | D <= (k.+1 * d.+1)%:R }. +Lemma source_direct_bound d (D : R) : { k | D <= (k.+1 * d.+1)%:R }. Proof. case: (source_direct_bound' d D) => k Hk. destruct k as [|k]; last by exists k. exists O; rewrite mul1n. -by apply (@leR_trans 0%R); last exact: leR0n. +by move: Hk; rewrite mul0n => /le_trans; apply. Qed. End source_direct_bound. @@ -106,33 +109,35 @@ Local Open Scope entropy_scope. Local Open Scope reals_ext_scope. Section source_coding_direct'. -Variables (A : finType) (P : {fdist A}) (num den : nat). -Let r := (num%:R / den.+1%:R)%R. +Let R := Rdefinitions.R. +Variables (A : finType) (P : R.-fdist A) (num den : nat). +Let r : R := num%:R / den.+1%:R. Hypothesis Hr : `H P < r. Variable epsilon : R. Hypothesis epsilon01 : 0 < epsilon < 1. -Definition lambda := min(r - `H P, epsilon). +Definition lambda := minr (r - `H P) epsilon. Lemma lambda_gt0 : 0 < lambda. -Proof. by apply Rmin_glb_lt;[move: Hr => ? ; lra|exact: epsilon01.1]. Qed. +Proof. +rewrite lt_min subr_gt0 Hr/=. +by case/andP : epsilon01. +Qed. Lemma lambda2_epsilon : lambda / 2 <= epsilon. Proof. -apply (@leR_trans lambda). - by rewrite leR_pdivr_mulr //; apply leR_pmulr; [lra | exact/ltRW/lambda_gt0]. -rewrite /lambda; case: (Rlt_le_dec (r - `H P) epsilon) => ?. -- by rewrite Rmin_left; lra. -- by rewrite Rmin_right //; lra. +apply (@le_trans _ _ lambda). + by rewrite ler_pdivrMr// ler_peMr ?ler1n// ltW// lambda_gt0. +by rewrite /lambda ge_min lexx orbT. Qed. Lemma lambda2_gt0 : 0 < lambda / 2. -Proof. by apply divR_gt0 => //; exact: lambda_gt0. Qed. +Proof. by apply divr_gt0 => //; exact: lambda_gt0. Qed. Lemma lambda2_lt1 : lambda / 2 < 1. -Proof. exact: (leR_ltR_trans lambda2_epsilon epsilon01.2). Qed. +Proof. apply: (le_lt_trans lambda2_epsilon); by case/andP: epsilon01. Qed. -Definition delta := max(aep_bound P (lambda / 2), 2 / lambda). +Definition delta := maxr (aep_bound P (lambda / 2)) (2 / lambda). Let k' := sval (source_direct_bound den delta). @@ -143,74 +148,78 @@ Definition n := (k'.+1 * num)%nat. Lemma Hlambdar : `H P + lambda <= r. Proof. rewrite /lambda. -case: (Rlt_le_dec (r - `H P) epsilon) => ?. -- rewrite Rmin_left; lra. -- rewrite Rmin_right //; lra. +have [?|?] := leP (r - `H P) epsilon. +- by rewrite addrCA subrr addr0. +- lra. Qed. -Local Open Scope fdist_scope. Local Open Scope typ_seq_scope. Theorem source_coding' : exists sc : scode_fl A k n, SrcRate sc = r /\ esrc(P , sc) <= epsilon. Proof. move: (proj2_sig (source_direct_bound den delta)) => Hdelta. -have Hk : aep_bound P (lambda / 2) <= INR k by exact/(leR_trans _ Hdelta)/leR_maxl. +have Hk : aep_bound P (lambda / 2) <= k%:R. + by apply/(le_trans _ Hdelta); rewrite le_max lexx. set S := `TS P k (lambda / 2). set def := TS_0 lambda2_gt0 lambda2_lt1 Hk. (*TODO: get rid of this expansion*) set F := f n S. set PHI := @phi _ n _ S def. exists (mkScode F PHI); split. - rewrite /SrcRate /r /n /k 2!natRM; field. - by split; exact/INR_eq0. + rewrite /SrcRate /r /n /k. + field. + by rewrite !nat1r/= !gt_eqF//=. set lhs := esrc(_, _). -suff -> : lhs = (1 - Pr (P `^ k) (`TS P k (lambda / 2)))%R. - rewrite leR_subl_addr addRC -leR_subl_addr. - apply (@leR_trans (1 - lambda / 2)%R). - by apply leR_add2l; rewrite leR_oppr oppRK; exact: lambda2_epsilon. +suff -> : lhs = 1 - Pr (P `^ k)%fdist (`TS P k (lambda / 2)). + rewrite lerBlDr addrC -lerBlDr. + apply (@le_trans _ _ (1 - lambda / 2)). + by rewrite lerD2l lerNr opprK; exact: lambda2_epsilon. exact: (Pr_TS_1 lambda2_gt0). rewrite /lhs {lhs} /SrcErrRate /Pr /=. set lhs := \sum_(_ | _ ) _. -suff -> : lhs = \sum_(x in 'rV[A]_k | x \notin S) P `^ k x. - have : forall a b : R, (a + b = 1 -> b = 1 - a)%R by move=> ? ? <-; field. +suff -> : lhs = \sum_(x in 'rV[A]_k | x \notin S) (P `^ k)%fdist x. + have : forall a b : R, a + b = 1 -> b = 1 - a by move=> ? ? <-; field. apply. - rewrite -[X in _ = X](Pr_cplt (P `^ k) (`TS P k (lambda / 2))). - congr (_ + _)%R. + rewrite -[X in _ = X](Pr_cplt (P `^ k)%fdist (`TS P k (lambda / 2))). + congr +%R. by apply: eq_bigl => ta /=; rewrite !inE. rewrite {}/lhs; apply eq_bigl => //= i. rewrite inE /=; apply/negPn/negPn. - suff H : def \in S by move/eqP/phi_f; tauto. exact: (TS_0_is_typ_seq lambda2_gt0 lambda2_lt1 Hk). - suff S_2n : (#| S | < expn 2 n)%nat by move/(f_phi def S_2n)/eqP. - suff card_S_bound : #| S |%:R < exp2 (k%:R * r). - apply/ltP/INR_lt; rewrite -natRexp2. - suff : n%:R = (k%:R * r)%R by move=> ->. - rewrite /n /k /r (natRM _ den.+1) /Rdiv -mulRA. - by rewrite (mulRCA den.+1%:R) mulRV ?INR_eq0' // mulR1 natRM. - suff card_S_bound : 1 + #| S |%:R <= exp2 (k%:R * r) by lra. - suff card_S_bound : 1 + #| S |%:R <= exp2 (k%:R * (`H P + lambda)). - apply: leR_trans; first exact: card_S_bound. - by apply Exp_le_increasing => //; apply leR_wpmul2l; [exact/leR0n | exact/Hlambdar]. - apply (@leR_trans (exp2 (k%:R * (lambda / 2) + k%:R * (`H P + lambda / 2)))); last first. - rewrite -mulRDr addRC -addRA. - rewrite (_ : forall a, a / 2 + a / 2 = a)%R; last by move=> ?; field. - by apply/RleP; rewrite Order.POrderTheory.lexx. - apply (@leR_trans (exp2 (1 + INR k * (`H P + lambda / 2)))); last first. - apply Exp_le_increasing => //; apply leR_add2r. - move/leR_max : Hdelta => [_ Hlambda]. - apply (@leR_pmul2r (2 / lambda)%R); first by apply/divR_gt0 => //; exact: lambda_gt0. - rewrite mul1R -mulRA -{2}(Rinv_div lambda 2). - by rewrite mulRV ?mulR1 //; exact/gtR_eqF/lambda2_gt0. - apply: leR_trans; first exact/leR_add2l/TS_sup. - apply (@leR_trans (exp2 (INR k* (`H P + lambda / 2)) + - exp2 (INR k * (`H P + lambda / 2)))%R). - + apply/leR_add2r. - rewrite -exp2_0; apply Exp_le_increasing => //. - apply mulR_ge0; first exact: leR0n. - apply addR_ge0; first exact: entropy_ge0. - by apply Rlt_le; exact: lambda2_gt0. - + rewrite addRR -{1}(logK Rlt_0_2) -ExpD {1}/log Log_n //. - by apply/RleP; rewrite Order.POrderTheory.lexx. + suff card_S_bound : #| S |%:R < 2 `^ (k%:R * r). + rewrite -(ltr_nat R) -natrXE natrX -powR_mulrn ?ler0n//. + suff : n%:R = k%:R * r by move=> ->. + rewrite /n /k /r. + by rewrite !natrM mulrCA -mulrA divff ?mulr1 ?pnatr_eq0// mulrC. + suff card_S_bound : 1 + #| S |%:R <= 2 `^ (k%:R * r) by lra. + suff card_S_bound : 1 + #| S |%:R <= 2 `^ (k%:R * (`H P + lambda)). + apply: le_trans; first exact: card_S_bound. + by rewrite gt1_ler_powRr ?ltr1n// ler_wpM2l// Hlambdar. + apply (@le_trans _ _ (2 `^ (k%:R * (lambda / 2) + k%:R * (`H P + lambda / 2)))); last first. + rewrite -mulrDr addrC -addrA. + rewrite (_ : forall a, a / 2 + a / 2 = a); last by move=> ?; field. + by rewrite lexx. + apply (@le_trans _ _ (2 `^ (1 + k%:R * (`H P + lambda / 2)))); last first. + rewrite gt1_ler_powRr ?ltr1n// lerD2r//. + move: Hdelta; rewrite ge_max => /andP[_ Hlambda]. + rewrite -(@ler_pM2r _ (2 / lambda)); last first. + by rewrite divr_gt0//; exact: lambda_gt0. + rewrite mul1r -mulrA. + rewrite -[in leRHS]invf_div// mulVf ?mulr1//. + by rewrite gt_eqF// -invf_div// invr_gt0// lambda2_gt0. + apply:(@le_trans _ _ (1 + powR 2 (k%:R * (`H P + (lambda / 2))))). + rewrite lerD2l//. + exact: TS_sup. + rewrite /S. + apply (@le_trans _ _ (2 `^ (k%:R * (`H P + lambda / 2)) + + 2 `^ (k%:R * (`H P + lambda / 2)))). + + rewrite lerD2r -[leLHS](powRr0 2). + rewrite ler_powR ?ler1n// mulr_ge0// addr_ge0//; first exact: entropy_ge0. + by rewrite divr_ge0// ltW// lambda_gt0. + + rewrite -mulr2n -mulr_natl powRD; last by rewrite pnatr_eq0 implybT. + by rewrite ler_pM2r ?powR_gt0// powRr1. Qed. End source_coding_direct'. @@ -219,11 +228,13 @@ Section source_coding_direct. Variables (A : finType) (P : {fdist A}). Theorem source_coding_direct epsilon : 0 < epsilon < 1 -> - forall r : Qplus, `H P < r -> - exists k n (sc : scode_fl A k n), SrcRate sc = r /\ esrc(P , sc) <= epsilon. + forall nu de : nat, `H P < nu%:R / de.+1%:R -> + exists k n (sc : scode_fl A k n), SrcRate sc = nu%:R/de.+1%:R /\ + esrc(P , sc) <= epsilon. Proof. -move=> Heps re HP_r; destruct re as [num den]. -by exists (k P num den epsilon), (n P num den epsilon); exact: source_coding'. +move=> Heps nu de HP_r. +exists (k P nu de epsilon), (n P nu de epsilon). +exact: source_coding'. Qed. End source_coding_direct. diff --git a/information_theory/source_coding_vl_converse.v b/information_theory/source_coding_vl_converse.v index 098d91bc..3f4f49f5 100644 --- a/information_theory/source_coding_vl_converse.v +++ b/information_theory/source_coding_vl_converse.v @@ -1,9 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext realType_ext logb ssr_ext ssralg_ext bigop_ext. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint matrix. +From mathcomp Require Import archimedean lra ring. +From mathcomp Require Import Rstruct reals sequences exp. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln. Require Import fdist proba entropy divergence log_sum source_code. (******************************************************************************) @@ -27,46 +27,45 @@ Local Open Scope fdist_scope. Local Open Scope proba_scope. Local Open Scope entropy_scope. Local Open Scope divergence_scope. -Local Open Scope R_scope. +Local Open Scope ring_scope. -Import Order.POrderTheory Num.Theory. +Import Order.POrderTheory GRing.Theory Num.Theory Num.Def Order.TotalTheory. +(* TODO: move to log_sum? *) Section log_sum_ord. +Let R := Rdefinitions.R. Variable n : nat. -Variable f g : nat ->R^+. +Variable f g : nat -> R. +Hypothesis (f0 : forall n, 0 <= f n) (g0 : forall n, 0 <= g n). Hypothesis f_dom_by_g : f `<< g. Lemma log_sum_inequality_ord_add1 : (\sum_(i < n) f i.+1) * - (log ((\sum_(i < n) f i.+1) / (\sum_(i < n) g i.+1))) <= - \sum_(i < n) f i.+1 * (log (f i.+1 / g i.+1)). -Proof. -have Rle0f_1 : forall x : 'I_n, 0 <= f x.+1 by move=> ?; apply nneg_f_ge0. -have Rle0g_1 : forall x : 'I_n, 0 <= g x.+1 by move=> ?; apply nneg_f_ge0. -have newRle0f_1 : [forall x : 'I_n, (0 <= [ffun x : 'I_n => f x.+1] x)%mcR]. - apply/forallPP; first by move=> x; apply/RleP. - by move=> ?/=; rewrite ffunE. -have newRle0g_1: [forall x : 'I_n, (0 <= [ffun x : 'I_n => g x.+1] x)%mcR]. - apply/forallPP; first by move=> x; apply/RleP. - by move=> ?/=; rewrite ffunE. -have f_dom_by_g1 : mkNNFinfun newRle0f_1 `<< mkNNFinfun newRle0g_1. + log ((\sum_(i < n) f i.+1) / (\sum_(i < n) g i.+1)) <= + \sum_(i < n) f i.+1 * log (f i.+1 / g i.+1). +Proof. +have Rle0f_1 (x : 'I_n) : 0 <= f x.+1 by exact: f0. +have Rle0g_1 (x : 'I_n) : 0 <= g x.+1 by exact: g0. +have newRle0f_1 : [forall x : 'I_n, 0 <= [ffun x : 'I_n => f x.+1] x]. + by apply/forallP => //= ?/=; rewrite ffunE. +have newRle0g_1 : [forall x : 'I_n, 0 <= [ffun x : 'I_n => g x.+1] x]. + by apply/forallP => //= ?/=; rewrite ffunE. +have f_dom_by_g1 : [ffun x0 : 'I_n => f x0.+1] `<< [ffun x0 : 'I_n => g x0.+1]. apply/dominatesP => a; move/dominatesP : f_dom_by_g. by rewrite /= !ffunE; exact. -have H : forall h, - \sum_(a | a \in [set: 'I_n]) h a.+1 = \sum_(a | a \in 'I_n) h a.+1. - by move=> ?; under eq_bigl do rewrite in_setT. +have H h : + \sum_(a | a \in [set: 'I_n]) h a.+1 = \sum_(a | a \in 'I_n) h a.+1 :> R. + by under eq_bigl do rewrite in_setT. rewrite -!H -(H (fun i => f i * log (f i / g i))). -have H1 : (forall x : 'I_n, 0 <= mkNNFinfun newRle0f_1 x). - by move=> x//=; rewrite ffunE. -have H2 : (forall x : 'I_n, 0 <= mkNNFinfun newRle0g_1 x). - by move=> x//=; rewrite ffunE. -have := (log_sum [set: 'I_n] (mkNNFinfun newRle0f_1) (mkNNFinfun newRle0g_1) H1 H2 f_dom_by_g1). -rewrite /=. +move/forallP in newRle0f_1. +move/forallP in newRle0g_1. +have := @log_sum R _ [set: 'I_n] [ffun x0 : 'I_n => f x0.+1] + [ffun x0 : 'I_n => g x0.+1] newRle0f_1 newRle0g_1 f_dom_by_g1. under eq_bigr do rewrite ffunE. under [in X in _ * log (_ / X) <= _ -> _]eq_bigr do rewrite ffunE. under [in X in _ <= X -> _]eq_bigr do rewrite ffunE. -move/leR_trans; apply. -rewrite leR_eqVlt; left. +move/le_trans; apply. +apply/eqW. by under eq_bigr do rewrite ffunE. Qed. @@ -81,29 +80,26 @@ rewrite [X in _ <= X] (log ((\sum_(i < n)f i.+1) / (\sum_(i < n) g i.+1)))). exact: log_sum_inequality_ord_add1. have : 0 <= \sum_(i in 'I_n) f i.+1. - by apply/RleP/sumr_ge0 => ? _; exact/RleP/nneg_f_ge0. - case=>[Hf | <-]; last by rewrite !mul0R. - have : 0 <= \sum_(i in 'I_n) g i.+1. - by apply/RleP/sumr_ge0 => ? _; exact/RleP/nneg_f_ge0. - case => [Hg |]. - by rewrite /log LogM // ?LogV //; last exact: invR_gt0. - have Rle0g_add1 : forall x : 'I_n, 0 <= g x.+1 by move=> ?; apply nneg_f_ge0. - move=> H. + by apply/sumr_ge0 => ? _. + rewrite le_eqVlt => /predU1P[<-|Hf]. + by rewrite !mul0r. + have : 0 <= \sum_(i in 'I_n) g i.+1 by exact/sumr_ge0. + rewrite le_eqVlt => /predU1P[H|Hg]; last first. + by rewrite logM// ?invr_gt0//; congr *%R; rewrite logV. have eq_g_0 : forall i : 'I_n, 0 = g i.+1. - move/esym/psumr_eq0P : H => H i; rewrite H//. - by move=> /= j _; exact/RleP. + by move/esym/psumr_eq0P : H => H i; rewrite H//. have : 0 = \sum_(i < n) f i.+1. - apply/esym/eqP; rewrite psumr_eq0 /=; last first. - move=> i _. exact/RleP/nneg_f_ge0. + apply/esym/eqP; rewrite psumr_eq0 //. apply/allP => i _; apply/eqP. by move/dominatesP : f_dom_by_g; apply; rewrite -eq_g_0. - by move => tmp; move: Hf; rewrite -tmp; move/Rlt_not_eq. + by move => tmp; move: Hf; rewrite -tmp ltxx. apply: eq_bigr => i _. -case: (nneg_f_ge0 f i.+1) => [fpos|<-]; last by rewrite !mul0R. -case: (nneg_f_ge0 g i.+1); last first. +have := (f0 i.+1); rewrite le_eqVlt => /predU1P[<-|fpos]; first by rewrite !mul0r. +have := (g0 i.+1); rewrite le_eqVlt => /predU1P[|]. + clear g0. move/esym => g0; move/dominatesP : f_dom_by_g => /(_ _ g0) ->. - by rewrite !mul0R. -by move=>gpos; rewrite /log LogM // ?LogV //; exact: invR_gt0. + by rewrite !mul0r. +by move=>gpos; rewrite logM ?invr_gt0// logV. Qed. End log_sum_ord. @@ -113,7 +109,7 @@ Variables (T : finType) (f : T -> nat). Definition inordf t := inord (f t) : 'I_(\max_t f t).+1. -Lemma inordfE : (fun t : T => nat_of_ord (inordf t)) =1 f . +Lemma inordfE : (fun t : T => nat_of_ord (inordf t)) =1 f. Proof. move=>t. apply: inordK; by apply: leq_bigmax. @@ -122,6 +118,7 @@ Qed. End Ordinal. Section Bigop_Lemma. +Let R := Rdefinitions.R. Variable A : finType. Variable n : nat. Variable f : A -> seq bool. @@ -132,9 +129,9 @@ Let big_seq_tuple' (F : seq bool -> R) : (0 < #|A|)%nat -> \sum_(i : n.-tuple bool | tval i \in codom f) F i. Proof. move Hpick : [pick x | x \in [set: A] ] => p Anon0. -move: Hpick; case: (pickP _)=>[defaultA _ _ | abs]; last first. - suff : False by []. - move:Anon0. +move: Hpick; case: (pickP _) => [defaultA _ _ | abs]; last first. + exfalso. + move: Anon0. rewrite -cardsT card_gt0; case/set0Pn => ?. by rewrite abs. pose dummy := [tuple of nseq n false]. @@ -145,8 +142,7 @@ move: Hpick; case: (pickP _)=>[defaultA _ _ | abs]; last first. by move => a0 /eqP /f_inj ->. - rewrite (reindex_onto h h'); last first. + move => a sizefa. rewrite /h' /h insubdK //. - + apply: esym. - apply: eq_big => i; last by move/codomP => [a fa]; rewrite /h fa H. + + apply/esym/eq_big => i; last by move/codomP => [a fa]; rewrite /h fa H. apply/idP/andP. * move/codomP => [a fa]. rewrite /h fa H. split; first by rewrite -fa size_tuple eqxx. @@ -157,7 +153,7 @@ Qed. Lemma big_seq_tuple (F : seq bool -> R) : (0 < #|A|)%nat -> (forall i, F i = if i \in codom f then F i else 0)-> - \sum_(i in {: n.-tuple bool}) F i = \sum_(a| size (f a) == n) F (f a). + \sum_(i in {: n.-tuple bool}) F i = \sum_(a | size (f a) == n) F (f a). Proof. move=> Anon0 Fi0. rewrite big_seq_tuple' //. @@ -166,27 +162,6 @@ rewrite (eq_bigr (fun a => if (tval a \in codom f) then F a else 0)) => [|i _]. by rewrite {1}Fi0. Qed. -Lemma big_pow1 x : x <> 1 -> - \sum_(i < n) x ^ i.+1 = x * (1 - (x ^ n)) / (1 - x). -Proof. -move => neq_x_1. -apply: (Rplus_eq_reg_l 1). -rewrite [X in _ = X + _](_ : _ = (1 - x) / (1 - x)); last first. - rewrite divRR //; apply/eqP; rewrite subR_eq0; exact/nesym. -rewrite mulRDr mulR1 -mulRDl addRA [in RHS]addRC -addRA. -rewrite Rplus_opp_l addR0 (addRC _ 1) mulRN. -rewrite -(big_mkord xpredT (fun i => x ^ i.+1)) (_ : n = n.+1.-1) //. -rewrite -(big_add1 _ _ _ _ xpredT)-{1}(pow_O x) -big_ltn //. -by rewrite big_mkord -sum_f_R0_sumR tech3. -Qed. - -Lemma log_pow r : 0 < r -> log (r ^ n) = n%:R * log r. -Proof. -elim:n=> [|n' IH lt_0_r]; first by rewrite /log Log_1 mul0R. -rewrite /log LogM //;last exact: pow_lt. -rewrite /log in IH; by rewrite IH // -addn1 addRC plus_INR mulRDl mul1R. -Qed. - End Bigop_Lemma. Local Open Scope vec_ext_scope. @@ -194,28 +169,29 @@ Local Open Scope vec_ext_scope. Section Entropy_lemma. Variables (A : finType) (P : {fdist A}) (n : nat). -Lemma entropy_TupleFDist : `H (P `^ n) = n%:R * `H P. +(* TODO: move to entropy.v *) +Lemma entropy_TupleFDist : `H (P `^ n)%fdist = n%:R * `H P. Proof. elim:n=>[|n0 IH]. - rewrite mul0R /entropy /= big1 ?oppR0 // => i _. - by rewrite fdist_rV0 /log Log_1 mulR0. -rewrite S_INR mulRDl mul1R -IH /entropy -(big_rV_cons_behead _ xpredT xpredT). -rewrite /= -oppRD; congr (- _). + rewrite mul0r /entropy /= big1 ?oppr0 // => i _. + by rewrite fdist_rV0 log1 mulr0. +rewrite -natr1 mulrDl mul1r -IH /entropy -(big_rV_cons_behead _ xpredT xpredT)/=. +rewrite /= -opprD; congr (- _). rewrite [LHS](_ :_ = \sum_(i | i \in A) P i * log (P i) * (\sum_(j in 'rV[A]_n0) (\prod_(i0 < n0) P j ``_ i0)) + \sum_(i | i \in A) P i * \sum_(j in 'rV[A]_n0) (\prod_(i0 < n0) P j ``_ i0) * log (\prod_(i0 < n0) P j ``_ i0)); last first. rewrite -big_split /=; apply: eq_bigr => i _. - rewrite -mulRA -mulRDr (mulRC (log (P i))) (big_distrl (log (P i)) _ _) /=. + rewrite -mulrA -mulrDr (mulrC (log (P i))) (big_distrl (log (P i)) _ _) /=. rewrite -big_split /= big_distrr /=. apply: eq_bigr => i0 _. rewrite fdist_rVE. rewrite big_ord_recl (_ : _ ``_ ord0 = i); last first. by rewrite mxE; case: splitP => // j Hj; rewrite mxE. - rewrite -mulRA. - case/RleP : (FDist.ge0 P i) => [pi_pos| <-]; last by rewrite !mul0R. + rewrite -mulrA. + case/RleP : (FDist.ge0 P i) => [/RltP pi_pos| <-]; last by rewrite !mul0r. congr (P i * _). - rewrite -mulRDr. + rewrite -mulrDr. rewrite (@eq_bigr _ _ _ _ _ _ (fun x => P ((row_mx (\row_(_ < 1) i) i0) ``_ (lift ord0 x))) (fun x => P i0 ``_ x)) => [|i1 _]; last first. @@ -223,46 +199,46 @@ rewrite [LHS](_ :_ = \sum_(i | i \in A) P i * log (P i) * rewrite mxE. case: splitP => j; first by rewrite (ord1 j). by rewrite lift0 add1n; case=> /eqP /val_eqP ->. - case: (Req_dec 0 (\prod_(i' < n0) P i0 ``_ i')) => [<-|rmul_non0]. - by rewrite !mul0R. + have [<-|rmul_non0] := eqVneq 0 (\prod_(i' < n0) P i0 ``_ i'). + by rewrite !mul0r. have rmul_pos : 0 < \prod_(i1 ?. - exact/RleP/FDist.ge0. - by rewrite /log LogM // !mulRDr mulRA mulRA. + by rewrite lt0r eq_sym rmul_non0; apply/prodr_ge0 => ?. + by rewrite logM//. rewrite (_ : \sum_(j in 'rV_n0) _ = 1); last first. - by rewrite (_ : 1 = 1%mcR)// -(FDist.f1 (P `^ n0)); apply eq_bigr => i _; rewrite fdist_rVE. -rewrite -big_distrl /= mulR1 [in RHS]addRC; congr (_ + _). -rewrite -big_distrl /= FDist.f1 mul1R; apply eq_bigr => i _. + rewrite -[RHS](FDist.f1 (P `^ n0)%fdist). + by apply eq_bigr => i _; rewrite fdist_rVE. +rewrite -big_distrl /= mulr1 [in RHS]addrC; congr +%R. +rewrite -big_distrl /= FDist.f1 mul1r; apply eq_bigr => i _. by rewrite fdist_rVE. Qed. End Entropy_lemma. Section le_entroPN_logeEX. +Let R := Rdefinitions.R. Variable (A : finType) (P : {fdist A}) (f : A -> seq bool). -Let X : {RV P -> R} := INR \o size \o f. +Let X : {RV P -> R} := (fun x => x%:R) \o size \o f. Definition Nmax := \max_(a in A) size (f a). Hypothesis f_uniq : uniquely_decodable f. Let Xnon0 x : 0 <> X x. Proof. -rewrite /X /=; case: (Req_dec 0 (size (f x))%:R)=>// H. -move: H; rewrite (_ : 0 = 0%:R)//; move/INR_eq. +rewrite /X /=; have [/eqP|/eqP//] := eqVneq (0:R) (size (f x))%:R. +rewrite (_ : 0 = 0%:R)// eqr_nat => /eqP. move/esym/size0nil => fx_nil. move: (@f_uniq [::] ([:: x])). by rewrite /extension /= fx_nil cat0s => /(_ erefl). Qed. +(* TODO: rename *) Lemma Xpos a : 0 < X a. Proof. -move/nesym/INR_not_0 : (@Xnon0 a) => H. -by rewrite ltR0n ltn_neqAle /= leq0n andbT; apply/eqP/nesym. +by rewrite lt_neqAle eq_sym ler0n andbT; apply/eqP/nesym/Xnon0. Qed. Let PN_ge0 : (forall i : 'I_Nmax.+1, 0 <= [ffun x : 'I__ => `Pr[ X = x%:R]] i)%mcR. -Proof. by move => a; rewrite ffunE; apply/RleP. Qed. +Proof. by move => a; rewrite ffunE. Qed. Lemma PN_sum1 : (\sum_(i < Nmax.+1) [ffun x : 'I__ => `Pr[ X = x%:R] ] i = 1)%mcR. @@ -274,9 +250,10 @@ rewrite /pr_eq; unlock. apply: eq_bigl => i0. rewrite /= inE. apply/eqP/eqP=> [|<-]; last first. - by rewrite inordfE /X /= FDist.f1 INRE. -rewrite FDist.f1 /X /= -INRE => /INR_eq H. -by apply/val_inj => /=; rewrite -H inordfE. + by rewrite inordfE /X /= FDist.f1. +rewrite FDist.f1 /X /= => /eqP; rewrite eqr_nat => /eqP H. +apply/val_inj => /=. +by rewrite inordfE. Qed. Definition PN := FDist.make PN_ge0 PN_sum1. @@ -286,179 +263,212 @@ Proof. rewrite /Ex (partition_big (inordf (size \o f)) (fun i => i \in 'I_Nmax.+1)) //=. apply : eq_bigr=> i _. rewrite /pr_eq; unlock. -rewrite /Pr ffunE mulRC big_distrl /=. -under eq_bigr do rewrite mulRC. +rewrite /Pr ffunE mulrC big_distrl /=. +under eq_bigr do rewrite mulrC. apply: congr_big=>[//| x| x]; last by move/eqP<-; rewrite inordfE. rewrite inE; apply/eqP/eqP=> [<-|]. - by rewrite inordfE /X/= INRE. -rewrite /X /= -INRE => /INR_eq H. + by rewrite inordfE /X/=. +rewrite /X /= => /eqP; rewrite eqr_nat => /eqP H. by apply: ord_inj; rewrite -H inordfE. Qed. Lemma le_1_EX : 1 <= `E X. Proof. -rewrite (_ : 1 = 1%mcR)// -(FDist.f1 P); apply: leR_sumR => i _. -rewrite -{1}(mul1R (P i)). -apply leR_wpmul2r; first exact/RleP/FDist.ge0. -by move: (Xpos i); rewrite (_ : 1 = 1%:R) //= (_ : 0 = 0%:R) // ltR_nat leR_nat. +rewrite -(FDist.f1 P); apply: ler_sum => i _. +rewrite -{1}(mul1r (P i)). +apply ler_wpM2r; first exact/FDist.ge0. +by move: (Xpos i); rewrite (_ : 1 = 1%:R) //= (_ : 0 = 0%:R) // ltr_nat ler_nat. Qed. -Lemma EX_gt0 : 0 < `E X. Proof. exact: ltR_leR_trans le_1_EX. Qed. +Lemma EX_gt0 : 0 < `E X. Proof. exact: lt_le_trans le_1_EX. Qed. Lemma entroPN_0 : `E X = 1 -> `H PN = 0. Proof. move => EX_1. have eq_0_P : forall a, X a <> 1 -> 0 = P a. move: EX_1. - rewrite (_ : 1 = 1%mcR)// -{1}(FDist.f1 P) => EX1 a Xnon1. + rewrite -{1}(FDist.f1 P) => EX1 a Xnon1. have /leR_sumR_eq H : forall i : A, i \in A -> P i <= (size (f i))%:R * P i. - move=> i _; rewrite -{1}(mul1R ( P i)). - apply/leR_wpmul2r; first exact/RleP/FDist.ge0. - by move: (Xpos i); rewrite (_ : 1 = 1%:R) //= (_ : 0 = 0%:R) // ltR_nat leR_nat. - case: (Req_dec (P a) 0) => //. + move=> i _; rewrite -{1}(mul1r ( P i)). + apply/ler_wpM2r; first exact/FDist.ge0. + by move: (Xpos i); rewrite (_ : 1 = 1%:R) //= (_ : 0 = 0%:R) // ltr_nat ler_nat. + have [//|] := eqVneq (P a) 0. have : (size (f a))%:R * P a = P a by rewrite (H EX1 a). - rewrite -{2}(mul1R (P a)). - by move/Rmult_eq_reg_r => tmp /tmp. -rewrite /entropy Ropp_eq_0_compat //. -rewrite (eq_bigr (fun=> 0)) ?big_const ?iter_addR ?mulR0 //= => i _. + rewrite -{2}(mul1r (P a)) => + Pa0. + move=> /(congr1 (fun x => x * (P a)^-1)). + by rewrite -!mulrA divff// !mulr1. +rewrite /entropy. +apply/eqP; rewrite oppr_eq0; apply/eqP. +rewrite big1//= => i _. rewrite /pr_eq; unlock. rewrite /Pr ffunE. -rewrite -INRE. -case: (Req_dec i%:R 1)=>[->| neq0]. - rewrite [X in _ * log X = _](_ : _ = 1); first by rewrite /log Log_1 mulR0. - rewrite (_ : 1 = 1%mcR)//. +have [->|neq0] := eqVneq i%:R (1:R). + rewrite [X in _ * log X = _](_ : _ = 1); first by rewrite log1 mulr0. rewrite -{2}(FDist.f1 P). - rewrite [in RHS](bigID (fun a => a \in [set x | (size (f x))%:R == 1])) /=. - rewrite [X in _ = _ + X](_ : _ = 0); first by rewrite addR0. - rewrite (eq_bigr (fun=> 0)) ?big_const ?iter_addR ?mulR0 // => j. - by rewrite inE; move/eqP/eq_0_P. -rewrite [X in X * _ = _](_ : _ = 0); first by rewrite mul0R. + rewrite [in RHS](bigID (fun a => a \in [set x | (size (f x))%:R == (1:R)])) /=. + rewrite [X in _ = _ + X](_ : _ = 0). + by rewrite addr0. + rewrite big1// => j. + by rewrite inE => /eqP/eq_0_P. +rewrite [X in X * _ = _](_ : _ = 0); first by rewrite mul0r. rewrite big1 // => j. rewrite inE; move/eqP => eq_Xj_i. -by move: neq0; rewrite -eq_Xj_i => /eq_0_P. +by move: neq0; rewrite -eq_Xj_i => /eqP/eq_0_P. Qed. Lemma le_entroPN_logeEX' : `H PN <= `E X * log (`E X) - (`E X - 1) * log((`E X ) - 1). Proof. -move/Rle_lt_or_eq_dec:le_1_EX=>[lt_EX_1| eq_E_0]; last first. - rewrite -eq_E_0 /Rminus Rplus_opp_r mul0R Ropp_0 addR0 mul1R /log Log_1. +move: le_1_EX; rewrite le_eqVlt => /predU1P[eq_E_0|lt_EX_1]. + rewrite -eq_E_0 log1 mulr0 subrr mul0r subrr. by move/esym/entroPN_0 : eq_E_0 ->. -have lt_0_EX_1 : 0 < `E X - 1 by rewrite subR_gt0. +have lt_0_EX_1 : 0 < `E X - 1 by rewrite subr_gt0. pose alp := (`E X - 1) / `E X . have gt_alp_1 : alp < 1. - rewrite -(ltR_pmul2r EX_gt0) // mul1R. - rewrite /alp -mulRA mulVR ?mulR1; last exact/gtR_eqF/EX_gt0. - by rewrite -ltR_subr_addl subRR -ltR_oppl oppR0. -have lt_0_alp : 0 < alp by rewrite /alp; exact/divR_gt0/EX_gt0. + rewrite -(ltr_pM2r EX_gt0) // mul1r. + rewrite /alp -mulrA mulVf ?mulr1; last first. + by rewrite gt_eqF// (le_lt_trans _ lt_EX_1). + by rewrite -ltrBrDl subrr -ltrNl oppr0. +have lt_0_alp : 0 < alp. + by rewrite /alp divr_gt0// EX_gt0. have EX_pos' : 0 < 1 - (`E X - 1) / `E X . - rewrite divRDl divRR; last exact/gtR_eqF/EX_gt0. - rewrite divN1R addR_opp subRB subRR add0R; exact/invR_gt0/EX_gt0. -have max_pos: (0 < \max_(a in A) size (f a))%coq_nat. - apply/ltP. + rewrite mulrBl divff//; last first. + by rewrite gt_eqF// (le_lt_trans _ lt_EX_1). + by rewrite mul1r opprB addrC subrK invr_gt0// EX_gt0. +have max_pos: (0 < \max_(a in A) size (f a))%N. move/card_gt0P : (fdist_card_neq0 P) => [a _]. - apply: (bigmax_sup a)=> //. - by move: (Xpos a); rewrite /X /= (_ : 0 = INR 0) // => /INR_lt/ltP. + apply: (bigop.bigmax_sup a) (* TODO: name conflict *)=> //. + by move: (Xpos a); rewrite /X /= ltr0n. rewrite [X in _ <= X](_ :_ = log ( alp / (1 - alp)) - (log alp) * `E X); last first. - rewrite /alp /Rdiv /log !LogM //; last 2 first. - exact/invR_gt0/EX_gt0. - exact/invR_gt0. - rewrite ![in RHS](LogV _ EX_gt0) // mulRDl [in RHS]/Rminus. - rewrite [in RHS]addRC (addRC _ (- log (`E X ) * `E X )) oppRD. - rewrite [in RHS]mulNR oppRK -addRA. - rewrite [in LHS]mulRC -addR_opp; congr (_ + _). - rewrite [in LHS]mulRDl mulRC oppRD mulN1R oppRK; congr (_ + _). - rewrite -[in RHS]addRA -[LHS]addR0; congr (_ + _). - rewrite mulRDl mulRV; last exact/gtR_eqF/EX_gt0. - by rewrite mulN1R !addR_opp subRB subRR add0R invRK ?Rplus_opp_l. -apply: (@leR_trans (log (alp * (1 - (alp ^ (\max_(a | a \in A) size (f a)))) + rewrite /alp !logM //; last 2 first. + by rewrite invr_gt0; exact/EX_gt0. + by rewrite invr_gt0. + rewrite ![in RHS](logV EX_gt0) //. + rewrite [in X in _ = _ - X]mulrDl. + rewrite [in RHS]addrC (addrC _ (- log (`E X ) * `E X )) opprD. + rewrite [in RHS]mulNr opprK -addrA. + rewrite [in LHS]mulrC; congr (_ + _). + rewrite [in LHS]mulrDl mulrC opprD mulN1r opprK; congr (_ + _). + rewrite -[in RHS]addrA -[LHS]addr0; congr (_ + _). + rewrite mulrDl mulfV; last first. + by rewrite gt_eqF// EX_gt0. + by rewrite mulN1r opprB addrCA subrr addr0 invrK addrC subrr. +apply: (@le_trans _ _ (log (alp * (1 - (alp ^ (\max_(a | a \in A) size (f a)))) / (1 - alp)) - log alp * `E X ) _); last first. - rewrite leR_add2r. - apply: Log_increasing_le => //. - apply/mulR_gt0; last by apply/invR_gt0; rewrite subR_gt0. - apply/mulR_gt0 => //; rewrite subR_gt0. - have : 0 <= alp < 1 by split => //; exact/ltRW. - by case/(pow_lt_1_compat _ _)/(_ max_pos). - rewrite /Rdiv -mulRA; apply/(leR_wpmul2l (ltRW lt_0_alp)). - rewrite -{2}(mul1R (/ (1 - alp))). - apply/leR_wpmul2r; first by apply/invR_ge0; rewrite subR_gt0. - rewrite -addR_opp addRC -leR_subr_addr subRR leR_oppl oppR0. - exact/expR_ge0/ltRW. -rewrite EX_ord -big_pow1; last exact/eqP/ltR_eqF. -rewrite mulRC (big_morph _ (morph_mulRDl _) (mul0R _)). -rewrite -(@leR_add2r (\sum_(i < Nmax.+1) i%:R * `Pr[ X = i%:R ] * log alp)). -rewrite -addRA (_ : - _ + _ = 0) ?addR0; last first. - rewrite addRC addR_opp subR_eq0; apply eq_bigr => i _; rewrite ffunE. - by rewrite -INRE. + rewrite lerD2r. + rewrite ler_log ?posrE//; last 2 first. + apply/mulr_gt0; last by rewrite invr_gt0. + rewrite mulr_gt0// subr_gt0. + have : 0 <= alp < 1 by apply/andP; split => //; exact/ltW. + move/andP => [alp0 alp1]. + by rewrite -exprnP expr_lt1. + by rewrite divr_gt0//. + rewrite -mulrA (ler_wpM2l (ltW lt_0_alp))//. + rewrite -{2}(mul1r ((1 - alp)^-1)). + rewrite ler_wpM2r ?invr_ge0 ?subr_ge0//. + exact: ltW. + rewrite -lerBrDl subrr lerNl oppr0. + by rewrite -exprnP exprn_ge0// ltW. +rewrite EX_ord -sum_exprz; last by rewrite lt_eqF. +rewrite mulrC. +rewrite big_distrl//=. +rewrite -(@lerD2r _ (\sum_(i < Nmax.+1) i%:R * `Pr[ X = i%:R ] * log alp)). +rewrite -addrA addrC (_ : - _ + _ = 0) ?addr0; last first. + apply/eqP; rewrite addrC subr_eq0; apply/eqP. + by apply eq_bigr => i _; rewrite ffunE. rewrite (@eq_bigr _ _ _ 'I_Nmax.+1 _ _ _ (fun i => `Pr[ X = i%:R ] * log (alp ^ i)))=>[|i _]; last first. - by rewrite log_pow // [in RHS]mulRC -mulRA (mulRC _ (log alp)) mulRA. -rewrite /entropy addRC; move: oppRB; rewrite/Rminus; move<-. -rewrite -(oppRK (log _)) leR_oppl oppRK big_morph_oppR -big_split /=. + by rewrite log_exprz // [in RHS]mulrC -mulrA (mulrC _ (log alp)) mulrA. +rewrite /entropy/=. +rewrite -[leLHS]opprB. +rewrite -(opprK (log _)) lerNl opprK big_morph_oppr -big_split /=. rewrite [X in _ <= X](_ : _ = \sum_(i < Nmax.+1) `Pr[ X = i%:R] * (log (`Pr[ X = i%:R ]) - log (alp ^ i))); last first. - by apply: eq_bigr => i _; rewrite ffunE addR_opp -INRE -mulRBr. -rewrite -sub0R -(mul1R (0 - _)). + by apply: eq_bigr => i _; rewrite ffunE -mulrBr. +rewrite -sub0r -(mul1r (0 - _)). have pmf1' : \sum_(i < Nmax) `Pr[X = i.+1%:R] = 1. - rewrite (_ : 1 = 1%mcR)// -PN_sum1 /=. + rewrite -[RHS]PN_sum1 /=. under [in RHS]eq_bigr do rewrite ffunE. - rewrite big_ord_recl. - rewrite -RplusE. - rewrite -subR_eq. + rewrite [RHS]big_ord_recl. + apply/eqP; rewrite -subr_eq; apply/eqP. rewrite [LHS](_ : _ = 0); last first. - apply/eqP; rewrite GRing.subr_eq0; apply/eqP/eq_bigr => i _ /=. - by rewrite INRE. + by apply/eqP; rewrite GRing.subr_eq0; apply/eqP/eq_bigr => i _ /=. apply/esym. rewrite /pr_eq; unlock. rewrite /Pr big1 // => i. rewrite inE; move/eqP => Xi_0. - by move/gtR_eqF: (Xpos i); rewrite Xi_0 => /eqP. -rewrite -{1}(Log_1 2) -pmf1'. + have := Xpos i. + by rewrite Xi_0 ltxx. +rewrite -{1}(log1). +rewrite -{1 2}[in leLHS]pmf1'. have Pr_ge0' (i : nat) : 0 <= `Pr[ X = i%:R] by []. -have alpi_ge0 (i : nat) : 0 <= alp ^ i by exact/pow_le/ltRW. -pose h := mkNNFun Pr_ge0'. -pose g := mkNNFun alpi_ge0. -have dom_by_hg : h `<< g. +have alpi_ge0 (i : nat) : 0 <= alp ^ i. + by rewrite -exprnP exprn_ge0// ltW. +pose h := [ffun i : 'I_Nmax.+1 => `Pr[ X = i%:R ]]. +pose g :=[ffun i : 'I_Nmax.+1 => alp ^ i]. +have dom_by_hg : (fun i : nat => `Pr[ X = i%:R ]) `<< (fun i : nat => alp ^ i). apply/dominatesP => i. rewrite /g /= => alp0. move: lt_0_alp. - have -> : alp = 0 by move: (pow_nonzero alp i); tauto. - by move/ltRR. -rewrite big_ord_recl [X in _ <= X + _](_ : _ = 0) ?add0R; last first. + have -> : alp = 0. + move: alp0. + rewrite -exprnP => /eqP. + by rewrite expf_eq0 => /andP[_ /eqP]. + by rewrite ltxx. +rewrite big_ord_recl [X in _ <= X + _](_ : _ = 0) ?add0r; last first. rewrite /pr_eq; unlock. rewrite /Pr. - have -> : [set x | X x == INR 0] = set0; last by rewrite big_set0 mul0R. + have -> : [set x | X x == 0] = set0; last by rewrite big_set0 mul0r. apply/setP => i; rewrite inE /= in_set0. - by apply/negbTE; rewrite gtR_eqF //; exact: Xpos. -exact: (log_sum_inequality_ord_add1' Nmax dom_by_hg). + by apply/negbTE; rewrite gt_eqF //; exact: Xpos. +have := log_sum_inequality_ord_add1' Nmax Pr_ge0' alpi_ge0. +by apply. Qed. -Lemma le_entroPN_logeEX : `H PN <= log (`E X) + log (exp 1). +Lemma le_entroPN_logeEX : `H PN <= log (`E X) + log (expR 1). Proof. -move/Rle_lt_or_eq_dec : le_1_EX => [?|eq_EX_1]; last first. - rewrite -eq_EX_1 /log Log_1 add0R. +move: le_1_EX; rewrite le_eqVlt => /predU1P[eq_EX_1|?]. + rewrite -eq_EX_1 log1 add0r. by move/esym/entroPN_0 : eq_EX_1 ->; apply: log_exp1_Rle_0. -have EX_1 : 0 < `E X - 1 by rewrite subR_gt0. -have /eqP neq_EX1_0 : (`E X + -1) != 0 by exact/gtR_eqF. -apply: (@leR_trans (`E X * log (`E X ) - (`E X - 1) * log((`E X ) -1))). +have EX_1 : 0 < `E X - 1 by rewrite subr_gt0. +have /eqP neq_EX1_0 : (`E X + -1) != 0 by rewrite gt_eqF. +apply: (@le_trans _ _ (`E X * log (`E X ) - (`E X - 1) * log ((`E X) - 1))). exact: le_entroPN_logeEX'. -rewrite -{1}(Rplus_minus 1 (`E X)) mulRDl mul1R /Rminus -addRA leR_add2l. -rewrite -mulRN -mulRDr -(mul1R (log (exp 1))) -{3}(subRKC (`E X) 1) -oppRB. -rewrite (addR_opp (log (`E X))) -logDiv //; last exact EX_gt0. -by apply: div_diff_ub; [exact/ltRW | - by move=> EX0; exfalso; move: EX0; apply/eqP/gtR_eqF/EX_gt0 | - exact/ltRW/EX_gt0]. +rewrite -{1}(_ : 1 + (`E X - 1) = `E X); last first. + by rewrite addrCA subrr addr0. +rewrite mulrDl mul1r. +rewrite -addrA. +rewrite lerD2l. +rewrite -mulrN. +rewrite -mulrDr. +rewrite -(mul1r (log (expR 1))). +rewrite -{3}(_ : (`E X + (1 - `E X)) = 1); last first. + by rewrite addrCA subrr addr0. +rewrite -opprB. +rewrite -logV; last first. + by rewrite opprB subr_gt0. +rewrite -logM; last 2 first. + by rewrite (lt_trans (@ltr01 _)). + by rewrite invr_gt0 ltrNr oppr0 subr_lt0. +rewrite -[in leRHS](opprK ((1 - `E X))). +apply: div_diff_ub. +- by rewrite opprB subr_ge0 ltW. +- move=> EX0. + move: EX_1. + by rewrite EX0 sub0r -ltrNr oppr0 ltNge ler01. +by rewrite (le_trans (@ler01 _) (ltW _)). Qed. End le_entroPN_logeEX. Section v_scode_converse'_1tuple. +Let R := Rdefinitions.R. Variables (A : finType) (P : {fdist A}). Variable f : A -> seq bool. Local Notation "'Nmax'" := (Nmax f). -Let X : {RV P -> R} := (INR \o size \o f). +Let X : {RV P -> R} := ((fun x => x%:R) \o size \o f). Local Notation "'PN'" := (PN P f). Hypothesis f_uniq : uniquely_decodable f. @@ -467,13 +477,13 @@ Definition Pf (i : seq bool) := if [ pick x | f x == i ] is Some x then P x else Lemma Rle0Pf i : 0 <= Pf i. Proof. rewrite /Pf. -by case: pickP => [x _ | _ ]; [exact/RleP/FDist.ge0|]. +by case: pickP => [x _ | _ ]; [exact/FDist.ge0|]. Qed. Lemma pmf1_Pf : \sum_(m < Nmax.+1) \sum_(a in {: m.-tuple bool}) Pf a = 1. Proof. move: (uniq_dec_inj f_uniq) => f_inj. -rewrite (_ : 1 = 1%mcR)// -(FDist.f1 P). +rewrite -(FDist.f1 P). rewrite (partition_big (inordf (size \o f)) (fun i => i \in 'I_Nmax.+1)) //=. apply: eq_bigr => i _. rewrite (big_seq_tuple i f_inj (fdist_card_neq0 P)) /Pf=>[|x]. @@ -490,12 +500,11 @@ Definition Pf' (m : 'I_Nmax.+1) := [ffun a : m.-tuple bool => Pf a / (PN m)]. Lemma Rle0Pf' (m : 'I_Nmax.+1) : PN m <> 0 -> [forall a : m.-tuple bool, (0 <= Pf' m a)%mcR]. Proof. -move=> PNnon0; apply/forallPP; first by move=> ?; exact/RleP. +move=> PNnon0; apply/forallP => /=. move=> a; rewrite /Pf'. -apply: (Rmult_le_reg_r (PN m)). - move/eqP in PNnon0. - by apply/RltP; rewrite lt0r PNnon0 ffunE; exact/RleP. -rewrite mul0R ffunE /Rdiv -mulRA -Rinv_l_sym // mulR1 /Pf. +rewrite ffunE. +rewrite divr_ge0//. +rewrite /Pf. by case: pickP. Qed. @@ -504,9 +513,11 @@ Proof. move: (uniq_dec_inj f_uniq) => f_inj PNnon0. rewrite /Pf'. under eq_bigr do rewrite ffunE. -rewrite -big_distrl /=. -apply: (Rmult_eq_reg_r (PN m)) => //; rewrite mul1R. -rewrite -mulRA mulVR ?mulR1; last exact/eqP. +rewrite -big_distrl. +apply: (@mulIf _ (PN m)). + exact/eqP. +rewrite -mulrA mulVf ?mulr1 ?mul1r; last first. + exact/eqP. rewrite /= ffunE. rewrite /pr_eq; unlock. rewrite /Pr (eq_bigr (fun x => Pf (f x))) => [|a ain]; last first. @@ -514,15 +525,14 @@ rewrite /Pr (eq_bigr (fun x => Pf (f x))) => [|a ain]; last first. case:pickP; first by move =>x /eqP/ f_inj ->. by move/(_ a); rewrite eqxx. rewrite (eq_bigl (fun x => size (f x) == m) _) => [|a]; last first. - rewrite inE /X /= -INRE. - by apply/eqP/eqP => [/INR_eq | ->]. + by rewrite inE /X /= eqr_nat. rewrite (big_seq_tuple m f_inj (fdist_card_neq0 P)) /Pf => [//|i0]. case: pickP => // ?; first by move/eqP <-; rewrite codom_f. by case: ifP. Qed. Lemma rsum_disjoints_set h : \sum_(a in [set : 'I_Nmax.+1]) h a = - \sum_(a in [set x | PN x == 0]) h a + \sum_(a in [set x | PN x != 0]) h a. + \sum_(a in [set x | PN x == 0]) h a + \sum_(a in [set x | PN x != 0]) h a :> R. Proof. rewrite -big_union //; last first. rewrite disjoints_subset. @@ -547,7 +557,7 @@ rewrite (eq_bigl (fun x => size (f x) == i) _) =>[|x]; last first. rewrite (@big_seq_tuple _ i _ f_inj (fun a => Pf a * log (Pf a)) (fdist_card_neq0 P))//. rewrite /Pf; move=> i0. case: (pickP ) => // x; first by move/eqP <-; rewrite codom_f. -by case: ifP; rewrite mul0R. +by case: ifP; rewrite mul0r. Qed. Lemma rewrite_HP_with_PN : @@ -557,20 +567,17 @@ Proof. rewrite rewrite_HP_with_Pf; congr (- _). rewrite (eq_bigl (fun m => m \in [set : 'I_Nmax.+1]) _) => [|?]; last first. by rewrite /= in_setT. -rewrite rsum_disjoints_set [Y in Y + _ = _]big1 ?add0R; last first. +rewrite rsum_disjoints_set [Y in Y + _ = _]big1 ?add0r; last first. move=> /= i; rewrite inE. rewrite /pr_eq; unlock. rewrite /Pr ffunE /= => /eqP/psumr_eq0P => H. - have {}H : forall j : A, j \in [set x | (size (f x))%:R == i%:R] -> P j = 0. + have {}H : forall j : A, j \in [set x | (size (f x))%:R == i%:R :> R] -> P j = 0. move=> a Ha. - apply: H => //. - rewrite inE/=. - rewrite inE in Ha. - by rewrite (eqP Ha) INRE. + by apply: H => //. rewrite big1 // => i0 _. rewrite {1}/Pf. - case: pickP => [a /eqP fai0|]; last by rewrite mul0R. - by rewrite H ?mul0R // inE fai0 size_tuple. + case: pickP => [a /eqP fai0|]; last by rewrite mul0r. + by rewrite H ?mul0r // inE fai0 size_tuple. apply : eq_bigr => i. rewrite inE /eqP => Pr_non0. rewrite big_distrr /=. @@ -578,19 +585,24 @@ apply : eq_bigr => i0 _. rewrite ffunE. rewrite {1}/Pf'. rewrite ffunE. -rewrite [in RHS]mulRC /Rdiv -mulRA -mulRA. -case: (Req_dec (Pf i0) 0) => [->| /nesym/eqP Pfi0_non0]; first by rewrite !mul0R. +rewrite [in RHS]mulrC -mulrA -mulrA. +have [->|Pfi0_non0] := eqVneq (Pf i0) 0. + by rewrite !mul0r. congr (_ * _). -rewrite mulRC -mulRA. +rewrite -mulrA. +rewrite mulrC. +rewrite -mulrA. rewrite {2}/PN. -rewrite [in X in _ = _ * (_ * / X)]/= [in X in _ = _ * (_ * / X)]ffunE. -rewrite mulRV ?mulR1; last by rewrite /PN /= ffunE in Pr_non0. -rewrite /log LogM; last 2 first. - apply/RltP; rewrite lt0r eq_sym Pfi0_non0; apply/RleP. - rewrite /Pf; case:pickP=>[? _ | ? ]; [exact/RleP/FDist.ge0 | by []]. - by apply/invR_gt0/RltP; rewrite -fdist_gt0. -rewrite LogV; last by apply/RltP; rewrite -fdist_gt0. -by rewrite /PN /= ffunE -addRA Rplus_opp_l addR0. +rewrite [in X in _ = _ * (_ / X)]/= [in X in _ = _ * (_ / X)]ffunE. +rewrite mulfV ?mulr1; last by rewrite /PN /= ffunE in Pr_non0. +rewrite logM; last 2 first. + rewrite lt_neqAle eq_sym Pfi0_non0//=. + rewrite /Pf. + by case: pickP => //. + rewrite invr_gt0. + by rewrite lt_neqAle eq_sym Pr_non0//= ffunE//. +rewrite logV; last by rewrite -fdist_gt0. +by rewrite /PN /= ffunE addrAC -addrA subrr addr0. Qed. Lemma rewrite_HP_with_HPN : `H P = @@ -602,93 +614,94 @@ rewrite {2}/entropy. rewrite (eq_bigl (fun m => m \in [set : 'I_Nmax.+1]) (fun x=> _ * log _))=>[|?]; last first. by rewrite /= in_setT. rewrite rsum_disjoints_set [Y in _ = _ + - (Y + _)]big1; last first. - by move => /= i; rewrite inE /PN /= => /eqP ->; rewrite mul0R. -rewrite add0R rewrite_HP_with_PN !big_morph_oppR -big_split /=. + by move => /= i; rewrite inE /PN /= => /eqP ->; rewrite mul0r. +rewrite add0r rewrite_HP_with_PN !big_morph_oppr -big_split /=. apply: eq_bigr => i. rewrite inE => /eqP Pr_non0. -rewrite mulRN -oppRD; congr (- _). -rewrite -mulRDr. congr (_ * _). -rewrite -[Y in _ = _ + Y]mul1R -(pmf1_Pf' Pr_non0) big_distrl /= -big_split /=. -by under eq_bigr do rewrite mulRDr. +rewrite mulrN -opprD; congr (- _). +rewrite -mulrDr. congr (_ * _). +rewrite -[Y in _ = _ + Y]mul1r -(pmf1_Pf' Pr_non0) big_distrl /= -big_split /=. +by under eq_bigr do rewrite mulrDr. Qed. Lemma apply_max_HPN : `H P <= `E X + `H PN. Proof. have f_inj := uniq_dec_inj f_uniq. -rewrite rewrite_HP_with_HPN addRC (addRC _ (`H _)) leR_add2l EX_ord. -rewrite (eq_bigl (fun m => m \in [set : 'I_Nmax.+1]) (fun x=> INR x * _ ))=>[|?]; last first. +rewrite rewrite_HP_with_HPN addrC (addrC _ (`H _)) lerD2l EX_ord. +rewrite (eq_bigl (fun m => m \in [set : 'I_Nmax.+1]) (fun x=> x%:R * _ ))=>[|?]; last first. by rewrite /= in_setT. rewrite rsum_disjoints_set. rewrite [Y in _ <= Y + _ ](_ :_ = 0). - rewrite add0R; apply: leR_sumR => i. - rewrite mulRC inE; move/eqP => H. - apply/leR_wpmul2r; first by rewrite /PN /= ffunE. - pose pmf_Pf' := mkNNFinfun (Rle0Pf' H). - have pmf1'_Pf' : ([forall a, (0 <= pmf_Pf' a)%mcR] && ((\sum_(a in {: i.-tuple bool}) pmf_Pf' a)%mcR == 1%mcR)). + rewrite add0r; apply: ler_sum => i. + rewrite mulrC inE; move/eqP => H. + rewrite ler_wpM2r//. +(* apply/leR_wpmul2r; first by rewrite /PN /= ffunE.*) +(* pose pmf_Pf' := mkNNFinfun (Rle0Pf' H).*) + have pmf1'_Pf' : ([forall a, (0 <= Pf' i a)%mcR] && ((\sum_(a in {: i.-tuple bool}) Pf' i a)%mcR == 1%mcR)). apply/andP; split. apply/forallP => x. - rewrite /pmf_Pf'/= /Pf'; rewrite ffunE. - apply/RleP/divR_ge0 => //. - exact: Rle0Pf. - by apply/RltP/fdist_gt0/eqP. + rewrite /Pf'; rewrite ffunE. + rewrite divr_ge0// /Pf. + by case: pickP. by apply/eqP; apply: (pmf1_Pf' H). pose distPf := FDist.mk pmf1'_Pf'. move: (entropy_max distPf). - rewrite card_tuple /= card_bool -natRexp log_pow (_ : INR 2 = 2) //. - by rewrite /log Log_n // mulR1. + rewrite card_tuple /= card_bool. + by rewrite natrX exprnP log_exprz// log2 mulr1. rewrite big1 //= => i. -by rewrite inE /PN /= => /eqP ->; rewrite mulR0. +by rewrite inE /PN /= => /eqP ->; rewrite mulr0. Qed. -Lemma apply_le_HN_logE_loge : `H P <= `E X + log ((exp 1) * `E X). +Lemma apply_le_HN_logE_loge : `H P <= `E X + log ((expR 1) * `E X). Proof. -apply: (leR_trans apply_max_HPN). -rewrite leR_add2l mulRC /log (LogM _ (EX_gt0 P f_uniq) (exp_pos 1)). +apply: (le_trans apply_max_HPN). +rewrite lerD2l mulrC. +rewrite (logM (EX_gt0 P f_uniq)) ?expR_gt0//. exact: le_entroPN_logeEX f_uniq. Qed. End v_scode_converse'_1tuple. Section v_scode_converse'_ntuple. - +Let R := Rdefinitions.R. Variables (A : finType) (n : nat). Variable f : encT A (seq bool) n. Variable P : {fdist A}. Hypothesis f_uniq : uniquely_decodable f. Lemma converse_case1 : @E_leng_cw _ _ P f < n%:R * log #|A|%:R -> -`H (P `^ n) <= @E_leng_cw _ _ P f + log ((exp 1) * n%:R * log #|A|%:R). +`H (P `^ n)%fdist <= @E_leng_cw _ _ P f + log ((expR 1) * n%:R * log #|A|%:R). Proof. -move=>H. -apply: (leR_trans (apply_le_HN_logE_loge (P `^ n) f_uniq)). -rewrite leR_add2l; apply: Log_increasing_le => //. - by apply/mulR_gt0; [exact/exp_pos | exact/EX_gt0]. -by rewrite -mulRA; apply: leR_wpmul2l; [exact/ltRW/exp_pos|exact/ltRW]. +move=> H. +apply: (le_trans (apply_le_HN_logE_loge (P `^ n)%fdist f_uniq)). +rewrite lerD2l//; apply: Log_increasing_le => //. + by rewrite mulr_gt0 ?expR_gt0// EX_gt0. +by rewrite -mulrA ler_wpM2l ?expR_ge0// ltW. Qed. Lemma converse_case2 : n%:R * log #|A|%:R <= @E_leng_cw _ _ P f -> - `H (P `^ n) <= @E_leng_cw _ _ P f. + `H (P `^ n)%fdist <= @E_leng_cw _ _ P f. Proof. -move=> H; rewrite entropy_TupleFDist; apply: (leR_trans _ H). -apply leR_wpmul2l; [exact/leR0n | exact/entropy_max]. +move=> H; rewrite entropy_TupleFDist; apply: (le_trans _ H). +by rewrite ler_wpM2l//; exact/entropy_max. Qed. End v_scode_converse'_ntuple. Section Extend_encoder. - +Let R := Rdefinitions.R. Variables (A : finType) (n m : nat). Variable f : encT A (seq bool) n. Variable P : {fdist A}. Hypothesis f_uniq : uniquely_decodable f. -Hypothesis m_non0 : 0 <> m%:R. +Hypothesis m_non0 : m%:R != 0 :> R. Let fm (x : 'rV['rV[A]_n]_m) := extension f (tuple_of_row x). Lemma fm_uniq : uniquely_decodable fm. Proof. pose m' := m.-1. have mpos : m = m'.+1. - rewrite prednK // -ltR_nat ltR_neqAle; split => //; exact/leR0n. + by rewrite prednK // -(ltr_nat R) lt_neqAle eq_sym m_non0/=. have: (@extension 'rV[A]_n _ f) \o (flatten \o map (fun x => @tval m _ (tuple_of_row x))) =1 @extension {: 'rV[ 'rV[A]_n ]_m} _ fm. @@ -706,20 +719,20 @@ elim => /= [| ta1 sta1 IHsta1]; case => [| ta2 sta2] //=. exact/tuple_of_row_inj/eqP. Qed. -Lemma ELC_TupleFDist : @E_leng_cw _ _ (P `^ n) fm = m%:R * @E_leng_cw _ _ P f. +Lemma ELC_TupleFDist : @E_leng_cw _ _ (P `^ n)%fdist fm = m%:R * @E_leng_cw _ _ P f. Proof. rewrite /E_leng_cw /= /fm. -pose X := INR \o size \o f. +pose X := (fun x => x%:R : R) \o size \o f. elim: m => [|m']. - rewrite mul0R /Ex big1 // => i _. - rewrite fdist_rV0 ?mulR1. + rewrite mul0r /Ex big1 // => i _. + rewrite fdist_rV0 ?mulr1. rewrite /comp_RV. rewrite [tuple_of_row]lock /= -lock. rewrite (_ : tuple_of_row i = [tuple]) //. apply: eq_from_tnth. by case; case. elim: m' => [_ |m'' _ IH]. - rewrite mul1R. + rewrite mul1r. rewrite -[in RHS]E_cast_RV_fdist_rV1. apply: eq_bigr => i _. rewrite fdist_rV1; congr (_ * _). @@ -729,12 +742,13 @@ elim: m' => [_ |m'' _ IH]. by apply eq_from_tnth => a; rewrite {a}(ord1 a) tnth_mktuple. by rewrite /extension /= cats0. pose fm1 (x : 'rV['rV[A]_n]_(m''.+1)) := extension f (tuple_of_row x). -pose Xm1 := INR \o size \o fm1. +pose Xm1 := (fun x => x%:R : R) \o size \o fm1. pose fm2 (x : 'rV['rV[A]_n]_(m''.+2)) := extension f (tuple_of_row x). -pose Xm2 := INR \o size \o fm2. +pose Xm2 := (fun x => x%:R : R) \o size \o fm2. have X_Xm1_Xm2 : Xm2 \= X @+ Xm1. rewrite /Xm2 => x /=. - rewrite -plus_INR plusE -size_cat. + rewrite /X/= /Xm1/= -natrD. + rewrite -size_cat. rewrite /fm2 /extension /fm1 /extension. rewrite [tuple_of_row]lock /= -lock. congr ((size _)%:R). @@ -746,160 +760,201 @@ have X_Xm1_Xm2 : Xm2 \= X @+ Xm1. rewrite (_ : tuple_of_row _ = [tuple of [:: x ``_ ord0]]); last first. by apply eq_from_tnth => i; rewrite {i}(ord1 i) /= tnth_mktuple mxE. by rewrite /= cats0. -rewrite (E_sum_2 X_Xm1_Xm2) S_INR mulRDl -IH addRC; congr (_ + _)%R. +rewrite (E_sum_2 X_Xm1_Xm2). +rewrite -natr1 mulrDl -IH addrC; congr +%R. by rewrite /Xm1 -/fm1 /Ex tail_of_fdist_rV_fdist_rV. -by rewrite -/X mul1R /Ex head_of_fdist_rV_fdist_rV. +by rewrite -/X mul1r /Ex head_of_fdist_rV_fdist_rV. Qed. End Extend_encoder. Section v_scode_converse'. - +Let R := Rdefinitions.R. Variables (A : finType) (P : {fdist A}). Variable n : nat. Variable f : encT A (seq bool) n. Hypothesis f_uniq : uniquely_decodable f. -Let alp := exp 1 * log (INR #| 'rV[A]_n |). -Let m''' eps := Z.abs_nat (ceil (4 / (n%:R * eps * ln 2))). +Let alp : R := expR 1 * log (#| 'rV[A]_n |%:R). +Let m''' eps := `|(Num.ceil (4 / (n%:R * eps * exp.ln 2) : R))|%N. Let m'' eps := maxn (m''' eps) 1. -Let m' eps := (maxn (Z.abs_nat (ceil (ln alp + n%:R * eps * ln 2))) (m'' eps))%:R. -Let m eps := Z.abs_nat (floor (exp (m' eps))). +Let m' eps : R := (maxn (`|(ceil (exp.ln alp + n%:R * eps * exp.ln 2))|%N) (m'' eps))%:R. +Let m eps := `|Num.floor (expR (m' eps) : R)|%N. -Lemma mpos eps : 0 <> INR n -> 0 < (m eps)%:R. +Lemma mpos eps : (0:R) <> n%:R -> (0:R) < (m eps)%:R. Proof. rewrite /m => nnon0. -rewrite (_ : 0 = INR 0)//; apply: lt_INR. -rewrite {1}(_ : 0%nat = Z.abs_nat 0)//; apply: Zabs_nat_lt; split => //. -apply: lt_0_IZR. -apply: (@ltR_trans (exp (m' eps) - 1)); last exact: (proj1 (floorP _)). -rewrite -(@ltR_add2r 1) addRC /Rdiv -addRA Rplus_opp_l 2!addR0 -{1}exp_0. -apply: exp_increasing. -rewrite (_ : 0 = INR 0) //; apply: lt_INR; apply: ltP. -apply: (@leq_trans (m'' eps)); last exact: leq_maxr. -by apply: (@leq_trans 1); last exact: leq_maxr. +rewrite ltr0n. +rewrite absz_gt0. +rewrite mathcomp_extra.floor_neq0; apply/orP; right. +by rewrite -expR0 ler_expR. Qed. -Lemma le_eps eps : 0 <> n%:R -> 1 <= n%:R * log #|A|%:R -> 0 < eps -> - log ((m eps)%:R * alp) * / (m eps)%:R * / n%:R <= eps. +Lemma le_eps eps : (0:R) <> n%:R -> (1:R) <= n%:R * log #|A|%:R -> (0:R) < eps -> + log ((m eps)%:R * alp) / (m eps)%:R / n%:R <= eps. Proof. move=> nnon0 eps_pos cardA_non1. pose x := m' eps. -pose Y := eps * INR n * ln 2. -have npos : 0 < INR n. - by case/Rdichotomy : nnon0 => //; rewrite (_ : 0 = INR 0)// => /INR_lt/ltP. +pose Y := eps * n%:R * exp.ln 2. +have npos : 0 < n%:R :> R. + rewrite lt_neqAle. + by move/eqP: nnon0 => -> /=. have xpos : 0 < x. - rewrite (_ : 0 = INR 0)//; apply: lt_INR; apply/leP. + rewrite ltr0n. apply: (@leq_trans (m'' eps)); last exact: leq_maxr. by apply: (@leq_trans 1); last exact: leq_maxr. -have mpos': (0 < floor (exp x))%Z. - apply/lt_IZR/(@ltR_trans (exp x - 1)); last exact: (proj1 (floorP _)). - rewrite -(@ltR_add2r 1) addRC /Rminus -addRA Rplus_opp_l 2!addR0 -exp_0. - exact: exp_increasing. +have mpos': (0 < floor (expR x)). + rewrite lt_neqAle -floor_ge_int exp.expR_ge0 andbT. + rewrite eq_sym mathcomp_extra.floor_neq0. + apply/orP; right. + by rewrite -exp.expR0 exp.ler_expR//. have le_1_alp : 1 <= alp. - rewrite /alp -(mulR1 1). - apply/leR_pmul => //. - rewrite mulR1; apply: (@leR_trans 2); last exact: leR2e. - by rewrite (_ : 1 = 1%:R) // (_ : 2 = 2%:R) // leR_nat. - rewrite card_mx -natRexp mul1n log_pow //. - rewrite (_ : 0 = INR 0) //; apply/lt_INR/ltP/fdist_card_neq0. - exact: P. -have alppos : 0 < alp by exact: (@ltR_leR_trans 1). -have Ypos : 0 < Y by apply/mulR_gt0 => //; apply/mulR_gt0. -apply: (Rmult_le_reg_r (INR (m eps) * INR n)). - by apply: mulR_gt0 => //; apply/mpos. -rewrite -mulRA (mulRC (/ INR n) _ ) -mulRA -mulRA -Rinv_r_sym; last exact: nesym. -rewrite mulR1 mulVR ?mulR1; last exact/gtR_eqF/mpos/eqP/ltR_eqF. -apply: (@leR_trans ((x ^ 2 / 2 - 1) * eps * (INR n))); last first. - rewrite -mulRA mulRC -mulRA; apply: leR_wpmul2l; first exact: ltRW. - rewrite mulRC; apply: leR_wpmul2r; first exact/ltRW. - apply: (@leR_trans (exp x - 1)). - rewrite leR_subl_addr subRK (_ : 2 = INR 2 `!)//; exact/(exp_lb 2)/pos_INR. - rewrite INR_Zabs_nat; last exact/le_IZR/ltRW/IZR_lt. - exact/ltRW/(proj1 (floorP _)). -rewrite INR_Zabs_nat; last exact/le_IZR/Rlt_le/IZR_lt. -rewrite {1}/log LogM//; last exact: IZR_lt. -rewrite -/(log _). -rewrite -(leR_pmul2r ln2_gt0). -rewrite mulRDl /Log/Rdiv -(mulRA (ln alp)) (mulVR _ ln2_neq0). -rewrite mulR1 -(mulRA _ (/ ln 2) _) (mulVR _ ln2_neq0). -apply: (@leR_trans (x + ln alp)). - rewrite leR_add2r ?mulR1 -(ln_exp x). - apply: ln_increasing_le; last exact: (proj2 (floorP _)). - apply: (@ltR_trans (exp x - 1)); last exact: proj1 (floorP _). - rewrite subR_gt0 -exp_0; exact: exp_increasing. -apply: (@leR_trans (2 * x - (eps * INR n * ln 2))). - rewrite -Rplus_diag /Rminus -addRA leR_add2l addR_opp leR_subr_addr (mulRC eps). - apply: (@leR_trans (IZR (ceil (ln alp + n%:R * eps * ln 2)))); first exact: proj1 (ceilP _). - rewrite -INR_Zabs_nat; first exact/le_INR/leP/leq_maxl. - apply: le_IZR. - apply: (@leR_trans (ln alp + Y)); last first. - by rewrite /Y (mulRC eps); exact: proj1 (ceilP _). - apply/addR_ge0; last exact/ltRW. - by rewrite -(ln_exp 0) exp_0; exact: ln_increasing_le. -rewrite -(mulRA _ eps) -(mulRA _ (eps * INR n)). -rewrite mulRBl mul1R leR_add2r. -apply: (Rmult_le_reg_r (/ Y * 2 * / x)). - by apply/mulR_gt0; [apply/mulR_gt0 => //; exact/invR_gt0|exact/invR_gt0]. -rewrite mulRC -mulRA (mulRC (/ x)) -mulRA -mulRA mulRV; last exact/gtR_eqF. + rewrite /alp -(mulr1 1). + rewrite ler_pM//. + rewrite mulr1; apply: (@le_trans _ _ 2); last first. + rewrite (_ : 2 = 1 + 1)//. + by rewrite exp.expR_ge1Dx. + by rewrite ler1n. + rewrite mul1r//. + rewrite card_mx mul1n. + rewrite natrX exprnP log_exprz// ltr0n. + exact/(fdist_card_neq0 P). +have alppos : 0 < alp by exact: (@lt_le_trans _ _ 1). +have Ypos : 0 < Y. + by rewrite mulr_gt0// ?mulr_gt0// ln2_gt0. +rewrite -mulrA -invfM ler_pdivrMr//; last first. + by rewrite mulr_gt0//; apply: mpos. +(*rewrite mulR1 mulVR ?mulR1; last exact/gtR_eqF/mpos/eqP/ltR_eqF.*) +apply: (@le_trans _ _ ((x ^ 2 / 2 - 1) * eps * n%:R)); last first. + rewrite -mulrA mulrC -mulrA. + rewrite ler_wpM2l//; first exact/ltW. + rewrite mulrC ler_wpM2r//. + apply: (@le_trans _ _ (expR x - 1)). + rewrite lerBlDr subrK (_ : 2 = (2 `!)%:R)//. + exact/ltW/exp_strict_lb. + rewrite /m /x. + rewrite lerBlDr. + rewrite (le_trans (ltW (mathcomp_extra.lt_succ_floor _)))//. + rewrite natr_absz. + rewrite mathcomp_extra.intrD1 ler_int. + rewrite lerD2r. + by rewrite ler_norm. +rewrite logM//; last exact: mpos. +rewrite -(ler_pM2r ln2_gt0). +rewrite mulrDl -(mulrA (ln alp)) (mulVf ln2_neq0). +rewrite mulr1 -(mulrA _ (ln 2)^-1 _) (mulVf ln2_neq0). +apply: (@le_trans _ _ (x + ln alp)). + rewrite lerD2r ?mulr1 -(expRK x). + rewrite ler_ln ?posrE ?expR_gt0//; last exact: mpos. + rewrite /m /x. + rewrite (le_trans _ (ge_floor _))//. + rewrite natr_absz ler_int. + by rewrite ger0_norm// mathcomp_extra.floor_ge0// expR_ge0. +apply: (@le_trans _ _ (2 * x - (eps * n%:R * ln 2))). + rewrite mulr_natl mulr2n -addrA lerD2l. + rewrite lerBrDr (mulrC eps). + apply: (@le_trans _ _ ((Num.ceil (ln alp + n%:R * eps * ln 2))%:~R)). + by rewrite le_ceil. + rewrite /x /m'. + rewrite (le_trans (ler_norm _))//. + rewrite -intr_norm. + rewrite -natr_absz ler_nat. + by rewrite leq_max leqnn. +rewrite -(mulrA _ eps) -(mulrA _ (eps * n%:R)). +rewrite mulrBl mul1r lerD2r. +rewrite -/Y. +rewrite -(@ler_pM2l _ ((Y^-1 * 2 / x))); last first. + by rewrite mulr_gt0 ?invr_gt0// mulr_gt0// invr_gt0. +(* apply: (Rmult_le_reg_r ). + by apply/mulR_gt0; [apply/mulR_gt0 => //; exact/invR_gt0|exact/invR_gt0].*) +rewrite -!mulrA (mulrCA x^-1) mulVf ?mulr1 ?gt_eqF//. +rewrite (mulrA x^-1) mulVf ?mul1r ?gt_eqF//. +rewrite (mulrCA 2) (mulrA 2) divff ?gt_eqF// mul1r. +rewrite [leRHS]mulrCA mulVf ?mulr1 ?gt_eqF//. +(*rewrite mulrC -mulrA. (mulrC (x^-1)) -mulrA -mulrA mulfV. rewrite mulR1 mulRC mulRA mulRA (mulRC _ (/x)) /= mulR1 mulRA (mulRC _ 2). rewrite -(mulRA _ Y) mulRV ?mulR1; last exact/gtR_eqF. rewrite (mulRC 2) !mulRA -(mulRA _ _ 2) !mulVR // ?(mul1R,mulR1); last 2 first. exact/eqP. - exact/gtR_eqF. -apply: (@leR_trans (m'' eps)%:R); last exact/le_INR/leP/leq_maxr. -apply: (@leR_trans (m''' eps)%:R); last exact/le_INR/leP/leq_maxl. -rewrite INR_Zabs_nat. - apply: (@leR_trans ((4 * / (INR n * eps * ln 2)))); last exact: proj1 (ceilP _). - by rewrite (mulRC n%:R); apply/RleP; rewrite lexx. -apply: le_IZR. -apply: (@leR_trans ((4 * / (INR n * eps * ln 2)))); last exact: proj1 (ceilP _). -apply: Rle_mult_inv_pos; first exact: ltRW (@mulR_gt0 2 2 _ _). -by rewrite (mulRC n%:R). + exact/gtR_eqF.*) +apply: (@le_trans _ _ (m'' eps)%:R); last first. + rewrite /x /m'. + rewrite ler_nat. + by rewrite leq_maxr. +(*exact/le_INR/leP/leq_maxr.*) +apply: (@le_trans _ _ (m''' eps)%:R); last first. + by rewrite /m'' ler_nat leq_max leqnn. +rewrite /m'''. +rewrite (mulrC n%:R) -/Y. +rewrite mulrC -natrM. +rewrite (le_trans (le_ceil _))//. +rewrite natr_absz. +rewrite (le_trans (ler_norm _))//. +by rewrite intr_norm. Qed. Theorem v_scode_converse' : n%:R * `H P <= @E_leng_cw _ _ P f. Proof. -case: (Req_dec 0 (INR n))=>[<-|nnon0]. - by rewrite mul0R; apply/ltRW/(EX_gt0 (P `^ n) f_uniq). -have npos : 0 < n%:R by rewrite (_ : 0 = INR 0) // ltR_neqAle leR_nat leq0n. -rewrite -(@leR_pmul2r (/ n%:R)); last exact/invR_gt0. -rewrite (mulRC (INR n)) -mulRA mulRV ?mulR1; last exact/gtR_eqF. -apply: le_epsilon => eps eps0. +have [<-|nnon0] := eqVneq (0:R) n%:R. + rewrite mul0r ltW//. + rewrite /E_leng_cw. + by rewrite EX_gt0//. +have npos : 0 < n%:R :> R. + move: nnon0. + rewrite eq_sym pnatr_eq0 ltr0n. + by rewrite lt0n. +rewrite -ler_pdivlMl// mulrC. +(*rewrite (mulRC (INR n)) -mulRA mulRV ?mulR1; last exact/gtR_eqF.*) +apply/ler_addgt0Pl => /= eps eps0. pose fm (x : 'rV['rV[A]_n]_((m eps))) := extension f (tuple_of_row x). -case: (Rle_or_lt ((m eps)%:R * (log #| 'rV[A]_n |%:R)) (@E_leng_cw _ _ (P `^ n) fm)). - move/(@converse_case2 _ _ fm (P `^ n)). +have [|] := leP ((m eps)%:R * (log #| 'rV[A]_n |%:R)) (@E_leng_cw _ _ (P `^ n)%fdist fm). + move/(@converse_case2 _ _ fm (P `^ n)%fdist). rewrite !entropy_TupleFDist ELC_TupleFDist. - rewrite (leR_pmul2l (mpos eps nnon0)) => H. - apply: (@leR_trans (@E_leng_cw _ _ P f / n%:R)) => //. - by rewrite leR_pdivl_mulr // mulRC. - by rewrite leR_addl; exact/ltRW. -have mnon0 : (m eps)%:R <> 0 by exact/eqP/gtR_eqF/mpos. + rewrite ler_pM2l//; last first. + apply: mpos => //. + exact/eqP. + move=> H. + apply: (@le_trans _ _ (@E_leng_cw _ _ P f / n%:R)) => //. + by rewrite ler_pdivlMr// mulrC. + by rewrite ler_wpDl// ltW. +have mnon0 : (m eps)%:R <> 0 :> R. + apply/eqP. + rewrite gt_eqF// mpos//. + exact/eqP. move => case2. -move: (@converse_case1 _ _ _ (P `^ n) - (fm_uniq f_uniq (Rlt_not_eq _ _ (mpos eps nnon0))) case2). -rewrite !entropy_TupleFDist ELC_TupleFDist -!mulRA mulRA. -move/(Rmult_le_compat_r _ _ _ (Rlt_le _ _ (Rinv_0_lt_compat _ (mpos eps nnon0)))). -rewrite -mulRA -mulRA mulRC mulRA -mulRA mulVR ?mulR1; last exact/eqP. -rewrite mulRDl (mulRC (m eps)%:R) -mulRA ?mulRV ?mulR1; last exact/eqP. -move/(Rmult_le_compat_r _ _ _ (Rlt_le _ _ (Rinv_0_lt_compat _ npos))). -rewrite (mulRC (INR n)) -mulRA mulRV ?mulR1; last exact/gtR_eqF. -rewrite mulRDl. -move/leR_trans; apply. -rewrite leR_add2l. -rewrite mulRA (mulRC (exp 1)) -(mulRA (m eps)%:R). -apply le_eps => //. +move/eqP in mnon0. +move: (@converse_case1 _ _ _ (P `^ n)%fdist + (fm_uniq f_uniq mnon0) case2). +rewrite !entropy_TupleFDist ELC_TupleFDist -!mulrA mulrA. +rewrite -ler_pdivlMl; last first. + rewrite mulr_gt0//. + apply: mpos. + exact/eqP. +move=> /le_trans; apply. +rewrite mulrDr. +rewrite {1}invfM. +rewrite mulrCA. +rewrite ![in X in X + _ <= _](mulrA (m eps)%:R) divff// mul1r. +rewrite mulrC addrC lerD2r. +rewrite mulrC. +move/eqP in nnon0. +rewrite invfM. +rewrite (mulrCA (expR 1)). +rewrite (mulrA (log _)). +apply: le_eps => //. move: case2. -rewrite ELC_TupleFDist mulRC (mulRC (m eps)%:R) card_mx mul1n -natRexp log_pow; last first. - by rewrite (_ : 0 = INR 0) //; apply/lt_INR/ltP/fdist_card_neq0; exact: P. -move/(ltR_pmul2r (mpos eps nnon0)) => /ltRW. -by apply: leR_trans; exact/le_1_EX. +rewrite ELC_TupleFDist mulrC (mulrC (m eps)%:R) card_mx mul1n. +rewrite natrX log_exprz; last first. + by rewrite ltr0n// (fdist_card_neq0 P). +rewrite ltr_pM2r//; last exact: mpos. +move=> /ltW. +apply: le_trans. +exact/le_1_EX. Qed. End v_scode_converse'. Section v_scode_converse. - Variables (A : finType) (P : {fdist A}) (n : nat). Variable f : encT A (seq bool) n. Hypothesis f_uniq : uniquely_decodable f. diff --git a/information_theory/source_coding_vl_direct.v b/information_theory/source_coding_vl_direct.v index 4e0e266b..bfa457d6 100644 --- a/information_theory/source_coding_vl_direct.v +++ b/information_theory/source_coding_vl_direct.v @@ -1,9 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. -Require Import Reals Lra. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext realType_ext logb ssr_ext ssralg_ext bigop_ext. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint matrix. +From mathcomp Require Import archimedean lra ring. +From mathcomp Require Import Rstruct reals exp. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln. Require Import fdist proba entropy aep typ_seq natbin source_code. (******************************************************************************) @@ -28,9 +28,12 @@ Local Open Scope fdist_scope. Local Open Scope entropy_scope. Local Open Scope typ_seq_scope. -Local Open Scope R_scope. +Local Open Scope ring_scope. + +Import Order.POrderTheory GRing.Theory Num.Theory Num.Def Order.TotalTheory. Section R_lemma. +Let R := Rdefinitions.R. Variable (X : finType) (n' : nat). Variable f0 : X -> R. Let n := n'.+1. @@ -43,97 +46,94 @@ rewrite (bigID (fun x => x \in S)) /=; congr (_ + _). by apply eq_bigl => x /=; rewrite inE. Qed. -Lemma log_pow_INR m k : (m > 0)%nat -> log (expn m k)%:R = k%:R * log m%:R. +Lemma log_pow_INR m k : (m > 0)%nat -> log (expn m k)%:R = k%:R * log m%:R :> R. Proof. -move=> m0; elim: k => [|k ih]; first by rewrite expn0 /log Log_1 mul0R. -rewrite expnS natRM /log LogM ?ltR0n // ?expn_gt0 ?m0 // -!/(log _) ih. -by rewrite -addn1 natRD addRC mulRDl mul1R. +move=> m0; elim: k => [|k ih]; first by rewrite expn0 /log Log1 mul0r. +rewrite expnS natrM logM ?ltr0n // ?expn_gt0 ?m0 // ih. +by rewrite -nat1r mulrDl mul1r. Qed. -Lemma elevenOverTwelve_le_One : / 4 + / 3 + / 3 < 1. +Lemma elevenOverTwelve_le_One : 4^-1 + 3^-1 + 3^-1 < 1 :> R. Proof. -apply: (Rmult_lt_reg_r 3); first exact: Rplus_lt_pos. -rewrite 2!mulRDl -Rinv_l_sym // mul1R mulRC. -apply: (Rmult_lt_reg_r 4); first exact: Rmult_lt_0_compat. -rewrite 2!mulRDl -mulRA -Rinv_l_sym //=. -rewrite !(mulR1, mul1R) 2!mulRDl !mul1R. -rewrite addRC; apply: Rplus_lt_compat_l. -apply: Rplus_lt_compat_r; apply: (Rlt_le_trans _ _ _ (Rlt_plus_1 _)). lra. Qed. End R_lemma. +Import Order.POrderTheory GRing.Theory Num.Theory Num.Def Order.TotalTheory. + Section Length. +Let R := Rdefinitions.R. Variable (X : finType) (n' : nat). Let n := n'.+1. Variable P : R.-fdist X. Variable epsilon : R. Hypothesis eps_pos : 0 < epsilon. -Lemma fdist_support_LB : 1 <= INR #|X|. -Proof. rewrite (_ : 1 = INR 1) //; apply/le_INR/leP/fdist_card_neq0; exact: P. Qed. +Lemma fdist_support_LB : 1 <= #|X|%:R :> R. +Proof. rewrite (_ : 1 = 1%:R) // ler_nat; apply/fdist_card_neq0; exact: P. Qed. -Lemma fdist_supp_lg_add_1_neq_0 : 1 + log (INR #|X|) <> 0. +Lemma fdist_supp_lg_add_1_neq_0 : 1 + log (#|X|%:R) != 0 :> R. Proof. -by apply: nesym; apply: Rlt_not_eq; apply: (Rplus_lt_le_0_compat _ _ Rlt_0_1); - rewrite -(Log_1 2); apply: Log_increasing_le => //; apply: fdist_support_LB. +rewrite gt_eqF// ltr_pwDl//. +rewrite -log1 ler_log ?posrE// ?fdist_support_LB//. +by rewrite (lt_le_trans _ fdist_support_LB)//. Qed. -Definition L_typ := ceil (INR n * (`H P + epsilon)). -Definition L_not_typ := ceil (log (INR #| [set : n.-tuple X]|)). +Definition L_typ := Num.ceil (n%:R * (`H P + epsilon)). +Definition L_not_typ := Num.ceil (log (#| [set : n.-tuple X]|%:R) : R). -Lemma Lt_pos : 0 < IZR L_typ. +Lemma Lt_pos : 0 < L_typ%:~R :> R. Proof. -apply: (Rlt_le_trans _ (INR n * (`H P + epsilon))); last exact: (proj1 (ceilP _)). -rewrite -(mulR0 0). -apply: (Rmult_le_0_lt_compat _ _ _ _ (Rle_refl _) (Rle_refl _)). -- by apply: lt_0_INR; apply/ltP. -- by apply(Rplus_le_lt_0_compat _ _ (entropy_ge0 P) eps_pos). +apply: (@lt_le_trans _ _ (n%:R * (`H P + epsilon))); last first. + by rewrite le_ceil. +by rewrite mulr_gt0// ltr_pwDr// entropy_ge0. Qed. -Lemma Lnt_nonneg : 0 <= IZR L_not_typ. +Lemma Lnt_nonneg : 0 <= L_not_typ%:~R :> R. Proof. -apply: (Rle_trans _ (log (INR #|[set: n.-tuple X]|))); last exact: (proj1 (ceilP _)). -rewrite -(Log_1 2); apply: Log_increasing_le => //. -rewrite cardsT card_tuple -natRexp. -by apply: pow_R1_Rle; apply: fdist_support_LB. +apply: (@le_trans _ _ (log (#|[set: n.-tuple X]|%:R))); last first. + by rewrite le_ceil. +rewrite -log1 ler_log ?posrE// cardsT card_tuple. + by rewrite natrX exprn_ege1// fdist_support_LB. +rewrite natrX exprn_gt0//. +by rewrite (lt_le_trans _ fdist_support_LB). Qed. -Lemma card_le_TS_Lt : INR #| `TS P n epsilon | <= INR #|[ set : (Z.abs_nat L_typ).-tuple bool]|. +Lemma card_le_TS_Lt : #| `TS P n epsilon |%:R <= #|[ set : `|L_typ|%N.-tuple bool]|%:R :> R. Proof. -apply: (Rle_trans _ _ _ (TS_sup _ _ _)). -rewrite cardsT /= card_tuple /= card_bool. -rewrite -natRexp2. -apply: Exp_le_increasing => //. -rewrite INR_Zabs_nat. -- exact: (proj1 (ceilP _)). -- by apply: le_IZR; apply: ltRW; apply: Lt_pos. +apply: (le_trans (TS_sup _ _ _)). +rewrite cardsT /= card_tuple /= card_bool. +rewrite natrX. +rewrite -exp.powR_mulrn//. +rewrite exp.ler_powR ?ler1n//. +rewrite (le_trans (le_ceil _))//. +rewrite natr_absz ler_int. +by rewrite ler_norm. Qed. -Lemma card_le_Xn_Lnt' : INR #| [set: n.-tuple X]| <= INR #| [set: (Z.abs_nat L_not_typ).-tuple bool]|. +Lemma card_le_Xn_Lnt' : #| [set: n.-tuple X]|%:R <= #| [set: `|L_not_typ|%N.-tuple bool]|%:R :> R. Proof. -have fact : log (INR (expn #|X| n)) <= IZR (ceil (log (INR (expn #|X| n)))). - exact: (proj1 (ceilP _)). rewrite /L_not_typ cardsT card_tuple. -rewrite {1}(_ : INR (expn #|X| n) = exp2 (log (INR (expn #|X| n)))). --rewrite cardsT card_tuple card_bool -natRexp2. - apply: Exp_le_increasing => //. - rewrite /L_not_typ INR_Zabs_nat //. - apply: le_IZR; apply: (Rle_trans _ (log (INR (expn #|X| n)))) => //. - rewrite /= -(Log_1 2); apply: Log_increasing_le => //. - rewrite -natRexp. - by apply: pow_R1_Rle; apply: fdist_support_LB. --rewrite logK //; last rewrite -natRexp. - exact/pow_lt/(Rlt_le_trans _ 1 _ _ fdist_support_LB). +rewrite {1}(_ : (expn #|X| n)%:R = 2 `^ (log ((expn #|X| n)%:R))). +- rewrite cardsT card_tuple card_bool. + rewrite [in leRHS]natrX. + rewrite -powR_mulrn//. + rewrite ler_powR ?ler1n//. + rewrite (le_trans (le_ceil _))//. + rewrite natr_absz ler_int. + by rewrite (le_trans (ler_norm _)). +- rewrite LogK// natrX exprn_gt0//. + by rewrite (lt_le_trans _ fdist_support_LB). Qed. End Length. Section Enc_Dec. +Let R := Rdefinitions.R. Variable (X : finType) (n' : nat). Let n := n'.+1. -Variable P : {fdist X}. +Variable P : R.-fdist X. Variable epsilon : R. Hypothesis eps_pos : 0 < epsilon. @@ -142,14 +142,14 @@ Local Notation "'L_not_typ'" := (L_not_typ X n'). Definition enc_typ x := let i := seq.index x (enum (`TS P n epsilon)) - in Tuple (size_bitseq_of_nat i (Z.abs_nat L_typ)). + in Tuple (size_bitseq_of_nat i (`|L_typ|%N)). Lemma card_le_Xn_Lnt : - (#|[the finType of n.-tuple X] | <= #|[the finType of (Z.abs_nat L_not_typ).-tuple bool]|)%nat. + (#|[the finType of n.-tuple X] | <= #|[the finType of `|L_not_typ|%N.-tuple bool]|)%nat. Proof. rewrite -!cardsT. -apply/leP. -apply: (INR_le _ _ (card_le_Xn_Lnt' n' P)). +rewrite -(ler_nat R). +by rewrite (card_le_Xn_Lnt' n' P). Qed. Definition enc_not_typ x := enum_val (widen_ord card_le_Xn_Lnt (enum_rank x)). @@ -165,8 +165,9 @@ Definition f : encT X (seq bool) n := fun x => Lemma f_inj : injective f. Proof. -have card_TS_Lt : (#|`TS P n epsilon| <= (expn 2 (Z.abs_nat L_typ)))%nat. - by apply/leP; apply: INR_le; move: (card_le_TS_Lt n' P eps_pos); +have card_TS_Lt : (#|`TS P n epsilon| <= (expn 2 (`|L_typ|)))%nat. + rewrite -(ler_nat R). + by move: (card_le_TS_Lt n' P epsilon); rewrite {1}cardsT card_tuple /= card_bool. move=> t1 t2; rewrite /f. case/boolP : (t1 == t2) ; first by move /eqP. @@ -174,7 +175,7 @@ move=> mainCase. case: ifP=>?; case: ifP=>? //; case=> H; last by apply/tuple_of_row_inj/inj_enc_not_typ/val_inj. - have {}H : index t1 (enum (`TS P n epsilon)) = index t2 (enum (`TS P n epsilon)) - by apply (@bitseq_of_nat_inj (Z.abs_nat L_typ)) => //; apply: (leq_trans _ card_TS_Lt); + by apply (@bitseq_of_nat_inj (`|L_typ|%N)) => //; apply: (leq_trans _ card_TS_Lt); apply: seq_index_enum_card => //; apply: enum_uniq. rewrite -(@nth_index _ t1 t1 (enum (`TS P n epsilon))); last by rewrite mem_enum. rewrite -(@nth_index _ t1 t2 (enum (`TS P n epsilon))); last by rewrite mem_enum. @@ -219,196 +220,218 @@ Qed. End Enc_Dec. Section E_Leng_Cw_Lemma. +Let R := Rdefinitions.R. Variables (X : finType). Variable (n' : nat). Let n := n'.+1. Variable P : {fdist X}. Variable epsilon : R. Hypothesis eps_pos : 0 < epsilon. -Hypothesis aepbound_UB : aep_bound P epsilon <= INR n. +Hypothesis aepbound_UB : aep_bound P epsilon <= n%:R. Local Notation "'L_typ'" := (L_typ n' P epsilon). Local Notation "'L_not_typ'" := (L_not_typ X n'). Lemma eq_sizef_Lt : - \sum_(x| x \in `TS P n epsilon) P `^ n (x) * (INR (size (f P epsilon x)) ) = - \sum_(x| x \in `TS P n epsilon) P `^ n (x) * (IZR L_typ + 1). + \sum_(x| x \in `TS P n epsilon) (P `^ n)%fdist (x) * (size (f P epsilon x))%:R = + \sum_(x| x \in `TS P n epsilon) (P `^ n)%fdist (x) * (L_typ%:~R + 1). Proof. apply: eq_bigr=> i H. -apply: Rmult_eq_compat_l. -rewrite /f H /= size_pad_seqL -INR_Zabs_nat. --by rewrite -addn1; rewrite plus_INR. --by apply: le_IZR;apply: ltRW; apply: Lt_pos. +congr (_ * _). +rewrite /f H /= size_pad_seqL. +rewrite -natr1 natr_absz. +congr (_ %:~R + _). +rewrite ger0_norm//. +rewrite -(ler_int R) ltW//. +by rewrite Lt_pos. Qed. Lemma eq_sizef_Lnt: - \sum_(x| x \in ~:(`TS P n epsilon)) P `^ n (x) * (INR (size (f P epsilon x)) ) - = \sum_(x| x \in ~:(`TS P n epsilon)) P `^ n (x) * (IZR L_not_typ + 1) . + \sum_(x| x \in ~:(`TS P n epsilon)) (P `^ n)%fdist x * (size (f P epsilon x))%:R + = \sum_(x| x \in ~:(`TS P n epsilon)) (P `^ n)%fdist x * (L_not_typ%:~R + 1) . Proof. apply: eq_bigr => ? H. -apply: Rmult_eq_compat_l. +congr *%R. move: H; rewrite in_setC. rewrite /f; move /negbTE ->. -rewrite /= -addn1 size_tuple plus_INR INR_Zabs_nat. --by []. --by apply: le_IZR; apply: (Lnt_nonneg _ P). +rewrite /= -addn1 size_tuple natrD//. +rewrite natr_absz. +rewrite ger0_norm//. +rewrite -(ler_int R). +by rewrite Lnt_nonneg. Qed. Lemma E_leng_cw_le_Length : @E_leng_cw _ _ P (f (n':=n') P epsilon) <= - (IZR L_typ + 1) + epsilon * (IZR L_not_typ + 1) . + (L_typ%:~R + 1) + epsilon * (L_not_typ%:~R + 1) . Proof. rewrite /E_leng_cw /Ex /=. -under eq_bigr do rewrite mulRC. +under eq_bigr do rewrite mulrC. rewrite (rsum_split _ (`TS P n'.+1 epsilon)). -rewrite eq_sizef_Lnt eq_sizef_Lt -!(big_morph _ (morph_mulRDl _) (mul0R _)) mulRC. +rewrite eq_sizef_Lnt eq_sizef_Lt. +rewrite -!big_distrl/= mulrC. rewrite (_ : \sum_(i | i \in ~: `TS P n epsilon) - P `^ n i = 1 - \sum_(i | i \in `TS P n epsilon) P `^ n i); last first. -- by rewrite (_ : 1 = 1%mcR)// -(FDist.f1 P`^n) (rsum_split _ (`TS P n epsilon)) addRC addRK. -- apply leR_add. - + rewrite -[X in _ <= X]mulR1; apply: leR_wpmul2l => //. - * by apply: addR_ge0 => //; exact/ltRW/Lt_pos. - * rewrite (_ : 1 = 1%mcR)// -(FDist.f1 (P `^ n)); apply: leR_sumRl => // *. - by apply/RleP; rewrite Order.POrderTheory.lexx. - + apply: leR_wpmul2r => //. - * by apply addR_ge0 => //; exact (Lnt_nonneg _ P). - * by rewrite leR_subl_addr addRC -leR_subl_addr; exact: Pr_TS_1. + (P `^ n)%fdist i = 1 - \sum_(i | i \in `TS P n epsilon) (P `^ n)%fdist i); last first. +- rewrite -(FDist.f1 (P `^ n)%fdist) (rsum_split _ (`TS P n epsilon)). + by rewrite addrAC subrr add0r. +- apply: lerD => //. + + rewrite -[X in _ <= X]mulr1; apply: ler_wpM2l => //. + * by apply: addr_ge0 => //; exact/ltW/Lt_pos. + * by rewrite -(FDist.f1 (P `^ n)%fdist); apply: leR_sumRl => // *. + + apply: ler_wpM2r => //. + * by apply addr_ge0 => //; exact (Lnt_nonneg _ P). + * by rewrite lerBlDr addrC -lerBlDr; exact: Pr_TS_1. Qed. End E_Leng_Cw_Lemma. Section v_scode. +Let R := Rdefinitions.R. Variable (X : finType) (n' : nat). Let n := n'.+1. Variable P : {fdist X}. Variable epsilon : R. Hypothesis eps_pos : 0 < epsilon . -Definition epsilon':= epsilon / (3 + (3 * log (INR #|X|))). -Definition n0 := maxn (Z.abs_nat (ceil (INR 2 / (INR 1 + log (INR #|X|))))) - (maxn (Z.abs_nat (ceil (8 / epsilon))) - (Z.abs_nat (ceil (aep_sigma2 P/ epsilon' ^ 3)))). +Definition epsilon':= epsilon / (3 + (3 * log (#|X|)%:R)). +Definition n0 := maxn (`|(ceil (2 / (1 + @log R (#|X|%:R))))|%N) + (maxn (`|(ceil (8 / epsilon))|%N) + (`|(ceil (aep_sigma2 P/ epsilon' ^ 3))|%N)). Hypothesis n0_Le_n : (n0 < n)%nat. -Lemma n0_eps3 : 2 * (epsilon / (3 * (1 + log (INR #|X|)))) / INR n < epsilon / 3. +Lemma n0_eps3 : 2 * (epsilon / (3 * (1 + log (#|X|%:R)))) / n%:R < epsilon / 3. Proof. move: (fdist_supp_lg_add_1_neq_0 P) => ?. -rewrite mulRC /Rdiv -?mulRA; apply: (Rmult_lt_compat_l _ _ _ eps_pos); rewrite ?mulRA (mulRC _ 2). -apply: (Rmult_lt_reg_l 3); first exact: Rplus_lt_pos. -rewrite Rinv_mult // ?mulRA (mulRC 3 2) Rinv_r_simpl_l //. -apply: (Rmult_lt_reg_l (INR n)); first exact/ltR0n. -rewrite mulRC -mulRA (mulRC _ (INR n)) ?mulRA Rinv_r_simpl_l; last first. - by apply/eqP; rewrite INR_eq0'. -rewrite Rinv_r_simpl_l //. -apply: (Rle_lt_trans _ _ _ (proj1 (ceilP _))). -rewrite -INR_Zabs_nat. -- apply: (lt_INR _ _). - move : n0_Le_n; rewrite /n0 gtn_max. - by case/andP => /ltP. -- apply: le_IZR;apply: (Rle_trans _ (2 * / (1 + log (INR #|X|)))); last exact: (proj1 (ceilP _)). - apply: Rmult_le_pos; first exact: ltRW. - apply: Rlt_le; apply: Rinv_0_lt_compat. - apply: Rplus_lt_le_0_compat => //. - rewrite -(Log_1 2). - apply: Log_increasing_le => //. - exact: fdist_support_LB. +rewrite (mulrC 2) -!mulrA. +rewrite ltr_pM2l//. +rewrite invfM. +rewrite -mulrA. +rewrite gtr_pMr ?invr_gt0//. +rewrite !mulrA. +rewrite ltr_pdivrMr// mul1r. +rewrite mulrC . +move: n0_Le_n. +rewrite -(ltr_nat R). +apply: le_lt_trans. +rewrite /n0. +rewrite (le_trans (le_ceil _))//. +rewrite (le_trans (ler_norm _))//. +rewrite -intr_norm. +rewrite -natr_absz ler_nat. +by rewrite leq_max leqnn. Qed. -Lemma n0_eps4 : 2 * / INR n < epsilon / 4. +Lemma n0_eps4 : 2 / n%:R < epsilon / 4. Proof. move: n0_Le_n; rewrite /n0 !gtn_max; case/andP=> _; case/andP=> Hyp _. -apply: (Rmult_lt_reg_l 4); first by lra. -rewrite /Rdiv (mulRC epsilon (/ 4)) mulRA mulRA ?mulRV; last first. - by rewrite gtR_eqF //; lra. -rewrite (_ : 4 * 2 = 8) ?mul1R; last by lra. -apply: (Rmult_lt_reg_l (INR n)); first exact/ltR0n. -rewrite mulRA (mulRC _ 8) Rinv_r_simpl_l; last by apply/eqP; rewrite INR_eq0'. -apply: (Rmult_lt_reg_l ( / epsilon)); first by apply: Rinv_0_lt_compat. -rewrite mulRC (mulRC (/ epsilon) (INR n * epsilon)) Rinv_r_simpl_l; - last by apply: nesym; apply: Rlt_not_eq=>//. -apply: (Rle_lt_trans _ (IZR (ceil (8 * / epsilon))) _ (proj1 (ceilP _))). -rewrite -INR_Zabs_nat. -- by apply: lt_INR; apply/ltP. -- apply: le_IZR;apply: (Rle_trans _ (8 * / epsilon)); last by apply: (proj1 (ceilP _)). - by apply: Rle_mult_inv_pos; [lra | apply eps_pos]. +rewrite ltr_pdivrMr//. +rewrite -ltr_pdivrMl ?divr_gt0//. +rewrite -(ltr_nat R) in Hyp. +rewrite (le_lt_trans _ Hyp)//. +rewrite invfM -mulrA invrK -natrM/= mulrC. +rewrite (le_trans (le_ceil _))//. +rewrite (le_trans (ler_norm _))//. +rewrite -intr_norm. +by rewrite natr_absz. Qed. Lemma eps'_pos : 0 < epsilon'. Proof. -rewrite /epsilon' /Rdiv -(mulR0 epsilon); apply ltR_pmul2l => //; apply/invR_gt0. -apply: Rplus_lt_le_0_compat; first lra. -apply: Rmult_le_pos; first lra. -rewrite -(Log_1 2). -exact: (Log_increasing_le _ _ (fdist_support_LB P)). +rewrite /epsilon'. +rewrite divr_gt0//. +rewrite ltr_wpDr// mulr_ge0// -log1 ler_log ?posrE//. + exact: fdist_support_LB. +by rewrite (lt_le_trans _ (fdist_support_LB P)). Qed. -Lemma le_aepbound_n : aep_bound P epsilon' <= INR n. +Lemma le_aepbound_n : aep_bound P epsilon' <= n%:R. Proof. -rewrite /aep_bound . -apply: (Rle_trans _ _ _ (proj1 (ceilP _))). -rewrite -INR_Zabs_nat. - apply: ltRW; apply: lt_INR. - move: n0_Le_n. - rewrite /n0 !gtn_max. - case/andP=> _. - case/andP=> _ H2. - by apply/ltP. -apply: le_IZR; apply: (Rle_trans _ (aep_sigma2 P / epsilon' ^ 3)); last by apply: (proj1 (ceilP _)). -apply: Rmult_le_pos; first by apply: aep_sigma2_ge0. -by apply: Rlt_le; apply: Rinv_0_lt_compat; apply: (pow_lt _ _ eps'_pos). +move: n0_Le_n. +rewrite -(ltr_nat R) => /ltW; apply: le_trans. +rewrite /n0. +rewrite /aep_bound. +rewrite (le_trans (le_ceil _))//. +rewrite (le_trans (ler_norm _))//. +rewrite -intr_norm. +rewrite -natr_absz. +rewrite ler_nat. +by rewrite !leq_max leqnn !orbT. Qed. Lemma lb_entro_plus_eps : - IZR (L_typ n' P epsilon') + 1 + epsilon' * (IZR (L_not_typ X n') + 1) < - (`H P + epsilon) * INR n. + (L_typ n' P epsilon')%:~R + 1 + epsilon' * ((L_not_typ X n')%:~R + 1) < + (`H P + epsilon) * n%:R. Proof. move : (fdist_supp_lg_add_1_neq_0 P) => ?. rewrite /L_typ /L_not_typ. -apply: (Rle_lt_trans _ (INR n'.+1 * (`H P + epsilon') + 1 + 1 + - epsilon' * (log (INR #|[set: (n'.+1).-tuple X]|) + 1 + 1))). -- apply: Rplus_le_compat. - + by apply: Rplus_le_compat; [apply: ltRW; apply: (proj2 (ceilP _)) | apply: Rle_refl]. - + apply: Rmult_le_compat_l; first by apply: Rlt_le; apply: eps'_pos. - by apply: Rplus_le_compat; [apply: ltRW; apply: (proj2 (ceilP _)) | apply: Rle_refl]. +apply: (@le_lt_trans _ _ (n'.+1%:R * (`H P + epsilon') + 1 + 1 + + epsilon' * (log (#|[set: (n'.+1).-tuple X]|%:R) + 1 + 1))). +- rewrite lerD//. + + rewrite lerD//. + rewrite -lerBlDr ltW//. + rewrite [X in _ - X](_ : 1 = 1%:~R)//. + by rewrite -intrB gt_pred_ceil. + + rewrite ler_wpM2l//. + by rewrite ltW// eps'_pos. + rewrite lerD2r. + rewrite -lerBlDr ltW//. + rewrite [X in _ - X](_ : 1 = 1%:~R)//. + by rewrite -intrB gt_pred_ceil. - rewrite cardsT card_tuple log_pow_INR; last by apply: fdist_card_neq0; exact: P. - rewrite -addRA -addRA -addRA addRC addRA addRC addRA -(Rinv_r_simpl_l (INR n) (1 + 1)); last first. - by apply/eqP; rewrite INR_eq0'. - rewrite (mulRC 2 _) -{1}mulRA -mulRDr -mulRA -mulRDr (mulRC epsilon' _) -mulRA. - rewrite (mulRC _ epsilon') -mulRDr mulRC. - apply: Rmult_lt_compat_r; first by apply: lt_0_INR; apply/ltP. - rewrite -addRA -addRA; apply: Rplus_lt_compat_l. - rewrite mulRDr (addRC (epsilon' * log (INR #|X|)) _) addRC addRA -addRA - (addRC _ epsilon') -{2}(mulR1 epsilon') -mulRDr -addRA - (addRC (epsilon' * (2 / INR n)) _) addRA addRC mulRC addRC /epsilon' - -{1}(mulR1 3) -{3}(mulR1 3) -mulRDr /Rdiv {1}Rinv_mult // mulRA - -mulRA -Rinv_l_sym // mulR1. - apply: (Rle_lt_trans _ (epsilon / 4 + epsilon * / 3 + epsilon / 3)). - * apply: Rplus_le_compat. - - by apply: Rplus_le_compat; [apply: ltRW; apply: n0_eps4 | apply: Rle_refl]. - - by rewrite mulRC /Rdiv (mulRC 2 _) mulRA mulRC mulRA; apply: ltRW; apply: n0_eps3. - * rewrite /Rdiv -?mulRDr -{2}(mulR1 epsilon); apply: (Rmult_lt_compat_l _ _ _ eps_pos). + rewrite -addrA -addrA -addrA addrC addrA addrC addrA. + rewrite (_ : 1 + 1 = (1 + 1) * n%:R * n%:R^-1); last first. + by rewrite -mulrA divff ?mulr1// pnatr_eq0. + rewrite (mulrC 2 _). + rewrite -mulrA -!mulrDr. + rewrite (mulrC epsilon' _) -mulrA. + rewrite -mulrDr. + rewrite [ltRHS]mulrC. + rewrite ltr_pM2l//. + rewrite -addrA -addrA ltrD2l. + apply: (@le_lt_trans _ _ (epsilon / 4 + epsilon / 3 + epsilon / 3)); last first. + rewrite -!mulrDr gtr_pMr//. by apply: elevenOverTwelve_le_One. + rewrite addrCA -addrA. + rewrite lerD//. + by rewrite ltW// n0_eps4. + rewrite {2}/epsilon'. + rewrite mulrDl addrA lerD//; last first. + rewrite -mulrA. + rewrite (mulrC _^-1). + rewrite ltW//. + rewrite (le_lt_trans _ n0_eps3)//. + by rewrite mulrDr mulr1 -mulrA. + rewrite -/epsilon'. + rewrite /epsilon'. + rewrite (mulrCA _ epsilon). + rewrite -mulrDr ler_pM2l//. + rewrite -[X in X + _ <= _]mul1r. + rewrite -mulrDl. + rewrite -{1}(mulr1 3) -mulrDr mulrC. + rewrite invfM -mulrA. + rewrite mulVf//. + by rewrite mulr1. Qed. Lemma v_scode' : exists sc : scode_vl _ n, cancel (enc sc) (dec sc) /\ - @E_leng_cw _ _ P (enc sc) / INR n < `H P + epsilon. + @E_leng_cw _ _ P (enc sc) / n%:R < `H P + epsilon. Proof. move : (fdist_supp_lg_add_1_neq_0 P) => ?. exists (mkScode (f P epsilon') (phi n' P epsilon')). -apply: conj=> [ x |]; first by apply: (phi_f _ eps'_pos). -apply: (Rmult_lt_reg_r (INR n)); first by apply: lt_0_INR; apply/ltP. -rewrite /Rdiv -mulRA -(mulRC (INR n)) mulRV ?INR_eq0' // mulR1. -apply: (Rle_lt_trans _ (IZR (L_typ n' P epsilon') + 1 + epsilon' * (IZR (L_not_typ X n') + 1))). -- by apply: E_leng_cw_le_Length; [apply: eps'_pos | apply: le_aepbound_n]. -- by apply: lb_entro_plus_eps. +split. + move=> x/=. + by rewrite phi_f. +rewrite ltr_pdivrMr//. +rewrite (le_lt_trans (E_leng_cw_le_Length eps'_pos le_aepbound_n))//. +by apply: lb_entro_plus_eps. Qed. End v_scode. Section variable_length_source_coding. - Variables (X : finType) (P : {fdist X}). +Let R := Rdefinitions.R. Variable epsilon : R. -Hypothesis eps_pos : 0 < epsilon . +Hypothesis eps_pos : 0 < epsilon. Local Notation "'n0'" := (n0 P epsilon). Theorem v_scode_direct : exists n : nat, diff --git a/information_theory/string_entropy.v b/information_theory/string_entropy.v index b73daa92..cd3a84f5 100644 --- a/information_theory/string_entropy.v +++ b/information_theory/string_entropy.v @@ -1,10 +1,10 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum. -Require Import Reals. -From mathcomp Require Import Rstruct classical_sets. -Require Import ssrR realType_ext Reals_ext ssr_ext ssralg_ext logb. -Require Import fdist entropy convex ln_facts jensen num_occ. +From mathcomp Require Import classical_sets reals exp itv. +From mathcomp Require convex. +Require Import ssr_ext ssralg_ext realType_ext realType_ln. +Require Import fdist entropy convex jensen num_occ. (******************************************************************************) (* String entropy *) @@ -23,56 +23,89 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. Local Open Scope num_occ_scope. Local Open Scope entropy_scope. -Local Coercion INR : nat >-> R. +Local Open Scope ring_scope. -Import Num.Theory. +Import Order.POrderTheory GRing.Theory Num.Theory. -Definition simplR := (add0R, addR0, subR0, mul0R, mulR0, mul1R, mulR1). +(* coercions to R : realType do not seem to work *) +Local Notation "x /:R y" := (x%:R / y%:R) (at level 40, left associativity). -Local Hint Resolve Rle_refl : core. -Local Hint Resolve leR0n : core. +(* TODO: move to convex ? *) +Section log_concave. +Import (canonicals) analysis.convex. +Variable R : realType. -Section seq_nat_fdist. +Definition i01_of_prob : {prob R} -> {i01 R}. +case => p H. exists p. +abstract (by case/andP: H => H0 H1; apply/andP; split). +Defined. +Definition prob_of_i01 : {i01 R} -> {prob R}. +case => p H. exists p. +abstract (by case/andP: H => H0 H1; apply/andP; split). +Defined. -Variables (A : finType) (f : A -> nat). -Variable total : nat. -Hypothesis sum_f_total : (\sum_(a in A) f a)%nat = total. -Hypothesis total_gt0 : total != O. +Lemma i01_of_probK : cancel i01_of_prob prob_of_i01. +Proof. case => p H. by apply/val_inj. Qed. +Lemma prob_of_i01K : cancel prob_of_i01 i01_of_prob. +Proof. case => p H. by apply/val_inj. Qed. -Let f_div_total := [ffun a : A => f a / total]. +Lemma mc_convE (a b : R^o) (p : {prob R}) : + conv p a b = mathcomp.analysis.convex.conv (i01_of_prob p) b a :> R^o. +Proof. +rewrite [LHS]addrC. +congr (_ .~ *: _ + _ *: _); by case: p. +Qed. -Lemma f_div_total_pos c : (0 <= f_div_total c)%mcR. +Lemma log_concave : concave_function_in Rpos_interval (log : R^o -> R^o). Proof. -rewrite ffunE; apply/RleP/mulR_ge0 => //. -apply /Rlt_le /invR_gt0 /ltR0n. -by rewrite lt0n. +move=> /= x y p Hx Hy. +rewrite /concave_function_at /convex_function_at. +rewrite !inE in Hx Hy. +have Hln := concave_ln (i01_of_prob p) Hy Hx. +rewrite -!mc_convE in Hln. +rewrite conv_leoppD leoppP /= /log /Log /=. +rewrite [in X in X <= _]avgRE !mulrA -mulrDl -avgRE. +by rewrite ler_wpM2r // invr_ge0 ln2_ge0. Qed. +End log_concave. + +Section seq_nat_fdist. +Variables (R : realType) (A : finType) (f : A -> nat). +(* +Let N2R x : R := x%:R. +#[reversible=yes] Local Coercion N2R' := N2R. +*) +Variable total : nat. +Hypothesis sum_f_total : (\sum_(a in A) f a)%N = total. +Hypothesis total_gt0 : total != O. + +Let f_div_total := [ffun a : A => f a /:R total : R]. -Lemma f_div_total_1 : \sum_(a in A) [ffun a : A => f a / total] a = 1. +Lemma f_div_total_pos c : 0 <= f_div_total c. +Proof. by rewrite ffunE mulr_ge0 // invr_ge0 ler0n. Qed. + +Lemma f_div_total_1 : \sum_(a in A) f_div_total a = 1. Proof. under eq_bigr do rewrite ffunE /=. -rewrite /f_div_total -big_distrl -big_morph_natRD. -by rewrite sum_f_total /= mulRV // INR_eq0'. +rewrite /f_div_total -big_distrl /= -natr_sum. +by rewrite sum_f_total divrr // unitfE pnatr_eq0. Qed. Definition seq_nat_fdist := FDist.make f_div_total_pos f_div_total_1. - End seq_nat_fdist. Section string. - -Variable A : finType. +Variables (R : realType) (A : finType). Section entropy. Variable S : seq A. Hypothesis S_nonempty : size S != O. -Definition pchar c := N(c|S) / size S. +Definition pchar c : R := N(c|S) /:R size S. -Definition num_occ_dist := seq_nat_fdist (sum_num_occ_size S) S_nonempty. +Definition num_occ_dist := seq_nat_fdist R (sum_num_occ_size S) S_nonempty. Definition Hs0 := `H num_occ_dist. End entropy. @@ -86,42 +119,44 @@ Definition Hs (s : seq A) := N(a|s) / size s * log (size s / N(a|s)). *) -Definition nHs (s : seq A) := +Definition nHs (s : seq A) : R := \sum_(a in A) - if N(a|s) == 0%nat then 0 else - N(a|s) * log (size s / N(a|s)). + if N(a|s) == 0%N then 0 else + N(a|s)%:R * log (size s /:R N(a|s)). Lemma szHs_is_nHs s (H : size s != O) : - size s * `H (@num_occ_dist s H) = nHs s. + (size s)%:R * `H (@num_occ_dist s H) = nHs s :> R. Proof. -rewrite /entropy /nHs /num_occ_dist /= -mulRN1 big_distrl big_distrr /=. +rewrite /entropy /nHs /num_occ_dist /=. +rewrite (big_morph _ (id1:=0) (@opprD _)) ?oppr0 // big_distrr /=. apply eq_bigr => a _ /=; rewrite ffunE. -case: ifPn => [/eqP -> | Hnum]; first by rewrite !mulRA !simplR. -rewrite {1}/Rdiv (mulRC N(a | s)) 3![in LHS]mulRA mulRV ?INR_eq0' // ?mul1R. -by rewrite -mulRA mulRN1 -logV ?Rinv_div//; apply divR_gt0; rewrite ltR0n lt0n. +case: ifPn => [/eqP -> | Hnum]; first by rewrite !mul0r oppr0 mulr0. +rewrite (mulrC N(a | s)%:R) mulrN 3![in LHS]mulrA mulrV ?unitfE ?pnatr_eq0 //. +rewrite mul1r -mulrA -mulrN -logV 1?mulrC ?invf_div //. +by apply divr_gt0; rewrite ltr0n lt0n. Qed. -Definition mulnRdep (x : nat) (y : x != O -> R) : R. +Definition mulnrdep (x : nat) (y : x != O -> R) : R. case/boolP: (x == O) => Hx. + exact 0. -+ exact (x * y Hx). ++ exact (x%:R * y Hx). Defined. -Arguments mulnRdep x y : clear implicits. +Arguments mulnrdep x y : clear implicits. -Lemma mulnRdep_0 y : mulnRdep 0 y = 0. -Proof. rewrite /mulnRdep /=. by destruct boolP. Qed. +Lemma mulnrdep_0 y : mulnrdep 0 y = 0. +Proof. by rewrite /mulnrdep /=; destruct boolP. Qed. -Lemma mulnRdep_nz x y (Hx : x != O) : mulnRdep x y = x * y Hx. +Lemma mulnrdep_nz x y (Hx : x != O) : mulnrdep x y = x%:R * y Hx. Proof. -rewrite /mulnRdep /=. +rewrite /mulnrdep /=. destruct boolP. by exfalso; rewrite i in Hx. -do 2!f_equal; apply eq_irrelevance. +by do 2!f_equal; apply eq_irrelevance. Qed. -Lemma szHs_is_nHs_full s : mulnRdep (size s) (fun H => Hs0 H) = nHs s. +Lemma szHs_is_nHs_full s : mulnrdep (size s) (fun H => Hs0 H) = nHs s. Proof. -rewrite /mulnRdep; destruct boolP; last by apply szHs_is_nHs. +rewrite /mulnrdep; destruct boolP; last by apply szHs_is_nHs. rewrite /nHs (eq_bigr (fun a => 0)); first by rewrite big1. move=> a _; suff -> : N(a|s) == O by []. by rewrite /num_occ -leqn0 -(eqP i) count_size. @@ -139,98 +174,95 @@ Proof. rewrite (eq_bigr _ (fun i _ => szHs_is_nHs i)).*) rewrite exchange_big /nHs /=. (* (2) Move to per-character inequalities *) -apply leR_sumR => a _. +apply ler_sum => a _. (* Remove strings containing no occurrences *) rewrite (bigID (fun s => N(a|s) == O)) /=. rewrite big1; last by move=> i ->. -rewrite num_occ_flatten add0R. +rewrite num_occ_flatten add0r. rewrite [in X in _ <= X](bigID (fun s => N(a|s) == O)). rewrite [in X in _ <= X]big1 //= ?add0n; last by move=> i /eqP. rewrite (eq_bigr - (fun i => N(a|i) * log (size i / N(a|i)))); + (fun i => N(a|i)%:R * log (size i /:R N(a|i)))); last by move=> i /negbTE ->. rewrite -big_filter -[in X in _ <= X]big_filter. (* ss' contains only strings with ocurrences *) set ss' := [seq s <- ss | N(a|s) != O]. -case/boolP: (ss' == [::]) => Hss'. - by rewrite (eqP Hss') !big_nil eqxx. -have Hnum s : s \in ss' -> (N(a|s) > 0)%nat. +have [->|Hss'] := eqVneq ss' [::]. + by rewrite !big_nil eqxx. +have Hnum s : s \in ss' -> (N(a|s) > 0)%N. by rewrite /ss' mem_filter lt0n => /andP [->]. -have Hnum': 0 < N(a|flatten ss'). - apply /ltR0n; destruct ss' => //=. +have Hnum' : (0:R) < N(a|flatten ss')%:R. + rewrite ltr0n; destruct ss' => //=. rewrite /num_occ count_cat ltn_addr //. by rewrite Hnum // in_cons eqxx. -have Hsz: 0 < size (flatten ss'). - apply (ltR_leR_trans Hnum'). - by apply /le_INR /leP /count_size. -apply (@leR_trans ((\sum_(i <- ss') N(a|i))%:R * - log (size (flatten ss') / - (\sum_(i <- ss') N(a|i))%nat))); +have Hsz: (0:R) < (size (flatten ss'))%:R. + apply (lt_le_trans Hnum'). + by rewrite ler_nat; apply /count_size. +apply (@le_trans _ _ ((\sum_(i <- ss') N(a|i))%:R * + log (size (flatten ss') /:R + (\sum_(i <- ss') N(a | i))%N))); last first. (* Not mentioned in the book: one has to compensate for the discarding of strings containing no occurences. Works thanks to monotonicity of log. *) (* (3) Compensate for removed strings *) case: ifP => Hsum. - by rewrite (eqP Hsum) mul0R. - apply leR_wpmul2l => //. + by rewrite (eqP Hsum) mul0r. + apply ler_wpM2l => //. apply Log_increasing_le => //. - apply/mulR_gt0 => //. - apply/invR_gt0/ltR0n. - by rewrite lt0n Hsum. - apply leR_wpmul2r. - apply /Rlt_le /invR_gt0 /ltR0n. - by rewrite lt0n Hsum. - apply /le_INR /leP. - rewrite !size_flatten !sumn_big_addn. + apply/mulr_gt0 => //. + by rewrite invr_gt0 ltr0n lt0n Hsum. + apply ler_wpM2r. + by rewrite invr_ge0 ler0n. + rewrite ler_nat !size_flatten !sumn_big_addn. rewrite !big_map big_filter. - rewrite [in X in (_ <= X)%nat] - (bigID (fun s => N(a|s) == O)) /=. + rewrite [leqRHS](bigID (fun s => N(a|s) == O)) /=. by apply leq_addl. (* (4) Prepare to use jensen_dist_concave *) have Htotal := esym (num_occ_flatten a ss'). rewrite big_tnth in Htotal. have Hnum2 : N(a|flatten ss') != O. - rewrite -lt0n; exact/ltR0n. -set d := seq_nat_fdist Htotal Hnum2. + by rewrite -lt0n -(ltr0n R). +set d := seq_nat_fdist R Htotal Hnum2. set r := fun i => - (size (tnth (in_tuple ss') i)) - / N(a|tnth (in_tuple ss') i). + size (tnth (in_tuple ss') i) + /:R N(a|tnth (in_tuple ss') i) : R. +(* Need convex for Rpos_interval *) have Hr: forall i, r i \in Rpos_interval. rewrite /r /= => i. - rewrite classical_sets.in_setE; apply Rlt_mult_inv_pos; apply /ltR0n. + rewrite classical_sets.in_setE; apply/divr_gt0; rewrite ltr0n. apply (@leq_trans N(a|tnth (in_tuple ss') i)). by rewrite Hnum // mem_tnth. by apply count_size. by apply /Hnum /mem_tnth. (* (5) Apply Jensen *) -move: (jensen_dist_concave log_concave d Hr). +move: (jensen_dist_concave (@log_concave R) d Hr). rewrite /d /r /=. under eq_bigr do rewrite ffunE /=. under [X in _ <= log X -> _]eq_bigr do rewrite ffunE /=. rewrite -(big_tnth _ _ _ xpredT - (fun s => (N(a|s) / N(a|flatten ss')) * - log ((size s) / N(a|s)))). + (fun s => N(a|s) /:R N(a|flatten ss') * + log (size s /:R N(a|s)))). rewrite -(big_tnth _ _ _ xpredT - (fun s => (N(a|s) / N(a|flatten ss')) * - (size s / N(a|s)))). + (fun s => (N(a|s) /:R N(a|flatten ss')) * + (size s /:R N(a|s)))). (* (6) Transform the statement to match the goal *) -move/(@leR_wpmul2r N(a|flatten ss') _ _ (leR0n _)). +move/(@ler_wpM2r R N(a|flatten ss')%:R (ler0n _ _)). rewrite !big_distrl /=. rewrite (eq_bigr - (fun i => N(a|i) * log (size i / N(a|i)))); + (fun i => N(a|i)%:R * log (size i /:R N(a|i)))); last first. - by move=> i _; rewrite mulRAC -!mulRA (mulRA (/ _)) mulVR ?mul1R // gtR_eqF. -move/leR_trans; apply. (* LHS matches *) -rewrite mulRC -num_occ_flatten big_filter. + move=> i _; rewrite mulrAC -!mulrA (mulrA _^-1) mulVr ?mul1r //. + by rewrite unitfE pnatr_eq0 -lt0n -(ltr0n R). +move/le_trans; apply. (* LHS matches *) +rewrite mulrC -num_occ_flatten big_filter. rewrite (eq_bigr - (fun i => size i / N(a|flatten ss'))); + (fun i => size i /:R N(a|flatten ss'))); last first. - move=> i Hi; rewrite mulRCA {1}/Rdiv mulRAC. - by rewrite mulRV ?mul1R // INR_eq0'. -rewrite -big_filter -/ss' -big_distrl. -rewrite -big_morph_natRD /=. + move=> i Hi; rewrite mulrCA mulrAC. + by rewrite mulrV ?mul1r // unitfE pnatr_eq0. +rewrite -big_filter -/ss' -big_distrl /= -natr_sum. by rewrite size_flatten sumn_big_addn big_map. Qed. @@ -241,8 +273,8 @@ End string. (* tentative definition *) Section higher_order_empirical_entropy. -Variables (A : finType) (l : seq A). -Hypothesis A0 : (O < #|A|)%nat. +Variables (R : realType) (A : finType) (l : seq A). +Hypothesis A0 : (O < #|A|)%N. Let n := size l. Let def : A. Proof. move/card_gt0P : A0 => /sigW[def _]; exact def. Defined. Hypothesis l0 : n != O. @@ -256,17 +288,17 @@ Fixpoint takes {k : nat} (w : k.-tuple A) (s : seq A) {struct s} : seq A := [::]. (* sample ref: https://www.dcc.uchile.cl/~gnavarro/ps/jea08.2.pdf *) -Definition hoH (k : nat) := / n%:R * +Definition hoH (k : nat) := n%:R^-1 * \sum_(w in {: k.-tuple A}) #|takes w l|%:R * match Bool.bool_dec (size w != O) true with - | left H => `H (num_occ_dist H) + | left H => `H (num_occ_dist R H) | _ => 0 end. Lemma hoH_decr (k : nat) : hoH k.+1 <= hoH k. Proof. -rewrite /hoH; apply/RleP; rewrite ler_pM2l//; last first. - by rewrite INRE RinvE invr_gt0// ltr0n lt0n. +rewrite /hoH; rewrite ler_pM2l//; last first. + by rewrite invr_gt0 ltr0n lt0n. (* TODO *) Abort. diff --git a/information_theory/success_decode_bound.v b/information_theory/success_decode_bound.v index 58bf23a3..4cefea33 100644 --- a/information_theory/success_decode_bound.v +++ b/information_theory/success_decode_bound.v @@ -1,10 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext ssr_ext ssralg_ext logb fdist entropy. -Require Import ln_facts num_occ types jtypes divergence conditional_divergence. +From mathcomp Require Import Rstruct reals exp. +Require Import ssr_ext ssralg_ext realType_ext realType_ln fdist entropy. +Require Import num_occ types jtypes divergence conditional_divergence. Require Import entropy channel_code channel. (******************************************************************************) @@ -30,7 +29,7 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. +Local Open Scope ring_scope. Local Open Scope channel_code_scope. Local Open Scope channel_scope. Local Open Scope entropy_scope. @@ -40,10 +39,9 @@ Local Open Scope types_scope. Local Open Scope divergence_scope. Local Open Scope set_scope. -Import Order.POrderTheory Num.Theory. +Import Order.POrderTheory Num.Theory GRing.Theory. Section typed_success_decomp_sect. - Variables A B M : finType. Variable W : `Ch*(A, B). Hypothesis Mnot0 : (0 < #|M|)%nat. @@ -53,7 +51,7 @@ Let n := n'.+1. Variable P : P_ n ( A ). Definition success_factor (tc : typed_code B M P) (V : P_ n (A , B)) := - exp2 (- n%:R * `H(V | P)) / #|M|%:R * + 2 `^ (- n%:R * `H(V | P)) / #|M|%:R * \sum_ (m : M) #| (V.-shell (tuple_of_row (enc tc m ))) :&: (@tuple_of_row B n @: ((dec tc) @^-1: [set Some m])) |%:R. @@ -61,30 +59,36 @@ Let Anot0 : (0 < #|A|)%nat. Proof. by case: W. Qed. Let Bnot0 : (0 < #|B|)%nat. Proof. -case/card_gt0P : Anot0 => a _; exact (fdist_card_neq0 (W a)). +by case/card_gt0P : Anot0 => a _; exact (fdist_card_neq0 (W a)). Qed. Lemma typed_success (tc : typed_code B M P) : scha(W, tc) = \sum_ (V | V \in \nu^{B}(P)) exp_cdiv P V W * success_factor tc V. Proof. -rewrite schaE // div1R. +rewrite schaE // mul1r. symmetry. -transitivity (/ #|M|%:R * \sum_(m : M) \sum_(V | V \in \nu^{B}(P)) +transitivity (#|M|%:R^-1 * \sum_(m : M) \sum_(V | V \in \nu^{B}(P)) exp_cdiv P V W * #| V.-shell (tuple_of_row (enc tc m)) :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m])) |%:R * - exp2 (- n%:R * `H(V | P))). + 2 `^ (- n%:R * `H(V | P))). rewrite exchange_big /= big_distrr /=. apply eq_bigr => V _. - rewrite /success_factor !mulRA -(mulRC (/ #|M|%:R)) -!mulRA; f_equal. - symmetry; rewrite -big_distrl /= -big_distrr /= -mulRA; f_equal. - by rewrite mulRC. + rewrite /success_factor !mulrA -(mulrC (#|M|%:R)^-1) -!mulrA; f_equal. + symmetry; rewrite -big_distrl /= -big_distrr /= -mulrA; f_equal. + by rewrite mulrC. f_equal. apply eq_bigr=> m _. rewrite (reindex_onto (@row_of_tuple B n) (@tuple_of_row B n)); last first. move=> i Hi; by rewrite tuple_of_rowK. -rewrite (sum_tuples_ctypes (typed_prop tc m)) //. +rewrite /=. +rewrite (sum_tuples_ctypes (typed_prop tc m))//. apply eq_bigr=> V HV. -rewrite -mulRA mulRC -mulRA -iter_addR -big_const. +rewrite -mulrA mulrC -mulrA. +(* TODO: dirty *) +rewrite GRing.mulr_natl. +rewrite -[LHS]addr0. +rewrite -iter_addr. +rewrite -big_const. apply eq_big => tb. - rewrite inE row_of_tupleK eqxx andbT. f_equal. @@ -96,7 +100,8 @@ apply eq_big => tb. by rewrite !inE. - rewrite in_set. move=> /andP [Htb _]. - rewrite mulRC -(@dmc_exp_cdiv_cond_entropy _ _ _ _ _ _ _ (row_of_tuple tb) (typed_prop tc m) HV) //. + rewrite mulrC. + rewrite -(@dmc_exp_cdiv_cond_entropy _ _ _ _ _ _ _ (row_of_tuple tb) (typed_prop tc m) HV)//. by rewrite row_of_tupleK. Qed. @@ -110,33 +115,40 @@ Let n := n'.+1. Variable V : P_ n ( A , B ). Variable P : P_ n ( A ). +Local Open Scope reals_ext_scope. + Definition success_factor_bound := - exp2(- n%:R * +| log #|M|%:R / n%:R - `I(P, V) |). + 2 `^ (- n%:R * +| log #|M|%:R / n%:R - `I(P, V) |). Variable tc : typed_code B M P. Hypothesis Vctyp : V \in \nu^{B}(P). Lemma success_factor_bound_part1 : success_factor tc V <= 1. Proof. -apply/RleP; rewrite -(@ler_pM2l _ #|M|%:R)//; last by rewrite ltr0n. -apply/RleP. -rewrite /success_factor /Rdiv -(mulRC (/ #|M|%:R)%coqR) -!RmultE 2!mulRA. -rewrite INRE mulRV; last first. - by rewrite -INRE INR_eq0' -?lt0n. -rewrite mul1R -INRE. -rewrite -iter_addR -big_const /=. +rewrite -(@ler_pM2l _ #|M|%:R)//; last by rewrite ltr0n. +rewrite /success_factor -(mulrC (#|M|%:R)^-1) 2!mulrA. +rewrite mulfV; last first. + by rewrite pnatr_eq0 gt_eqF. +rewrite mul1r. +(* TODO: dirty *) +rewrite [leRHS]GRing.mulr_natl. +rewrite -[leRHS]addr0. +rewrite -iter_addr. +rewrite -big_const /=. rewrite (_ : \sum_(m | m \in M ) 1 = \sum_(m : M) 1); last exact/eq_bigl. rewrite big_distrr /=. -apply: leR_sumR => m _. -rewrite mulNR exp2_Ropp. -rewrite mulRC leR_pdivr_mulr // ?mul1R. -apply/(@leR_trans #| V.-shell (tuple_of_row (enc tc m)) |%:R); last first. +apply: ler_sum => m _. +rewrite mulNr. +rewrite exp.powRN. +rewrite mulrC ler_pdivrMr // ?mul1r ?exp.powR_gt0//. +apply/(@le_trans _ _ #| V.-shell (tuple_of_row (enc tc m)) |%:R); last first. apply card_shelled_tuples => //. exact/typed_prop. case: (JType.c V) => _ Anot0. case/card_gt0P : (Anot0) => a _. exact: (fdist_card_neq0 (V a)). -apply/le_INR/leP/subset_leq_card/setIidPl/setP => tb. +rewrite ler_nat. +apply/subset_leq_card/setIidPl/setP => tb. by rewrite in_set in_set andbC andbA andbb. Qed. @@ -183,18 +195,22 @@ case/boolP : (tb \in cover partition_pre_image) => Hcase. Qed. Lemma success_factor_bound_part2 : - success_factor tc V <= exp2(n%:R * `I(P, V)) / #|M|%:R. + success_factor tc V <= 2 `^ (n%:R * `I(P, V)) / #|M|%:R. Proof. -rewrite /success_factor -mulRA (mulRC (/ #|M|%:R)) !mulRA. -apply leR_wpmul2r; first exact/invR_ge0/ltR0n. -rewrite /mutual_info_chan -addR_opp addRC addRA. +rewrite /success_factor -mulrA (mulrC (#|M|%:R)^-1) !mulrA. +apply ler_wpM2r. + by rewrite invr_ge0//. +rewrite /mutual_info_chan addrC addrA. rewrite (_ : - `H(type.d P , V) + `H P = - `H( V | P )); last first. rewrite /cond_entropy_chan. - by rewrite oppRD oppRK. -rewrite mulRDr mulRN -mulNR /exp2 ExpD; apply leR_wpmul2l => //. -rewrite -big_morph_natRD; apply (@leR_trans #| T_{`tO( V )} |%:R); last first. + by rewrite opprB addrC. +rewrite [in leRHS]mulrDr mulrN -mulNr. +rewrite powRD; last by rewrite pnatr_eq0 implybT. +apply ler_wpM2l => //. + by rewrite exp.powR_ge0. +rewrite -natr_sum; apply: (@le_trans _ _ #| T_{`tO( V )} |%:R); last first. by rewrite -output_type_out_entropy //; exact: card_typed_tuples. -apply/le_INR/leP. +rewrite ler_nat. apply: (@leq_trans (\sum_m #| T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m]))|)). - apply leq_sum => m _. by apply subset_leq_card, setSI, shell_subset_output_type. @@ -226,25 +242,38 @@ apply: (@leq_trans (\sum_m #| T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^- by rewrite in_set => /andP [H _]. Qed. -Lemma success_factor_ub : - success_factor tc V <= success_factor_bound. +Lemma success_factor_ub : success_factor tc V <= success_factor_bound. Proof. rewrite /success_factor_bound. -apply Rmax_case. -- rewrite mulR0 exp2_0; by apply success_factor_bound_part1. -- apply (@leR_trans (exp2 (n%:R * `I(P, V)) / #|M|%:R)); last first. - + apply/Req_le/esym. - rewrite mulRDr mulRC. - rewrite Rmult_opp_opp -mulRA mulRN mulVR ?INR_eq0' //. - rewrite mulRN mulR1 /exp2 ExpD mulRC /Rdiv; f_equal. - rewrite Exp_Ropp LogK //; exact/ltR0n. +have [H|H] := Order.TotalTheory.leP 0 (log #|M|%:R / n%:R - (`I(P, V))). +- apply (@le_trans _ _ (2 `^ (n%:R * `I(P, V)) / #|M|%:R)); last first. + + apply/eqW/esym. + rewrite mulrDr mulrC. + rewrite mulrNN -mulrA mulrN mulVf ?pnatr_eq0//. + rewrite mulrN mulr1 powRD//; last by rewrite pnatr_eq0 implybT. + rewrite mulrC; f_equal. + rewrite exp.powRN. + by rewrite logK// ltr0n. + exact/success_factor_bound_part2. +- by rewrite mulr0 powRr0; exact: success_factor_bound_part1. Qed. End typed_success_factor_bound_sect. -Section typed_success_bound_sect. +(* TODO: move *) +Section rExtrema. +Variables (R : realType) (I : finType) (i0 : I) (F : I -> R). + +Lemma arg_rmax2 : forall j, (F j <= F [arg max_(i > i0) F i]%O)%O. +Proof. +move=> j; case: (@Order.TotalTheory.arg_maxP _ _ I i0 xpredT F isT) => i _. +exact. +Qed. + +End rExtrema. +Section typed_success_bound_sect. +Let R := Rdefinitions.R. Variables A B M : finType. Variable W : `Ch*(A, B). Hypothesis Mnot0 : (0 < #|M|)%nat. @@ -266,35 +295,33 @@ Qed. Hypothesis HV0 : V0 \in \nu^{B}(P). -Let exp_cdiv_bound := fun V => exp_cdiv P V W * success_factor_bound M V P. +Let exp_cdiv_bound := fun V => exp_cdiv P V W * success_factor_bound M V P : R. Let Vmax := [arg max_(V > V0) exp_cdiv_bound V]%O. Lemma typed_success_bound : - scha(W, tc) <= n.+1%:R ^ (#|A| * #|B|) * exp_cdiv_bound Vmax. + scha(W, tc) <= n.+1%:R ^+ (#|A| * #|B|) * exp_cdiv_bound Vmax. Proof. rewrite (typed_success W Mnot0 tc). -apply (@leR_trans ( \sum_(V|V \in \nu^{B}(P)) exp_cdiv P V W * - exp2 (- n%:R * +| log #|M|%:R * / n%:R - `I(P, V) |))). - apply: leR_sumR => V Vnu. - rewrite -mulRA; apply leR_wpmul2l. - by rewrite /exp_cdiv; case : ifP. - by rewrite /success_factor mulRA; exact: success_factor_ub. -apply (@leR_trans (\sum_(V | V \in \nu^{B}(P)) exp_cdiv P Vmax W * - exp2 (- n%:R * +| log #|M|%:R * / n%:R - `I(P, Vmax)|))). - apply leR_sumR => V HV. - by move/RleP: (@arg_rmax2 (P_ n (A, B)) V0 +apply (@le_trans _ _ ( \sum_(V|V \in \nu^{B}(P)) exp_cdiv P V W * + 2 `^ (- n%:R * +| log #|M|%:R * n%:R^-1 - `I(P, V) |))). + apply: ler_sum => V Vnu. + rewrite -mulrA ler_wpM2l ?exp_cdiv_ge0//. + by rewrite /success_factor mulrA; exact: success_factor_ub. +apply (@le_trans _ _ (\sum_(V | V \in \nu^{B}(P)) exp_cdiv P Vmax W * + 2 `^ (- n%:R * +| log #|M|%:R * n%:R^-1 - `I(P, Vmax)|))). + apply ler_sum => V HV. + by move: (@arg_rmax2 _ (P_ n (A, B)) V0 (fun V => exp_cdiv P V W * success_factor_bound M V P) V). -rewrite big_const iter_addR /success_factor_bound; apply leR_wpmul2r. -- apply mulR_ge0; last exact/exp2_ge0. - by rewrite /exp_cdiv; case: ifP. -- by rewrite natRexp; exact/le_INR/leP/card_nu. +rewrite big_const iter_addr /success_factor_bound addr0. +rewrite -mulr_natr mulrC ler_wpM2r//. +- by rewrite mulr_ge0 ?powR_ge0 ?exp_cdiv_ge0. +- by rewrite -natrX ler_nat card_nu. Qed. End typed_success_bound_sect. Section success_bound_sect. - Variables A B M : finType. Variable W : `Ch*(A, B). Hypothesis Mnot0 : (0 < #|M|)%nat. @@ -314,32 +341,34 @@ Local Open Scope num_occ_scope. Lemma success_bound : let Pmax := [arg max_(P > P0) scha(W, P.-typed_code c)]%O in - scha(W, c) <= n.+1%:R ^ #|A| * scha(W, Pmax.-typed_code c). + scha(W, c) <= n.+1%:R ^+ #|A| * scha(W, Pmax.-typed_code c). Proof. -move=> Pmax. -apply (@leR_trans (#| P_ n ( A ) |%:R * scha W (Pmax.-typed_code c))); last first. - apply leR_wpmul2r; first exact/RleP/scha_pos. - rewrite natRexp; exact/le_INR/leP/(type_counting A n). -apply (@leR_trans (\sum_(P : P_ n ( A )) scha W (P.-typed_code c))); last first. +red. +set Pmax := [arg max_(P > P0) scha( W, P .-typed_code c)]%O. +apply (@le_trans _ _ (#| P_ n ( A ) |%:R * scha W (Pmax.-typed_code c))); last first. + apply ler_wpM2r; first exact/scha_pos. + by rewrite -natrX ler_nat; exact/(type_counting A n). +apply (@le_trans _ _ (\sum_(P : P_ n ( A )) scha W (P.-typed_code c))); last first. rewrite (_ : #| P_ n ( A ) |%:R * scha W (Pmax.-typed_code c) = \sum_(P : P_ n ( A )) scha W (Pmax.-typed_code c)); last first. - by rewrite big_const iter_addR. - apply leR_sumR => P _. - by move/RleP : (arg_rmax2 P0 (fun P1 : P_ n (A) => scha(W, P1.-typed_code c)) P). + by rewrite big_const iter_addr addr0 mulr_natl. + apply ler_sum => P _. + by move : (arg_rmax2 P0 (fun P1 : P_ n (A) => scha(W, P1.-typed_code c)) P). rewrite schaE // -(sum_messages_types c). -rewrite div1R (big_morph _ (morph_mulRDr _) (mulR0 _)). -apply leR_sumR => P _. -rewrite mulRC leR_pdivr_mulr; last exact/ltR0n. -rewrite schaE // div1R -mulRA mulRCA mulVR ?INR_eq0' -?lt0n // mulR1. -apply/(@leR_trans (\sum_(m | m \in enc_pre_img c P) +rewrite mul1r. +rewrite big_distrr/=. +apply: ler_sum => P _. +rewrite mulrC ler_pdivrMr ?ltr0n//. +rewrite schaE // mul1r -mulrA mulrCA mulVf ?pnatr_eq0 ?gt_eqF//. +apply/(@le_trans _ _ (\sum_(m | m \in enc_pre_img c P) \sum_(y | (dec (P.-typed_code c)) y == Some m) (W ``(|(enc (P.-typed_code c)) m)) y)). - apply: leR_sumR => m Hm. - apply/Req_le/eq_big => tb // _. + apply: ler_sum => m Hm. + apply/eqW/eq_big => tb // _. rewrite inE in Hm. by rewrite /tcode /= ffunE Hm. -- apply leR_sumRl => //= i ?; [| exact/RleP/sumr_ge0]. - by apply/RleP; rewrite lexx. +- rewrite mulr1 big_mkcond; apply: ler_sum => //= i _. + by case: ifPn => // _; exact: sumr_ge0. Qed. End success_bound_sect. diff --git a/information_theory/typ_seq.v b/information_theory/typ_seq.v index baeb8bdb..21c28e14 100644 --- a/information_theory/typ_seq.v +++ b/information_theory/typ_seq.v @@ -1,10 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. -Require Import Reals Lra. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext realType_ext logb. -Require Import fdist proba entropy aep. +From mathcomp Require Import all_ssreflect ssralg ssrnum matrix lra. +From mathcomp Require Import reals exp. +Require Import ssr_ext realType_ext realType_ln fdist proba entropy aep. (******************************************************************************) (* Typical Sequences *) @@ -35,19 +33,20 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. Local Open Scope fdist_scope. Local Open Scope proba_scope. Local Open Scope entropy_scope. +Local Open Scope ring_scope. Import Order.TTheory GRing.Theory Num.Theory. Section typical_sequence_definition. - -Variables (A : finType) (P : {fdist A}) (n : nat) (epsilon : R). +Context {R : realType}. +Variables (A : finType) (P : R.-fdist A) (n : nat) (epsilon : R). Definition typ_seq (t : 'rV[A]_n) := - (exp2 (- n%:R * (`H P + epsilon)) <= P `^ n t <= exp2 (- n%:R * (`H P - epsilon)))%mcR. + 2 `^ (- n%:R * (`H P + epsilon)) <= (P `^ n)%fdist t <= + 2 `^ (- n%:R * (`H P - epsilon)). Definition set_typ_seq := [set ta | typ_seq ta]. @@ -57,166 +56,150 @@ Notation "'`TS'" := (set_typ_seq) : typ_seq_scope. Local Open Scope typ_seq_scope. -Lemma set_typ_seq_incl (A : finType) (P : {fdist A}) n epsilon : 0 <= epsilon -> forall r, 1 <= r -> - `TS P n (epsilon / 3) \subset `TS P n epsilon. +Lemma set_typ_seq_incl {R : realType} (A : finType) (P : R.-fdist A) n epsilon : + 0 <= epsilon -> `TS P n (epsilon / 3) \subset `TS P n epsilon. Proof. -move=> e0 r r1. +move=> e0. apply/subsetP => /= x. -rewrite !inE /typ_seq => /andP[/RleP H2 /RleP H3] [:Htmp]. -apply/andP; split; apply/RleP. -- apply/(leR_trans _ H2)/Exp_le_increasing => //. - rewrite !mulNR leR_oppr oppRK; apply leR_wpmul2l; first exact/leR0n. - apply/leR_add2l. - abstract: Htmp. - rewrite leR_pdivr_mulr; [apply leR_pmulr => //|]; lra. -- apply/(leR_trans H3)/Exp_le_increasing => //. - rewrite !mulNR leR_oppr oppRK; apply leR_wpmul2l; first exact/leR0n. - apply leR_add2l; rewrite leR_oppr oppRK; exact Htmp. +rewrite !inE /typ_seq => /andP[H2 H3] [:e3e]. +apply/andP; split. +- apply/(le_trans _ H2). + rewrite ler_powR ?ler1n// !mulNr lerNr opprK; apply ler_wpM2l => //. + rewrite lerD2l//. + abstract: e3e. + by rewrite ler_pdivrMr// ler_peMr//; lra. +- apply/(le_trans H3); rewrite ler_powR// ?ler1n//. + rewrite !mulNr lerNr opprK; apply ler_wpM2l => //. + by rewrite lerD2l lerNr opprK; exact e3e. Qed. Section typ_seq_prop. +Context {R : realType}. +Variables (A : finType) (P : R.-fdist A) (epsilon : R) (n : nat). -Variables (A : finType) (P : {fdist A}) (epsilon : R) (n : nat). - -Lemma TS_sup : #| `TS P n epsilon |%:R <= exp2 (n%:R * (`H P + epsilon)). +Lemma TS_sup : #| `TS P n epsilon |%:R <= 2 `^ (n%:R * (`H P + epsilon)). Proof. -suff Htmp : #| `TS P n epsilon |%:R * exp2 (- n%:R * (`H P + epsilon)) <= 1. - by rewrite -(mulR1 (exp2 _)) mulRC -leR_pdivr_mulr // /Rdiv -exp2_Ropp -mulNR. -rewrite (_ : 1 = 1%mcR)// -(FDist.f1 (P `^ n)). -rewrite (_ : _ * _ = \sum_(x in `TS P n epsilon) (exp2 (- n%:R * (`H P + epsilon)))); last first. - by rewrite big_const iter_addR. -by apply/leR_sumRl => //= i; rewrite inE; case/andP => /RleP. +suff Htmp : #| `TS P n epsilon |%:R * 2 `^ (- n%:R * (`H P + epsilon)) <= 1. + by rewrite -(mulr1 (2 `^ _)) mulrC -ler_pdivrMr// ?powR_gt0// -powRN// -mulNr. +rewrite -[leRHS](FDist.f1 (P `^ n)%fdist). +rewrite (_ : _ * _ = + \sum_(x in `TS P n epsilon) (2 `^ (- n%:R * (`H P + epsilon)))); last first. + by rewrite big_const iter_addr addr0 mulr_natl. +by apply: leR_sumRl => //= i; rewrite inE; case/andP. Qed. Lemma typ_seq_definition_equiv x : x \in `TS P n epsilon -> - exp2 (- n%:R * (`H P + epsilon)) <= P `^ n x <= exp2 (- n%:R * (`H P - epsilon)). -Proof. by rewrite inE /typ_seq => /andP[? ?]; split; apply/RleP. Qed. + 2 `^ (- n%:R * (`H P + epsilon)) <= (P `^ n)%fdist x <= + 2 `^ (- n%:R * (`H P - epsilon)). +Proof. by rewrite inE /typ_seq => /andP[? ?]; apply/andP; split. Qed. Lemma typ_seq_definition_equiv2 x : x \in `TS P n.+1 epsilon -> - `H P - epsilon <= - (1 / n.+1%:R) * log (P `^ n.+1 x) <= `H P + epsilon. + `H P - epsilon <= - n.+1%:R^-1 * log ((P `^ n.+1)%fdist x) <= `H P + epsilon. Proof. -rewrite inE /typ_seq. -case/andP => H1 H2; split; - apply/RleP; rewrite -(@ler_pM2r _ n.+1%:R) ?ltr0n//. -- rewrite div1R -[in leRHS]RmultE mulRAC mulNR INRE mulVR; last first. - by rewrite mulrn_eq0/= oner_eq0. - rewrite mulN1R; apply/RleP. - rewrite leR_oppr. - apply/(@Exp_le_inv 2) => //. - rewrite LogK //; last by apply/(ltR_leR_trans (exp2_gt0 _)); apply/RleP: H1. - rewrite mulrC -mulNR -INRE. - exact/RleP. -- rewrite div1R -[in leLHS]RmultE mulRAC mulNR INRE mulVR; last first. - by rewrite mulrn_eq0/= oner_eq0. - rewrite mulN1R; apply/RleP. - rewrite leR_oppl. - apply/(@Exp_le_inv 2) => //. - rewrite LogK //; last by apply/(ltR_leR_trans (exp2_gt0 _)); apply/RleP: H1. - rewrite mulrC -mulNR -INRE. - exact/RleP. +rewrite inE /typ_seq => /andP[H1 H2]; apply/andP; split; + rewrite -(@ler_pM2r _ n.+1%:R) ?ltr0n//. +- rewrite mulrAC mulNr mulVf; last by rewrite pnatr_eq0. + rewrite mulN1r. + rewrite lerNr. + rewrite -ler_log ?posrE// in H2; last 2 first. + by rewrite (lt_le_trans _ H1)// powR_gt0. + by rewrite powR_gt0. + by rewrite mulNr powRN logV ?powR_gt0// log_powR log2 mulr1 mulrC in H2. +- rewrite mulrAC mulNr mulVf; last by rewrite pnatr_eq0. + have := FDist.ge0 ((P `^ n.+1)%fdist) x; rewrite le_eqVlt => /predU1P[H3|H3]. + have : 0 < 2 `^ (1 *- n.+1 * (`H P + epsilon)) by rewrite powR_gt0. + rewrite -H3 in H1. + by rewrite ltNge H1. + rewrite mulN1r. + rewrite lerNl. + rewrite -ler_log ?posrE ?powR_gt0// in H1. + by rewrite mulNr powRN logV ?powR_gt0// log_powR log2 mulr1 mulrC in H1. Qed. End typ_seq_prop. Section typ_seq_more_prop. - -Variables (A : finType) (P : {fdist A}) (epsilon : R) (n : nat). +Context {R : realType}. +Variables (A : finType) (P : R.-fdist A) (epsilon : R) (n : nat). Hypothesis He : 0 < epsilon. Lemma Pr_TS_1 : aep_bound P epsilon <= n.+1%:R -> - 1 - epsilon <= Pr (P `^ n.+1) (`TS P n.+1 epsilon). + 1 - epsilon <= Pr (P `^ n.+1)%fdist (`TS P n.+1 epsilon). Proof. move=> k0_k. -have -> : Pr P `^ n.+1 (`TS P n.+1 epsilon) = - Pr P `^ n.+1 [set i | (i \in `TS P n.+1 epsilon) && (0 < P `^ n.+1 i)%mcR]. +have -> : Pr (P `^ n.+1)%fdist (`TS P n.+1 epsilon) = + Pr (P `^ n.+1)%fdist [set i | (i \in `TS P n.+1 epsilon) && (0 < (P `^ n.+1)%fdist i)]. congr Pr; apply/setP => /= t; rewrite !inE. apply/idP/andP => [H|]; [split => // | by case]. - case/andP : H => /RleP H _; exact/RltP/(ltR_leR_trans (exp2_gt0 _) H). + by case/andP : H => H _; apply/(lt_le_trans _ H); rewrite powR_gt0. set p := [set _ | _]. -rewrite Pr_to_cplt leR_add2l leR_oppl oppRK. -have -> : Pr P `^ n.+1 (~: p) = - Pr P `^ n.+1 [set x | P `^ n.+1 x == 0] + - Pr P `^ n.+1 [set x | (0 < P `^ n.+1 x)%mcR && - (`| - (1 / n.+1%:R) * log (P `^ n.+1 x) - `H P | > epsilon)%mcR]. +rewrite Pr_to_cplt lerD2l lerNl opprK. +have -> : Pr (P `^ n.+1)%fdist (~: p) = + Pr (P `^ n.+1)%fdist [set x | (P `^ n.+1)%fdist x == 0] + + Pr (P `^ n.+1)%fdist [set x | (0 < (P `^ n.+1)%fdist x) && + (`| - n.+1%:R^-1 * log ((P `^ n.+1)%fdist x) - `H P | > epsilon)]. have -> : ~: p = - [set x | P `^ n.+1 x == 0 ] :|: - [set x | (0 < P `^ n.+1 x)%mcR && - (`| - (1 / n.+1%:R) * log (P `^ n.+1 x) - `H P | > epsilon)%mcR]. + [set x | (P `^ n.+1)%fdist x == 0 ] :|: + [set x | (0 < (P `^ n.+1)%fdist x) && + (`| - n.+1%:R^-1 * log ((P `^ n.+1)%fdist x) - `H P | > epsilon)]. apply/setP => /= i; rewrite !inE negb_and orbC. - apply/idP/idP => [/orP[/RltP|]|]. - - move/RltP => H. - have {}H : P `^ n.+1 i = 0. + apply/idP/idP => [/orP[H|]|]. + - have {}H : (P `^ n.+1)%fdist i = 0. apply/eqP. apply/negPn. apply: contra H. - by have [+ _] := fdist_gt0 (P `^ n.+1) i. + by have [+ _] := fdist_gt0 (P `^ n.+1)%fdist i. by rewrite H eqxx. - rewrite /typ_seq negb_and => /orP[|] LHS. - + have [//|H1] := eqVneq (P `^ n.+1 i) 0. - have {}H1 : 0 < P `^ n.+1 i by apply/RltP; rewrite lt0r H1/=. - apply/andP; split; first exact/RltP. - move/RleP: LHS => /ltRNge/(@Log_increasing 2 _ _ Rlt_1_2 H1). - rewrite /exp2 ExpK // mulRC mulRN -mulNR -ltR_pdivr_mulr; last exact/ltR0n. - rewrite /Rdiv mulRC ltR_oppr => /RltP; rewrite -ltrBrDl => LHS. - rewrite div1r// mulNr -RinvE ger0_norm// -INRE//. - by move/RltP : LHS; move/(ltR_trans He)/ltRW/RleP. + + have [//|H1] := eqVneq ((P `^ n.+1)%fdist i) 0. + have {}H1 : 0 < (P `^ n.+1)%fdist i by rewrite lt0r H1/=. + rewrite /= H1/=. + move: LHS; rewrite -ltNge => /ltr_log => /(_ H1). + rewrite log_powR mulNr log2 mulr1 -mulrN -ltr_pdivrMl// opprD. + rewrite ltrBrDl -ltrBrDr addrC => /lt_le_trans; apply. + by rewrite mulNr ler_norm. + move: LHS; rewrite leNgt negbK => LHS. apply/orP; right; apply/andP; split. - exact/(lt_trans _ LHS)/RltP/exp2_gt0. - move/RltP in LHS. - move/(@Log_increasing 2 _ _ Rlt_1_2 (exp2_gt0 _)) : LHS. - rewrite /exp2 ExpK // mulRC mulRN -mulNR -ltR_pdivl_mulr; last exact/ltR0n. - rewrite oppRD oppRK => LHS. - have H2 : forall a b c, - a + b < c -> - c - a < - b by move=> *; lra. - move/H2 in LHS. - rewrite div1r mulrC mulrN ler0_norm//. - * rewrite ltrNr//; apply/RltP; rewrite -RminusE -RoppE. - by rewrite -RdivE ?gt_eqF// ?ltr0n// -INRE. - * apply/RleP; rewrite -RminusE -RoppE. - rewrite -RdivE ?gt_eqF// ?ltr0n// -INRE//. - apply: (leR_trans (ltRW LHS)). - by apply/RleP; rewrite lerNl oppr0// ltW//; apply/RltP. + exact/(lt_trans _ LHS)/powR_gt0. + have : 0 < 2 `^ (1 *- n.+1 * (`H P - epsilon)) by exact/powR_gt0. + move/ltr_log : LHS => /[apply]. + rewrite log_powR log2 mulr1 -ltr_ndivrMl; last first. + by rewrite oppr_lt0 ltr0n. + rewrite -ltrN2 opprB ltrBlDr => /lt_le_trans; apply. + rewrite addrC -opprB mulNr opprB -[in leRHS]opprD normrN. + by rewrite invrN mulNr opprK addrC ler_norm. - rewrite -negb_and; apply: contraTN. - rewrite negb_or /typ_seq => /andP[H1 /andP[/RleP H2 /RleP H3]]. - apply/andP; split; first exact/gtR_eqF/RltP. - rewrite negb_and H1 /= -leNgt. - move/(@Log_increasing_le 2 _ _ Rlt_1_2 (exp2_gt0 _)) : H2. - rewrite /exp2 ExpK // mulRC mulRN -mulNR -leR_pdivl_mulr ?oppRD; last exact/ltR0n. - move => H2. - have /(_ _ _ _ H2) {}H2 : forall a b c, - a + - b <= c -> - c - a <= b. - by move=> *; lra. - move/RltP in H1. - move/(@Log_increasing_le 2 _ _ Rlt_1_2 H1) : H3. - rewrite /exp2 ExpK //. - rewrite mulRC mulRN -mulNR -leR_pdivr_mulr; last exact/ltR0n. - rewrite oppRD oppRK div1r mulrC mulrN => H3. - have /(_ _ _ _ H3) {}H3 : forall a b c, a <= - c + b -> - b <= - a - c. - by move=> *; lra. - by rewrite ler_norml; apply/andP; split; - apply/RleP; rewrite -RminusE -RoppE; - rewrite -RdivE ?gt_eqF// ?ltr0n// -INRE//. + rewrite negb_or /typ_seq => /andP[H1 /andP[H2 H3]]. + rewrite gt_eqF//= negb_and H1 /= -leNgt. + have : 0 < 2 `^ (1 *- n.+1 * (`H P + epsilon)) by exact/powR_gt0. + move/log_increasing_le : H2 => /[apply] /=. + rewrite log_powR log2 mulr1 -ler_ndivrMl; last by rewrite oppr_lt0 ltr0n. + rewrite -lerBlDl invrN => H2. + rewrite ler_norml H2 andbT. + move/log_increasing_le : H3 => /(_ H1). + rewrite log_powR log2 mulr1 -ler_ndivlMl; last by rewrite oppr_lt0 ltr0n. + by rewrite invrN addrC -{1}(opprK (`H P)) lerBlDr. rewrite disjoint_Pr_setU // disjoints_subset; apply/subsetP => /= i. by rewrite !inE /= => /eqP Hi; rewrite negb_and Hi ltxx. -rewrite {1}/Pr (eq_bigr (fun=> 0)); last by move=> /= v; rewrite inE => /eqP. -rewrite big_const iter_addR mulR0 add0R. -apply/(leR_trans _ (aep He k0_k))/subset_Pr/subsetP => /= t. +rewrite {1}/Pr big1 ?add0r; last by move=> /= v; rewrite inE => /eqP. +apply/(le_trans _ (aep He k0_k))/subset_Pr/subsetP => /= t. rewrite !inE /= => /andP[-> H3]. -rewrite /log_RV /= /scalel_RV /= mulRN -mulNR. -apply/ltW. -by rewrite RmultE RoppE// RdivE ?gt_eqF ?INRE ?ltr0n. +by rewrite /log_RV /= /scalel_RV /= mulrN -mulNr div1r ltW. Qed. Variable He1 : epsilon < 1. Lemma set_typ_seq_not0 : aep_bound P epsilon <= n.+1%:R -> - #| `TS P n.+1 epsilon | <> O. + #| `TS P n.+1 epsilon | != O. Proof. move/Pr_TS_1 => H. -case/boolP : (#| `TS P n.+1 epsilon | == O) => [|Heq]; last by apply/eqP. +have [/eqP|//] := eqVneq (#| `TS P n.+1 epsilon |) O. rewrite cards_eq0 => /eqP Heq. rewrite Heq Pr_set0 in H. -lra. +exfalso. +move: H; apply/negP. +by rewrite -ltNge subr_gt0. Qed. Definition TS_0 (H : aep_bound P epsilon <= n.+1%:R) : 'rV[A]_n.+1. @@ -224,7 +207,7 @@ apply (@enum_val _ (pred_of_set (`TS P n.+1 epsilon))). have -> : #| `TS P n.+1 epsilon| = #| `TS P n.+1 epsilon|.-1.+1. rewrite prednK //. move/set_typ_seq_not0 in H. - rewrite lt0n; by apply/eqP. + by rewrite lt0n. exact ord0. Defined. @@ -233,22 +216,20 @@ Lemma TS_0_is_typ_seq (k_k0 : aep_bound P epsilon <= n.+1%:R) : Proof. rewrite /TS_0. apply/enum_valP. Qed. Lemma TS_inf : aep_bound P epsilon <= n.+1%:R -> - (1 - epsilon) * exp2 (n.+1%:R * (`H P - epsilon)) <= #| `TS P n.+1 epsilon |%:R. + (1 - epsilon) * 2 `^ (n.+1%:R * (`H P - epsilon)) <= #| `TS P n.+1 epsilon |%:R. Proof. move=> k0_k. -have H1 : (1 - epsilon <= Pr (P `^ n.+1) (`TS P n.+1 epsilon) <= 1)%mcR. - by apply/andP; split; apply/RleP; [exact: Pr_TS_1 | exact: Pr_le1]. -have H2 : (forall x, x \in `TS P n.+1 epsilon -> - exp2 (- n.+1%:R * (`H P + epsilon)) <= - P `^ n.+1 x <= exp2 (- n.+1%:R * (`H P - epsilon)))%mcR. +have H1 : 1 - epsilon <= Pr (P `^ n.+1)%fdist (`TS P n.+1 epsilon) <= 1. + by rewrite Pr_TS_1//= Pr_le1. +have H2 : forall x, x \in `TS P n.+1 epsilon -> + 2 `^ (- n.+1%:R * (`H P + epsilon)) <= + (P `^ n.+1)%fdist x <= 2 `^ (- n.+1%:R * (`H P - epsilon)). by move=> x; rewrite inE /typ_seq => /andP[-> ->]. -have /RltP H3 := exp2_gt0 (- n.+1%:R * (`H P + epsilon)). -have /RltP H5 := exp2_gt0 (- n.+1%:R * (`H P - epsilon)). +have O2 : 0 < 2 :> R by lra. +have H3 := powR_gt0 (- n.+1%:R * (`H P + epsilon)) O2. +have H5 := powR_gt0 (- n.+1%:R * (`H P - epsilon)) O2. have := wolfowitz H3 H5 H1 H2. -rewrite mulNR exp2_Ropp. -rewrite RinvE ?gtR_eqF// invrK => /andP[] /RleP. -by rewrite -!RmultE -RminusE -INRE. -(* TODO: clean *) +by rewrite mulNr powRN invrK => /andP[]. Qed. End typ_seq_more_prop. diff --git a/information_theory/types.v b/information_theory/types.v index 29cd2e03..28cff72d 100644 --- a/information_theory/types.v +++ b/information_theory/types.v @@ -1,12 +1,10 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From HB Require Import structures. -From mathcomp Require Import all_ssreflect ssralg ssrnum perm. -From mathcomp Require Import matrix. +From mathcomp Require Import all_ssreflect ssralg ssrnum perm matrix. From mathcomp Require boolp. -From mathcomp Require Import Rstruct. -Require Import Reals. -Require Import ssrR Reals_ext realType_ext ssr_ext ssralg_ext logb. +From mathcomp Require Import Rstruct exp. +Require Import ssr_ext ssralg_ext realType_ext realType_ln. Require Import fdist proba entropy num_occ channel_code channel typ_seq. (******************************************************************************) @@ -33,22 +31,22 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. +Import GRing.Theory Num.Theory. + Local Open Scope entropy_scope. Local Open Scope num_occ_scope. -Local Open Scope R_scope. Local Open Scope fdist_scope. +Local Open Scope ring_scope. Module type. Section type_def. - -Variable A : finType. -Variable n : nat. +Variables (A : finType) (n : nat). Record type : predArgType := mkType { d :> {fdist A} ; f : {ffun A -> 'I_n.+1} ; - d_f : forall a, d a = INR (f a) / INR n }. + d_f : forall a, d a = (f a)%:R / n%:R }. End type_def. @@ -66,7 +64,8 @@ Definition ffun_of_type A n (P : P_ n ( A )) := let: type.mkType _ f _ := P in f Lemma type_fun_type A n (_ : n != O) (P : P_ n ( A )) a : ((type.f P) a)%:R = n%:R * type.d P a. Proof. -case: P => /= d f d_f; by rewrite d_f mulRCA mulRV ?INR_eq0' // mulR1. +case: P => /= d f d_f. +by rewrite d_f mulrCA mulfV ?mulr1// pnatr_eq0. Qed. Lemma INR_type_fun A n (P : P_ n ( A )) a : @@ -76,23 +75,24 @@ Proof. destruct P as [d f d_f] => /=. by rewrite d_f. Qed. Lemma no_0_type (A : finType) (d : {fdist A}) (t : {ffun A -> 'I_1}) : (forall a, d a = (t a)%:R / 0%:R) -> False. Proof. -move=> H; apply R1_neq_R0. -rewrite (_ : 1 = 1%mcR)//. +move=> H. +have /eqP := @oner_neq0 Rdefinitions.R; apply. rewrite -(FDist.f1 d). -transitivity (\sum_(a | a \in A) INR (t a) / 0); first exact/eq_bigr. -rewrite -big_distrl /= -big_morph_natRD. -rewrite (_ : (\sum_(a in A) _)%nat = O) ?mul0R //. +transitivity (\sum_(a | a \in A) (t a)%:R / 0 : Rdefinitions.R); first exact/eq_bigr. +rewrite -big_distrl /= -natr_sum. +rewrite (_ : (\sum_(a in A) _)%nat = O) ?mul0r //. transitivity (\sum_(a in A) 0)%nat; first by apply eq_bigr => a _; rewrite (ord1 (t a)). by rewrite big_const iter_addn. Qed. Definition type_of_tuple (A : finType) n (ta : n.+1.-tuple A) : P_ n.+1 ( A ). -set f := [ffun a => N(a | ta)%:R / n.+1%:R]. +pose f := [ffun a => N(a | ta)%:R / n.+1%:R : Rdefinitions.R]. assert (H1 : forall a, (0%mcR <= f a)%mcR). - move=> a; rewrite ffunE; apply/RleP/divR_ge0; by [apply leR0n | apply ltR0n]. -assert (H2 : \sum_(a in A) f a = 1%R). + move=> a; rewrite ffunE; apply/divr_ge0; by [apply ler0n | apply ltr0n]. +assert (H2 : \sum_(a in A) f a = 1). under eq_bigr do rewrite ffunE /=. - by rewrite -big_distrl /= -big_morph_natRD sum_num_occ_alt mulRV // INR_eq0'. + rewrite -big_distrl /= -natr_sum. + by rewrite sum_num_occ_alt mulfV // pnatr_eq0. assert (H : forall a, (N(a | ta) < n.+2)%nat). move=> a; rewrite ltnS; by apply num_occ_leq_n. refine (@type.mkType _ n.+1 (FDist.make H1 H2) @@ -133,35 +133,30 @@ destruct Q as [d2 f2 H2]. rewrite /= in H. apply/type_eqP => /=. apply/eqP/ffunP => a. -apply/val_inj/INR_eq. -move: {H}(H a); rewrite H1 H2 eqR_mul2r //. -apply/invR_neq0; by rewrite INR_eq0. +apply/val_inj/eqP. +rewrite -(eqr_nat Rdefinitions.R). +move: {H}(H a); rewrite H1 H2. +move=> /(congr1 (fun x => x * n.+1%:R)). +by rewrite -!mulrA mulVf ?mulr1 ?pnatr_eq0// => ->. Qed. Definition fdist_of_ffun (A : finType) n (f : {ffun A -> 'I_n.+2}) (Hf : (\sum_(a in A) f a)%nat == n.+1) : {fdist A}. -set pf := [ffun a : A => INR (f a) / INR n.+1]. +set pf := [ffun a : A => (f a)%:R / n.+1%:R :> Rdefinitions.R]. assert (pf_ge0 : forall a, (0 <= pf a)%mcR). - move=> a; apply/RleP. - rewrite /pf/= ffunE; apply: divR_ge0 => //. - apply/RleP. - rewrite INRE. - by rewrite Num.Theory.ler0n. - apply/RltP. - rewrite INRE. - by rewrite Num.Theory.ltr0n. -assert (H : (\sum_(a in A) pf a)%mcR = 1 :> R). + move=> a. + by rewrite /pf/= ffunE divr_ge0//. +assert (H : (\sum_(a in A) pf a)%mcR = 1 :> Rdefinitions.R). rewrite /pf; under eq_bigr do rewrite ffunE /=. - rewrite /Rdiv -big_distrl /= -big_morph_natRD. + rewrite -big_distrl /= -natr_sum. move/eqP : Hf => ->. - rewrite -RmultE. - by rewrite mulRV// INR_eq0'. + by rewrite mulfV// pnatr_eq0. exact: (FDist.make pf_ge0 H). Defined. Lemma fdist_of_ffun_prop (A : finType) n (f : {ffun A -> 'I_n.+2}) (Hf : (\sum_(a in A) f a)%nat == n.+1) : -forall a : A, (fdist_of_ffun Hf) a = INR (f a) / INR n.+1. +forall a : A, (fdist_of_ffun Hf) a = (f a)%:R / n.+1%:R. Proof. by move=> a; rewrite ffunE. Qed. Definition type_choice_f (A : finType) n (f : {ffun A -> 'I_n.+1}) : option (P_ n ( A )). @@ -173,14 +168,15 @@ refine (match Sumbool.sumbool_of_bool (\sum_(a in A) f a == n.+1)%nat with Defined. Lemma ffun_of_fdist (A : finType) n (d : {fdist A}) (t : {ffun A -> 'I_n.+2}) - (H : forall a : A, d a = INR (t a) / INR n.+1) : (\sum_(a in A) t a)%nat == n.+1. + (H : forall a : A, d a = (t a)%:R / n.+1%:R) : (\sum_(a in A) t a)%nat == n.+1. Proof. -suff : INR (\sum_(a in A) t a) == INR n.+1 * \sum_(a | a \in A) d a. - by move/eqP; rewrite (FDist.f1 d) mulR1 => /INR_eq/eqP. +suff : (\sum_(a in A) t a)%:R == n.+1%:R * \sum_(a | a \in A) d a. + by move/eqP; rewrite (FDist.f1 d) mulr1 => /eqP; rewrite eqr_nat. apply/eqP. -transitivity (INR n.+1 * (\sum_(a|a \in A) INR (t a) / INR n.+1)). - by rewrite -big_distrl -big_morph_natRD mulRCA mulRV ?mulR1 // INR_eq0'. -congr (_ * _); exact/eq_bigr. +transitivity (n.+1%:R * (\sum_(a|a \in A) (t a)%:R / n.+1%:R) :> Rdefinitions.R). + rewrite -big_distrl -natr_sum. + by rewrite mulrCA mulfV ?mulr1 // pnatr_eq0. +by congr (_ * _); exact/eq_bigr. Qed. Lemma type_choice_pcancel A n : pcancel (@type.f A n) (@type_choice_f A n). @@ -312,10 +308,8 @@ End type_facts. Section typed_tuples. Variables (A : finType) (n : nat) (P : P_ n ( A )). -Local Open Scope nat_scope. - Definition typed_tuples := - [set t : n.-tuple A | [forall a, type.d P a == (INR N(a | t) / INR n)%R] ]. + [set t : n.-tuple A | [forall a, type.d P a == (N(a | t)%:R / n%:R)%R] ]. End typed_tuples. @@ -332,9 +326,10 @@ move: Hta. rewrite in_set. move/forallP/(_ a)/eqP. destruct P as [d f H] => /= Htmp. -apply/INR_eq/esym; move: Htmp. -rewrite H eqR_mul2r //. -by apply/invR_neq0; rewrite INR_eq0. +apply/eqP; rewrite -(@eqr_nat Rdefinitions.R). +move: Htmp => /(congr1 (fun x => x * n%:R)). +rewrite -mulrA mulVf ?pnatr_eq0// mulr1 => <-. +by rewrite H -mulrA mulVf ?mulr1// pnatr_eq0. Qed. Lemma typed_tuples_not_empty' : exists x : seq A, @@ -392,7 +387,7 @@ Local Open Scope tuple_ext_scope. Local Open Scope vec_ext_scope. Lemma tuple_dist_type t : tuple_of_row t \in T_{P} -> - (type.d P) `^ n t = \prod_(a : A) type.d P a ^ (type.f P a). + ((type.d P) `^ n) t = \prod_(a : A) type.d P a ^+ (type.f P a). Proof. move=> Hx. rewrite fdist_rVE. @@ -401,20 +396,20 @@ rewrite (_ : \prod_(i < n) type.d P (t ``_ i) = rewrite exchange_big; apply eq_big ; first by []. move=> i _. rewrite (bigID (fun y => y == t ``_ i)) /=. - rewrite -/(INR n.+1) big_pred1_eq eqxx big1 ?mulR1 //. + rewrite big_pred1_eq eqxx big1 ?mulr1 //. by move=> i0 /negbTE ->. apply eq_bigr => a _. -rewrite -big_mkcond /= -/(INR n.+1). -transitivity (\prod_(i < n | t ``_ i == a) (INR (type.f P a) / INR n)). - apply eq_big => // i. - move/eqP => ->. - by rewrite INR_type_fun. -rewrite big_const iter_mulR INR_type_fun. -congr (_ ^ _). +rewrite -big_mkcond /=. +transitivity (\prod_(i < n | t ``_ i == a) ((type.f P a)%:R / n%:R) : Rdefinitions.R). + by apply eq_big => // i /eqP ->; rewrite INR_type_fun. +rewrite prodr_const/=. +rewrite INR_type_fun. +congr (_ ^+ _). rewrite /typed_tuples inE in Hx. move/forallP/(_ a)/eqP : Hx. -rewrite -INR_type_fun eqR_mul2r; last by apply/invR_neq0; rewrite INR_eq0; exact/eqP. -move/INR_eq => ->. +rewrite -INR_type_fun. +move=> /(congr1 (fun x => x * n%:R)). +rewrite -!mulrA mulVf ?pnatr_eq0 ?mulr1// => /eqP; rewrite eqr_nat => /eqP ->. rewrite num_occ_alt cardsE /=. apply eq_card => /= n0. by rewrite /in_mem /= tnth_mktuple. @@ -423,84 +418,90 @@ Qed. Local Close Scope tuple_ext_scope. Lemma tuple_dist_type_entropy t : tuple_of_row t \in T_{P} -> - (type.d P) `^ n t = exp2 (- INR n * `H P). + ((type.d P) `^ n) t = ((2%:R:Rdefinitions.R) `^ (- n%:R * `H P))%R. Proof. move/(@tuple_dist_type t) => ->. -rewrite (_ : \prod_(a : A) type.d P a ^ (type.f P) a = - \prod_(a : A) exp2 (type.d P a * log (type.d P a) * INR n)); last first. +rewrite (_ : \prod_(a : A) type.d P a ^+ (type.f P) a = + \prod_(a : A) (2%:R:Rdefinitions.R) `^ (type.d P a * log (type.d P a) * n%:R)); last first. apply eq_bigr => a _. - case/boolP : (0 == type.d P a) => H; last first. + have [H|H] := eqVneq 0 (type.d P a); last first. have {}H : 0 < type.d P a. have := FDist.ge0 (type.d P) a. - move/RleP. - case/Rle_lt_or_eq_dec => // abs. - rewrite (_ : 0%mcR = 0)// in abs. - by rewrite abs eqxx in H. - rewrite -{1}(logK H) -exp2_pow. - congr exp2. - rewrite -mulRA [X in _ = X]mulRC -mulRA mulRC. + by rewrite Order.POrderTheory.le_eqVlt (negbTE H)/=. + rewrite -{1}(@LogK _ 2%N _ _ H)//. + rewrite -powRrM' mulrC. + congr (_ `^ _)%R. + rewrite -mulrA [X in _ = X]mulrC -mulrA mulrC. congr (_ * _). - by rewrite type_fun_type. - - move/eqP : (H) => <-. - rewrite -(_ : O = type.f P a); first by rewrite !mul0R exp2_0 /pow. - apply INR_eq. - rewrite {1}/INR. - rewrite -(@eqR_mul2r ( / INR n)); last by apply/invR_neq0; rewrite INR_eq0; exact/eqP. - by rewrite type_fun_type // -(eqP H) mulR0. -rewrite -(big_morph _ morph_exp2_plus exp2_0) -(big_morph _ (morph_mulRDl _) (mul0R _)). -by rewrite /entropy Rmult_opp_opp mulRC. + by rewrite -type_fun_type. + - move : (H) => <-. + rewrite -(_ : O = type.f P a). + by rewrite !mul0r expr0 exp.powRr0. + apply/eqP. + rewrite -(eqr_nat Rdefinitions.R). + move : H => /(congr1 (fun x => n%:R * x)). + by rewrite mulr0 type_fun_type// => /eqP. +rewrite -powR2sum. +congr (_ `^ _)%R. +rewrite /entropy mulrN mulNr opprK. +rewrite big_distrr/=. +apply: eq_bigr => a _. +by rewrite mulrC; congr *%R. Qed. Local Open Scope typ_seq_scope. Import Order.POrderTheory. -Lemma typed_tuples_are_typ_seq : (@row_of_tuple A n @: T_{ P }) \subset `TS P n 0. +Lemma typed_tuples_are_typ_seq : + (@row_of_tuple A n @: T_{ P }) \subset `TS P n 0. Proof. apply/subsetP => t Ht. rewrite /set_typ_seq inE /typ_seq tuple_dist_type_entropy; last first. - case/imsetP : Ht => x Hx ->. - by rewrite row_of_tupleK. -by rewrite addR0 subR0 lexx. + by case/imsetP : Ht => x Hx ->; rewrite row_of_tupleK. +by rewrite addr0 subr0 lexx. Qed. -Lemma card_typed_tuples : INR #| T_{ P } | <= exp2 (INR n * `H P). +Lemma card_typed_tuples : + #| T_{ P } |%:R <= ((2%:R:Rdefinitions.R) `^ (n%:R * `H P))%R. Proof. -rewrite -(invRK (exp2 (INR n * `H P))%R) -exp2_Ropp -mulNR. -set aux := - INR n * `H P. -rewrite -div1R leR_pdivl_mulr // {}/aux. +rewrite -(@invrK _ ((2%:R:Rdefinitions.R) `^ (n%:R * `H P))%R) -powRN -mulNr. +set aux := - n%:R * `H P. +rewrite -div1r ler_pdivlMr // {}/aux ?powR_gt0//. case/boolP : [exists x, x \in T_{P}] => x_T_P. - case/existsP : x_T_P => ta Hta. rewrite -(row_of_tupleK ta) in Hta. rewrite -(tuple_dist_type_entropy Hta). - rewrite [X in X <= _](_ : _ = Pr (type.d P) `^ n (@row_of_tuple A n @: T_{P})). + rewrite [X in X <= _](_ : _ = Pr ((type.d P) `^ n) (@row_of_tuple A n @: T_{P})). exact: Pr_le1. symmetry. rewrite /Pr. transitivity (\sum_(a | (a \in 'rV[A]_n) && [pred x in (@row_of_tuple A n @: T_{P})] a) - exp2 (- INR n * `H P)). + (2%:R : Rdefinitions.R) `^ (- n%:R * `H P)). apply eq_big => // ta'/= Hta'. rewrite -(@tuple_dist_type_entropy ta') //. case/imsetP : Hta' => x Hx ->. by rewrite row_of_tupleK. - rewrite big_const iter_addR tuple_dist_type_entropy //. + rewrite big_const iter_addr addr0 tuple_dist_type_entropy //. + rewrite [in RHS]mulrC. + rewrite mulr_natr. do 2 f_equal. by rewrite card_imset //; exact: row_of_tuple_inj. -- rewrite (_ : (INR #| T_{P} | = 0)%R); first by rewrite mul0R; exact/Rle_0_1. - rewrite (_ : 0%R = INR 0) //; congr INR; apply/eqP. +- rewrite (_ : (#| T_{P} |%:R = 0)%R); first by rewrite mul0r. + rewrite (_ : 0%R = 0%:R) //; congr (_%:R); apply/eqP. rewrite cards_eq0; apply/negPn. by move: x_T_P; apply contra => /set0Pn/existsP. Qed. -Lemma card_typed_tuples_alt : INR #| T_{P} | <= exp2 (INR n * `H P). +Lemma card_typed_tuples_alt : + (#| T_{P} |%:R <= (2%R:Rdefinitions.R) `^ (n%:R * `H P))%R. Proof. -apply (@leR_trans (INR #| `TS P n 0 |)). - apply/le_INR/leP. +apply (@le_trans _ _ (#| `TS P n 0 |%:R)). + rewrite ler_nat. apply: leq_trans; last first. by apply subset_leq_card; exact: typed_tuples_are_typ_seq. by rewrite card_imset //; exact: row_of_tuple_inj. -apply: (leR_trans (TS_sup _ _ _)); rewrite addR0. -by apply/RleP; rewrite Order.POrderTheory.lexx. +by apply: (le_trans (TS_sup _ _ _)); rewrite addr0. Qed. Lemma perm_tuple_in_Ttuples ta (s : 'S_n) : @@ -588,15 +589,15 @@ Variable c : code A B M n. Lemma sum_messages_types' f : \sum_(P : P_ n ( A )) (\sum_(m |m \in enc_pre_img c P) f m) = - \sum_ (S | S \in enc_pre_img_partition c) \sum_(m in S) f m. + \sum_ (S | S \in enc_pre_img_partition c) \sum_(m in S) f m :> Rdefinitions.R. Proof. rewrite (bigID (fun P => [exists m, m \in enc_pre_img c P] )). rewrite /=. -rewrite Rplus_comm big1 ; last first. +rewrite addrC big1 ; last first. move=> P; rewrite negb_exists => HP. apply big_pred0 => m /=. by apply/negP/negPn; move:HP => /forallP/(_ m) ->. -rewrite /= add0R big_imset. +rewrite /= add0r big_imset. apply eq_big => [P|P _] //=. rewrite in_set. by case: set0Pn => [/existsP //| ?]; exact/existsP. @@ -607,18 +608,21 @@ case: Q HPQ => /= Qd Qf HQ HPQ. apply/type_eqP => /=. apply/eqP. apply ffunP => a. -apply/val_inj/INR_eq. -move: {HPQ}(HPQ a); rewrite HP HQ eqR_mul2r //. -by apply/invR_neq0; rewrite INR_eq0. +apply/val_inj. +move: {HPQ}(HPQ a); rewrite HP HQ. +move=> /(congr1 (fun x => x * n%:R)). +rewrite -!mulrA mulVf ?pnatr_eq0// !mulr1 => /eqP. +by rewrite eqr_nat => /eqP. Qed. Lemma sum_messages_types f : - \sum_(P : P_ n ( A )) (\sum_(m |m \in enc_pre_img c P) f m) = \sum_ (m : M) (f m). + \sum_(P : P_ n ( A )) (\sum_(m |m \in enc_pre_img c P) f m) + = \sum_ (m : M) (f m) :> Rdefinitions.R. Proof. -transitivity (\sum_ (m in [set: M]) (f m)); last by apply eq_bigl => b; rewrite in_set. +transitivity (\sum_ (m in [set: M]) (f m)); last first. + by apply: eq_bigl => b; rewrite in_set. rewrite -(cover_enc_pre_img c) /enc_pre_img_partition sum_messages_types'. -symmetry. -by apply big_trivIset, trivIset_enc_pre_img. +exact/esym/big_trivIset/trivIset_enc_pre_img. Qed. End sum_messages_types. @@ -645,9 +649,11 @@ Definition Hdef := proj2_sig (typed_tuples_not_empty P). Definition tcode_untyped_code := mkCode [ffun m => if tuple_of_row (enc c m) \in T_{P} then enc c m else def] (dec c). -Lemma tcode_typed_prop (m : M) : tuple_of_row ((enc tcode_untyped_code) m) \in T_{P}. +Lemma tcode_typed_prop (m : M) : + tuple_of_row (enc tcode_untyped_code m) \in T_{P}. Proof. -rewrite /= ffunE; case: ifP => [//| _]; rewrite /def row_of_tupleK; exact Hdef. +rewrite /= ffunE; case: ifP => [//| _]; rewrite /def row_of_tupleK. +exact Hdef. Qed. Definition tcode : typed_code B M P := mkTypedCode tcode_typed_prop. diff --git a/lib/Ranalysis_ext.v b/lib/Ranalysis_ext.v deleted file mode 100644 index add13eff..00000000 --- a/lib/Ranalysis_ext.v +++ /dev/null @@ -1,400 +0,0 @@ -(* infotheo: information theory and error-correcting codes in Coq *) -(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect. -From mathcomp Require Import Rstruct. -From mathcomp Require boolp. -Require Import Reals Lra. -Require Import ssrR logb Reals_ext. - -(******************************************************************************) -(* Additional lemmas about real analysis *) -(* *) -(* Variant of lemmas (mean value theorem, etc.) from the Coq standard library *) -(* to handle about partial. Used to analyze the logarithm function as in the *) -(* x |-> x * ln x function, the binary entropy function or Pinsker's *) -(* inequality. *) -(* *) -(* Definition pderivable == derivative restricted by a condition *) -(* TODO: document lemmas *) -(* *) -(******************************************************************************) - -Set Implicit Arguments. -Unset Strict Implicit. -Import Prenex Implicits. - -Local Open Scope R_scope. - -Lemma proof_derive_irrelevance g1 g2 x - (g1x : derivable_pt g1 x) (g2x : derivable_pt g2 x) : - (forall x, g1 x = g2 x) -> derive_pt g1 x g1x = derive_pt g2 x g2x. -Proof. -move: g1x g2x => [l Hl] [m Hm] Hext. -move: Hl Hm ; rewrite /derivable_pt_abs => Hl Hm. -have g1g2 : g1 = g2 by rewrite boolp.funeqE. -have ml : l = m by subst g2; exact: (uniqueness_limite g1 x). -by subst m. -Qed. - -Lemma derivable_f_eq_g (f g : R -> R) x r : (forall y, r < y -> g y = f y) -> r < x -> - derivable_pt f x -> derivable_pt g x. -Proof. -move=> Hfg rltx. -case => l Hl. -exists l => eps Heps ; move : Hl => /(_ eps Heps) ; case ; case => delt delt_pos Hdelt. -have aux : 0 < Rmin (x - r) delt. - apply Rmin_case => // ; apply (@ltR_add2r r); by rewrite add0R addRC subRKC. -exists (mkposreal (Rmin (x - r) delt) aux) => /= h hnot0 Rlthdelta. -rewrite Hfg ; last first. - rewrite -ltR_subl_addr. - apply (@ltR_add2r (- r)). - rewrite -addRA addRCA -/(_ - _) subRR addR0 addRC. - apply (@leR_ltR_trans (Rabs h)); first by rewrite -Rabs_Ropp; apply Rle_abs. - apply (@ltR_leR_trans (Rmin (- r + x) delt)) => //. - by rewrite addRC. - exact/geR_minl. -rewrite Hfg //. -apply Hdelt => //=. -apply (@ltR_leR_trans (Rmin (x - r) delt)) => // ; exact/geR_minr. -Defined. - -Lemma derive_pt_f_eq_g f g x r (Hfg : forall y, r < y -> g y = f y) - (rltx : r < x) (derivable_f : derivable_pt f x) : - derive_pt f x (derivable_f) = - derive_pt g x (derivable_f_eq_g Hfg rltx derivable_f). -Proof. -rewrite /derive_pt /derivable_f_eq_g. -by destruct derivable_f. -Qed. - -Lemma derivable_pt_lim_cst c x : derivable_pt_lim (fun _ : R => c) x 0. -Proof. -rewrite /derivable_pt_lim => e e0. -exists (mkposreal _ e0) => h h0 Hh; by rewrite subRR subR0 div0R normR0. -Defined. - -Lemma derivable_pt_cst c x : derivable_pt (fun _ => c) x. -Proof. exists 0; exact: derivable_pt_lim_cst. Defined. - -Lemma derive_pt_cst x c : derive_pt (fun _ => c) x (derivable_pt_cst c x) = 0. -Proof. by []. Defined. - -Lemma derivable_pt_Ropp x : derivable_pt Ropp x. -Proof. -exists (-1) => eps Heps. -exists (mkposreal _ Heps) => h /eqP Hh /= Hh'. -rewrite (_ : (- (x + h) - - x) = - h); last by field. -rewrite /Rdiv mulNR mulRV // (_ : -1 - -1 = 0); last by field. -by rewrite Rabs_R0. -Defined. - -Lemma derivable_pt_Rminus p x : derivable_pt (Rminus p) x. -Proof. -exists (-1) => eps Heps. -exists (mkposreal _ Heps) => h /eqP Hh /= Hh'. -rewrite (_ : (p - (x + h) - (p - x)) = - h); last by field. -rewrite /Rdiv mulNR mulRV // (_ : -1 - -1 = 0); last by field. -by rewrite Rabs_R0. -Defined. - -Lemma derivable_pt_ln x : 0 < x -> derivable_pt ln x. -Proof. -move=> Hx; exists (/ x); apply derivable_pt_lim_ln; assumption. -Defined. - -Lemma derivable_pt_lim_Log b (x : R) : 0 < x -> - derivable_pt_lim (Log b) x (/ ln b * / x). -Proof. -move=> x0. -rewrite (_ : Log b = comp (fun x => x / ln b) ln); last by rewrite boolp.funeqE. -apply derivable_pt_lim_comp; first exact: derivable_pt_lim_ln. -move=> e e0. -exists (mkposreal _ e0) => h h0 /= he. -rewrite [_ / ln b]/Rdiv mulRDl -(addR_opp _ (ln x / ln b)) addRAC addR_opp. -rewrite subRR add0R {1}/Rdiv mulRAC mulRV ?mul1R ?subRR ?normR0 //; exact/eqP. -Defined. - -Lemma derivable_pt_Log b x : 0 < x -> derivable_pt (Log b) x. -Proof. -move=> x0. -exists (/ln b * / x). -apply derivable_pt_lim_Log. -assumption. -Defined. - -Lemma derive_pt_Log b a (a0 : 0 < a) : - derive_pt (Log b) a (derivable_pt_Log b a0) = (/ ln b * / a). -Proof. by []. Defined. - -Lemma derive_pt_ln a (a0 : 0 < a) : derive_pt ln a (derivable_pt_ln a0) = / a. -Proof. by []. Defined. - -Definition pderivable f (P : R -> Prop) := forall x, P x -> derivable_pt f x. - -Section pderivable_prop. - -Variables a b : R. -Variable f : R -> R. - -Lemma MVT_cor1_pderivable : forall (pr : pderivable f (fun x => a <= x <= b)), - a < b -> - exists c, exists Hc : a <= c <= b, - f b - f a = derive_pt f c (pr c Hc) * (b - a) /\ a < c < b. -Proof. -intros pr ab. -have H0 : forall c : R, a < c < b -> derivable_pt f c. - move=> c Hc. - apply pr. - case: Hc => ? ?; lra. -have H1 : forall c : R, a < c < b -> derivable_pt id c. - move=> c _; by apply derivable_pt_id. -have H2 : forall c, a <= c <= b -> continuity_pt f c. - move=> x Hc. - apply derivable_continuous_pt. - apply pr. - case: Hc => ? ?; lra. -have H3 : forall c, a <= c <= b -> continuity_pt id c. - move=> x Hc; by apply derivable_continuous_pt, derivable_pt_id. -case: (MVT f id a b H0 H1 ab H2 H3) => c [Hc H']. -exists c. -have Hc' : a <= c <= b. - clear H'. - case: Hc => ? ?; lra. -exists Hc'. -split; last by []. -cut (derive_pt id c (H1 c Hc) = derive_pt id c (derivable_pt_id c)); - [ intro | apply pr_nu ]. -rewrite H (derive_pt_id c) mulR1 in H'. -rewrite -H' /= /id mulRC. -f_equal. -by apply pr_nu. -Qed. - -Lemma pderivable_restrict_left : pderivable f (fun x => a < x <= b) -> - forall a' b', a < a' -> b' <= b -> a' < b' -> - pderivable f (fun x => a' <= x <= b'). -Proof. move=> H a' b' aa' bb' a'b' z [z0 z1]; apply H; lra. Defined. - -Lemma pderivable_restrict_right : pderivable f (fun x => a <= x < b) -> - forall a' b', a <= a' -> b' < b -> a' < b' -> - pderivable f (fun x => a' <= x <= b'). -Proof. move=> H a' b' aa' bb' a'b' z [z0 z1]; apply H; lra. Defined. - -Lemma pderivable_restrict_left_right : pderivable f (fun x => a < x < b) -> - forall a' b', a < a' -> b' < b -> a' < b' -> - pderivable f (fun x => a' <= x <= b'). -Proof. move=> H a' b' aa' bb' a'b' z [z0 z1]; apply H; lra. Defined. - -End pderivable_prop. - -Lemma pderive_increasing_ax_open_closed : forall (a b:R) (f:R -> R) (pr: pderivable f (fun x => a < x <= b)), - a < b -> - ((forall t:R, forall Ht :a < t <= b, 0 < derive_pt f t (pr t Ht)) -> - forall x y:R, a < x <= b -> a < y <= b -> x < y -> f x < f y) /\ - ((forall t:R, forall Ht : a < t <= b, 0 <= derive_pt f t (pr t Ht)) -> - forall x y:R, a < x <= b -> a < y <= b -> x < y -> f x <= f y). -Proof. -intros a b f pr H; split; intros H0 x y H1 H2 H3. -- rewrite -subR_gt0. - set pr' := pderivable_restrict_left pr (proj1 H1) (proj2 H2) H3. - have H0' : forall t (Ht : x <= t <= y), 0 < derive_pt f t (pr' t Ht). - move=> z /= [Hz0 Hz1]. - by apply H0. - case: (MVT_cor1_pderivable pr' H3); intros x0 [x1 [H7 H8]]. - rewrite H7. - apply mulR_gt0; [by apply H0' | lra]. -- set pr' := pderivable_restrict_left pr (proj1 H1) (proj2 H2) H3. - have H0' : forall t (Ht : x <= t <= y), 0 <= derive_pt f t (pr' t Ht). - move=> z /= [Hz0 Hz1]. - by apply H0. - case: (MVT_cor1_pderivable pr' H3); intros x0 [x1 [H7 H8]]. - rewrite -(add0R (f x)) -leR_subr_addr H7; apply mulR_ge0 => //; lra. -Qed. - -Lemma pderive_increasing_ax_closed_open : - forall (a b:R) (f:R -> R) (pr: pderivable f (fun x => a <= x < b)), - a < b -> - ((forall t:R, forall Ht :a <= t < b, 0 < derive_pt f t (pr t Ht)) -> - forall x y:R, a <= x < b -> a <= y < b -> x < y -> f x < f y) /\ - ((forall t:R, forall Ht : a <= t < b, 0 <= derive_pt f t (pr t Ht)) -> - forall x y:R, a <= x < b -> a <= y < b -> x < y -> f x <= f y). -Proof. -intros a b f pr H; split; intros H0 x y H1 H2 H3. -- rewrite -subR_gt0. - set pr' := pderivable_restrict_right pr (proj1 H1) (proj2 H2) H3. - have H0' : forall t (Ht : x <= t <= y), 0 < derive_pt f t (pr' t Ht). - move=> z /= [Hz0 Hz1]. - by apply H0. - case: (MVT_cor1_pderivable pr' H3); intros x0 [x1 [H7 H8]]. - rewrite H7. - apply mulR_gt0; [by apply H0' | lra]. -- set pr' := pderivable_restrict_right pr (proj1 H1) (proj2 H2) H3. - have H0' : forall t (Ht : x <= t <= y), 0 <= derive_pt f t (pr' t Ht). - move=> z /= [Hz0 Hz1]. - by apply H0. - assert (H4 := MVT_cor1_pderivable pr' H3). - case H4; intros x0 [x1 [H7 H8]]. - rewrite -(add0R (f x)) -leR_subr_addr H7; apply mulR_ge0 => //; lra. -Qed. - -Lemma pderive_increasing_open_closed : - forall (a b:R) (f:R -> R) (pr:pderivable f (fun x => a < x <= b)), - a < b -> - (forall t:R, forall Ht : a < t <= b, 0 <= derive_pt f t (pr t Ht)) -> - forall x y:R, a < x <= b -> a < y <= b -> x <= y -> f x <= f y. -Proof. -move=> a b f pr ab H x y Hx Hy xy. -case: (pderive_increasing_ax_open_closed pr ab) => H1 H2. -case/Rle_lt_or_eq_dec : xy => xy. -- now apply H2. -- rewrite xy; by apply Req_le. -Qed. - -Lemma pderive_increasing_closed_open : - forall (a b:R) (f:R -> R) (pr:pderivable f (fun x => a <= x < b)), - a < b -> - (forall t:R, forall Ht : a <= t < b, 0 <= derive_pt f t (pr t Ht)) -> - forall x y:R, a <= x < b -> a <= y < b -> x <= y -> f x <= f y. -Proof. -move=> a b f pr ab H x y Hx Hy xy. -case: (pderive_increasing_ax_closed_open pr ab) => H1 H2. -case/Rle_lt_or_eq_dec : xy => xy. -apply H2 => //. -subst y. -by apply Req_le. -Qed. - -Lemma pderive_increasing (a b : R) (f : R -> R) - (pr : pderivable f (fun x => a < x <= b)) : - a < b -> - ((forall t:R, forall Ht :a < t <= b, 0 < if t == b then 1 else derive_pt f t (pr t Ht)) -> - forall x y:R, a < x <= b -> a < y <= b -> x < y -> f x < f y). -Proof. -move=> H H0 x y H1 H2 H3. -apply/subR_gt0. -set pr' := pderivable_restrict_left pr (proj1 H1) (proj2 H2) H3. -have H0' : forall t (Ht : x <= t <= y), 0 < if t == y then 1 else derive_pt f t (pr' t Ht). - move=> z /= [Hz0 Hz1]. - case/orP : (orbN (z == y)) => Hcase. - - rewrite Hcase ; lra. - - move/negbTE in Hcase ; rewrite Hcase. - have Hz : a < z <= b. - split. - - apply: (ltR_leR_trans _ Hz0); by apply H1. - - apply: (leR_trans Hz1); by apply H2. - move: (H0 z) => H02. - have Hz2 : ~~ (z == b). - apply/ltR_eqF. - clear Hz0 H1 H3 pr' H H0 x. - move/eqP in Hcase. - apply (@ltR_leR_trans y). - - case (total_order_T z y) ; first case ; move=> Hzy. - - exact Hzy. - - contradict Hcase ; exact Hzy. - - lra. - - by apply H2. - move/negbTE in Hz2. - rewrite Hz2 in H02. - by apply H02. -case: (MVT_cor1_pderivable pr' H3); intros x0 [x1 [H7 H8]]. -rewrite H7. -apply mulR_gt0; last lra. -have Hx0 : ~~ (x0 == y) by rewrite ltR_eqF //; case: H8. -move/negbTE in Hx0. -by move: (H0' x0); rewrite Hx0; exact. -Qed. - -Lemma MVT_cor1_pderivable_closed_continuity f a b : forall (prd : pderivable f (fun x => a < x < b)) (prc : forall x (Hx : a <= x <= b), continuity_pt f x), - a < b -> - exists c (Hc : a < c < b), - f b - f a = derive_pt f c (prd c Hc) * (b - a) /\ a < c < b. -Proof. -intros prd prc ab. -have H0 : forall c : R, a < c < b -> derivable_pt f c. - move=> c Hc. - apply prd. - case: Hc => ? ?; lra. -have H1 : forall c : R, a < c < b -> derivable_pt id c. - move=> c _; by apply derivable_pt_id. -have H2 : forall c, a <= c <= b -> continuity_pt f c. - move=> x Hc. - by apply prc. -have H3 : forall c, a <= c <= b -> continuity_pt id c. - move=> x Hc; by apply derivable_continuous_pt, derivable_pt_id. -case: (MVT f id a b H0 H1 ab H2 H3) => c [Hc H']. -exists c. -exists Hc. -split => //. -cut (derive_pt id c (H1 c Hc) = derive_pt id c (derivable_pt_id c)); - [ intro | apply pr_nu ]. -rewrite H (derive_pt_id c) mulR1 in H'. -rewrite -H' /= /id mulRC. -congr (_ * _). -exact: pr_nu. -Qed. - -Lemma MVT_cor1_pderivable_open_continuity f a b : forall (prd : pderivable f (fun x => a < x < b)) (prca : continuity_pt f a) (prcb : continuity_pt f b), - a < b -> - exists c (Hc : a < c < b), - f b - f a = derive_pt f c (prd c Hc) * (b - a) /\ a < c < b. -Proof. -intros prd prca prcb ab. -have prc : forall x (Hx : a <= x <= b), continuity_pt f x. - move=> x Hx. - case/boolP : (x == a) => [/eqP -> //|/eqP /nesym xnota]. - case/boolP : (x == b) => [/eqP -> //|/eqP xnotb]. - apply derivable_continuous_pt, prd. - split; rewrite ltR_neqAle. - - split => //; exact/(proj1 Hx). - - split => //; exact/(proj2 Hx). -have H0 : forall c : R, a < c < b -> derivable_pt f c. - move=> c Hc. - apply prd. - case: Hc => ? ?; lra. -have H1 : forall c : R, a < c < b -> derivable_pt id c. - move=> c _; by apply derivable_pt_id. -have H2 : forall c, a <= c <= b -> continuity_pt f c. - move=> x Hc. - by apply prc. -have H3 : forall c, a <= c <= b -> continuity_pt id c. - move=> x Hc; by apply derivable_continuous_pt, derivable_pt_id. -case: (MVT f id a b H0 H1 ab H2 H3) => c [Hc H']. -exists c. -exists Hc. -split => //. -cut (derive_pt id c (H1 c Hc) = derive_pt id c (derivable_pt_id c)); - [ intro | apply pr_nu ]. -rewrite H (derive_pt_id c) mulR1 in H'. -rewrite -H' /= /id mulRC. -f_equal. -by apply pr_nu. -Qed. - -Lemma derive_sincreasing_interv a b (f:R -> R) (pr: pderivable f (fun x => a < x < b)) (prc : forall x (Hx : a <= x <= b), continuity_pt f x) : - a < b -> - ((forall t:R, forall (prt : derivable_pt f t), a < t < b -> 0 < derive_pt f t prt) -> - forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y). -Proof. -intros H H0 x y H1 H2 H3. -rewrite -subR_gt0. -have prd' : pderivable f (fun z => x < z < y). - move=> z /= [Hz1 Hz2] ; apply pr. - split. - - apply (@leR_ltR_trans x) => //; by apply H1. - - apply (@ltR_leR_trans y) => //; by apply H2. -have H0' : forall t (Ht : x < t < y), 0 < derive_pt f t (prd' t Ht). - move=> z /= [Hz0 Hz1]. - apply H0. - split. - - apply (@leR_ltR_trans x) => //; by apply H1. - - apply (@ltR_leR_trans y) => //; by apply H2. -have prcx : continuity_pt f x by apply prc; split; apply H1. -have prcy : continuity_pt f y by apply prc; split; apply H2. -have aux : a < b. - apply (@leR_ltR_trans x) ; first by apply H1. - apply (@ltR_leR_trans y) => //; by apply H2. -case: (MVT_cor1_pderivable_open_continuity prd' prcx prcy H3); intros x0 [x1 [H7 H8]]. -rewrite H7. -apply mulR_gt0; first by apply H0'. -by rewrite subR_gt0. -Qed. diff --git a/lib/Reals_ext.v b/lib/Reals_ext.v deleted file mode 100644 index f6ad77d1..00000000 --- a/lib/Reals_ext.v +++ /dev/null @@ -1,635 +0,0 @@ -(* infotheo: information theory and error-correcting codes in Coq *) -(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From HB Require Import structures. -From mathcomp Require Import all_ssreflect. -From mathcomp Require Import all_algebra vector reals normedtype. -From mathcomp Require Import mathcomp_extra boolp. -From mathcomp Require Import Rstruct. -Require Import ssrR realType_ext. -Require Import Reals Lra. -From mathcomp Require Import lra. - -(******************************************************************************) -(* Additional lemmas and definitions about Coq reals *) -(* *) -(* Section reals_ext. *) -(* various lemmas about up, Int_part, frac_part, Rabs define ceil and floor *) -(* *) -(* T ->R^+ == functions that return non-negative reals. *) -(* *) -(* Qplus == type of non-negative rationals *) -(* *) -(* Rpos == type of positive reals *) -(* x%:pos == tries to infer that x : R is actually a Rpos *) -(* *) -(* Rnng == Type of non-negative reals *) -(* x%:nng == tries to infer that x : R is actually a Rnneg *) -(* *) -(******************************************************************************) - -Declare Scope reals_ext_scope. -Delimit Scope R_scope with coqR. - -Reserved Notation "T '->R^+' " (at level 10, format "'[' T ->R^+ ']'"). -Reserved Notation "+| r |" (at level 0, r at level 99, format "+| r |"). -Reserved Notation "x %:pos" (at level 2, format "x %:pos"). -Reserved Notation "x %:nng" (at level 2, format "x %:nng"). - -Notation "+| r |" := (Rmax 0 r) : reals_ext_scope. - -Set Implicit Arguments. -Unset Strict Implicit. -Import Prenex Implicits. - -Arguments INR : simpl never. - -Import Order.Theory GRing.Theory Num.Theory. - -#[export] Hint Extern 0 ((0 <= onem _)%coqR) => - solve [exact/RleP/onem_ge0/RleP] : core. - -Local Open Scope R_scope. -Local Open Scope reals_ext_scope. - -Lemma Rlt_1_2 : 1 < 2. Proof. Lra.lra. Qed. -Global Hint Resolve Rlt_1_2 : core. - -Section reals_ext. - -(* TODO: see Rplus_lt_reg_pos_r in the standard library *) -(*Lemma Rplus_le_lt_reg_pos_r r1 r2 r3 : 0 < r2 -> r1 + r2 <= r3 -> r1 < r3. -Proof. move=> *. lra. Qed.*) - -Lemma INR_Zabs_nat x : (0 <= x)%Z -> (Z.abs_nat x)%:R = IZR x. -Proof. move=> Hx. by rewrite INR_IZR_INZ Zabs2Nat.id_abs Z.abs_eq. Qed. - -Section about_the_pow_function. - -Lemma pow_even_ge0 (n : nat) x : ~~ odd n -> 0 <= x ^ n. -Proof. -move=> Hn; rewrite -(odd_double_half n) (negbTE Hn) {Hn} add0n. -move Hm : (_./2) => m {Hm n}; elim: m => [|m ih]; first by rewrite pow_O. -rewrite doubleS 2!expRS mulRA; apply/mulR_ge0 => //. -rewrite -{2}(pow_1 x) -expRS; exact: pow2_ge_0. -Qed. - -Lemma pow2_Rle_inv a b : 0 <= a -> 0 <= b -> a ^ 2 <= b ^ 2 -> a <= b. -Proof. -move=> Ha Hb H. -apply sqrt_le_1 in H; try exact: pow_even_ge0. -by rewrite /= !mulR1 !sqrt_square in H. -Qed. - -Lemma pow2_Rlt_inv a b : 0 <= a -> 0 <= b -> a ^ 2 < b ^ 2 -> a < b. -Proof. -move=> ? ? H. -apply sqrt_lt_1 in H; try exact: pow_even_ge0. -by rewrite /= !mulR1 !sqrt_square in H. -Qed. - -Lemma x_x2_eq q : q * (1 - q) = / 4 - / 4 * (2 * q - 1) ^ 2. -Proof. field. Qed. - -Lemma x_x2_max q : q * (1 - q) <= / 4. -Proof. -rewrite x_x2_eq. -have : forall a b, 0 <= b -> a - b <= a. move=> *; Lra.lra. -apply; apply mulR_ge0; [Lra.lra | exact: pow_even_ge0]. -Qed. - -End about_the_pow_function. - -Lemma up_pos r : 0 <= r -> (0 < up r)%Z. -Proof. -move=> Hr. -apply lt_IZR => /=. -move/Rgt_lt : (proj1 (archimed r)) => Hr'. -exact: (leR_ltR_trans Hr). -Qed. - -Lemma Rle_up_pos r : 0 <= r -> r <= IZR (Z.abs (up r)). -Proof. -move=> Hr. -rewrite Z.abs_eq; last first. - apply up_pos in Hr. - by apply Z.lt_le_incl. -case: (base_Int_part r). -rewrite /Int_part minus_IZR => _ ?; Lra.lra. -Qed. - -Lemma Rle_up a : a <= IZR (Z.abs (up a)). -Proof. -case: (Rlt_le_dec a 0) => Ha; last by apply Rle_up_pos. -apply (@leR_trans 0); first Lra.lra. -exact/IZR_le/Zabs_pos. -Qed. - -Lemma up_Int_part r : (up r = Int_part r + 1)%Z. -Proof. -case: (base_Int_part r) => H1 H2. -rewrite -(up_tech r (Int_part r)) // plus_IZR //; Lra.lra. -Qed. - -Lemma Int_part_ge0 a : 0 <= a -> (0 <= Int_part a)%Z. -Proof. -move/up_pos => ?; rewrite /Int_part (_ : 0 = Z.succ 0 - 1)%Z //. -apply Z.sub_le_mono => //; exact/Zlt_le_succ. -Qed. - -Lemma frac_part_INR m : frac_part (INR m) = 0. -Proof. -rewrite /frac_part /Int_part -(up_tech _ (Z_of_nat m)). -- by rewrite minus_IZR plus_IZR /= -INR_IZR_INZ; by field. -- rewrite -INR_IZR_INZ. - by apply/RleP; rewrite Order.POrderTheory.lexx. -- rewrite {1}INR_IZR_INZ; apply IZR_lt. - by apply Z.lt_add_pos_r. -Qed. - -Lemma frac_Int_part x : frac_part x = 0 -> IZR (Int_part x) = x. -Proof. -rewrite /frac_part. -set h := IZR _. -move=> H. -by rewrite -(addR0 h) -H Rplus_minus. -Qed. - -Lemma frac_part_mult a b : frac_part a = 0 -> frac_part b = 0 -> - frac_part (a * b) = 0. -Proof. -rewrite /frac_part /Int_part !minus_IZR //. -move=> Ha Hb. -have {}Ha : IZR (up a) = a + 1. - move: Ha. - set x := IZR (up a). - move=> Ha. - rewrite -[X in X = _](add0R _) -Ha. - by field. -have {}Hb : IZR (up b) = b + 1. - move: Hb. - set x := IZR (up b). - move=> Hb. - rewrite -[X in X = _](add0R _) -Hb. - by field. -rewrite -(tech_up _ ((up a - 1) * (up b - 1) + 1)). - rewrite ?plus_IZR ?minus_IZR ?mult_IZR ?minus_IZR // Ha Hb. - by field. - rewrite ?plus_IZR ?minus_IZR ?mult_IZR ?minus_IZR // Ha Hb. - rewrite (_ : forall a, a + 1 - 1 = a); last by move=> *; field. - rewrite (_ : forall a, a + 1 - 1 = a); last by move=> *; field. - Lra.lra. - rewrite ?plus_IZR ?minus_IZR ?mult_IZR ?minus_IZR // Ha Hb. - rewrite (_ : forall a, a + 1 - 1 = a); last by move=> *; field. - rewrite (_ : forall a, a + 1 - 1 = a); last by move=> *; field. - by apply/RleP; rewrite Order.POrderTheory.lexx. -Qed. - -Lemma frac_part_pow a : frac_part a = 0 -> forall n : nat, frac_part (a ^ n) = 0. -Proof. -move=> Ha; elim=> /=. -by rewrite /frac_part (_ : 1 = INR 1) // Int_part_INR subRR. -move=> n IH; exact: frac_part_mult. -Qed. - -Definition ceil (r : R) : Z := if frac_part r == 0 then Int_part r else up r. - -Definition floor : R -> Z := Int_part. - -Lemma floorP (r : R) : r - 1 < IZR (floor r) <= r. -Proof. rewrite /floor; case: (base_Int_part r) => ? ?; split=> //; Lra.lra. Qed. - -Lemma ceilP (r : R) : r <= IZR (ceil r) < r + 1. -Proof. -rewrite /ceil; case: ifPn => [|] /eqP r0. - rewrite frac_Int_part //; Lra.lra. -case: (floorP r); rewrite /floor => H1 /Rle_lt_or_eq_dec[] H2. - rewrite up_Int_part plus_IZR; Lra.lra. -by exfalso; apply/r0; rewrite subR_eq0. -Qed. - -Lemma leR0ceil x : 0 <= x -> (0 <= ceil x)%Z. -Proof. move=> ?; case: (ceilP x) => K _; exact/le_IZR/(leR_trans _ K). Qed. - -Lemma normR_max a b c c' : 0 <= a <= c -> 0 <= b <= c' -> - `| a - b | <= max(c, c'). -Proof. -move=> [H1 H2] [H H3]; case: (Rtotal_order a b) => [H0|[H0|H0]]. -- rewrite distRC gtR0_norm ?subR_gt0 //. - apply: (@leR_trans b); [Lra.lra | apply/(leR_trans H3)/leR_maxr; lra]. -- subst b; rewrite subRR normR0. - exact/(leR_trans H1)/(leR_trans H2)/leR_maxl. -- rewrite geR0_norm; last Lra.lra. - apply: (@leR_trans a); [Lra.lra|exact/(leR_trans H2)/leR_maxl]. -Qed. - -End reals_ext. - -Section rExtrema. -Variables (I : finType) (i0 : I) (F : I -> R). - -Lemma arg_rmax2 : forall j, (F j <= F [arg max_(i > i0) F i]%O)%O. -Proof. -move=> j; case: (@Order.TotalTheory.arg_maxP _ _ I i0 xpredT F isT) => i _. -exact. -Qed. - -End rExtrema. - -Section nneg_finfun. -Variable (T : finType). - -Record nneg_finfun := mkNNFinfun { - nneg_ff :> {ffun T -> R} ; - _ : [forall a, (0 <= nneg_ff a)%mcR] }. - -HB.instance Definition _ := [isSub for nneg_ff]. -HB.instance Definition _ := [Equality of nneg_finfun by <:]. -End nneg_finfun. - - -Section nneg_finfun. (* Reals_ext.v *) -Local Open Scope R_scope. - -Lemma nneg_finfun_ge0 (I : finType) (f : nneg_finfun I) i : (0 <= f i)%mcR. -Proof. by case: f => /= f /forallP /(_ i). Qed. - -Lemma nneg_finfun_le0 (I : finType) (F : nneg_finfun I) i : - (F i == 0) = (F i <= 0)%mcR. -Proof. -apply/idP/idP => [/eqP -> //|]. -case: F => F /= /forallP /(_ i). -by rewrite eq_le coqRE => -> ->. -Qed. - -Fail Check F : pos_fun _. (* Why no coercion pos_ffun >-> pos_fun? *) - -Lemma pos_ffun_bigmaxR0P (I : finType) (r : seq I) (P : pred I) (F : nneg_finfun I) : - reflect (forall i : I, i \in r -> P i -> F i = 0) - (\rmax_(i <- r | P i) F i == 0). -Proof. -apply: (iffP idP) => [/eqP H i ir Pi|H]. -- apply/eqP; rewrite nneg_finfun_le0 -coqRE -H. - rewrite -big_filter; apply/RleP; apply: leR_bigmaxR. - by rewrite mem_filter ir Pi. -- rewrite -big_filter big_seq. - under eq_bigr=> i do rewrite mem_filter=> /andP [] /[swap] /(H i) /[apply] ->. - by rewrite -big_seq big_const_seq iter_fix // maxRR. -Qed. - -Lemma nnegP (U : finType) (C : {ffun U -> R}) : - (forall u : U, 0 <= C u) -> [forall a, (0 <= C a)%mcR]. -Proof. by move=> h; apply/forallP => u; apply/RleP. Qed. - -Definition Cpos_fun (U : finType) (C : nneg_finfun U) - (h : forall u : U, 0 <= C u) : nneg_finfun U := - mkNNFinfun (nnegP h). - -End nneg_finfun. - -Record nneg_fun (T : Type) := mkNNFun { - nneg_f :> T -> R ; - nneg_f_ge0 : forall a, 0 <= nneg_f a }. - -Notation "T '->R^+' " := (nneg_fun T) : reals_ext_scope. - -#[global] Hint Extern 0 (Rle (IZR Z0) _) => solve [exact/RleP/prob_ge0] : core. -#[global] Hint Extern 0 (Rle _ (IZR (Zpos xH))) => solve [exact/RleP/prob_le1] : core. - -Lemma prob_IZR_subproof (p : positive) : (0 <= / IZR (Zpos p) <= 1)%O. -Proof. -have [/RleP ? /RleP ?] : (0 <= / IZR (Zpos p) <= 1)%coqR. - split; first exact/Rlt_le/Rinv_0_lt_compat/IZR_lt/Pos2Z.is_pos. - rewrite -[X in (_ <= X)%coqR]Rinv_1; apply Rle_Rinv => //. - - exact/IZR_lt/Pos2Z.is_pos. - - exact/IZR_le/Pos2Z.pos_le_pos/Pos.le_1_l. -exact/andP. -Qed. - -Canonical probIZR (p : positive) := Eval hnf in Prob.mk (prob_IZR_subproof p). - -Definition divRnnm n m := n%:R / (n + m)%:R. - -Lemma prob_divRnnm_subproof n m : (R0 <= divRnnm n m <= R1)%O. -Proof. -apply/andP; split. - by rewrite /divRnnm RdivE divr_ge0// INRE ler0n. -rewrite /divRnnm RdivE !INRE. -have [/eqP ->|n0] := boolP (n == O). - by rewrite mul0r ler01. -rewrite ler_pdivrMr// ?ltr0n ?addn_gt0; last first. - by rewrite lt0n n0. -by rewrite mul1r ler_nat leq_addr. -Qed. - -Canonical probdivRnnm (n m : nat) := - Eval hnf in @Prob.mk _ (divRnnm n m) (prob_divRnnm_subproof n m). - -Lemma prob_invn (m : nat) : (R0 <= / (1 + m)%:R <= R1)%mcR. -Proof. -rewrite -(mul1R (/ _)%coqR) (_ : 1%coqR = INR 1) // -/(Rdiv _ _). -exact: prob_divRnnm_subproof. -Qed. - -Canonical probinvn (n : nat) := - Eval hnf in @Prob.mk _ (/ (1 + n)%:R) (prob_invn n). - -Lemma prob_invp_subproof (p : {prob R}) : (0 <= 1 / (1 + Prob.p p) <= 1)%O. -Proof. -apply/andP; split. - by rewrite RdivE mul1r invr_ge0 ?addr_ge0. -rewrite RdivE mul1r invf_le1//. - by rewrite lerDl. -rewrite (@lt_le_trans _ _ 1)//. -by rewrite lerDl. -Qed. - -Definition Prob_invp (p : {prob R}) := Prob.mk (prob_invp_subproof p). - -Lemma prob_mulR_subproof (p q : {prob R}) : (0 <= Prob.p p * Prob.p q <= 1)%O. -Proof. -apply/andP; split. - by rewrite mulr_ge0. -by rewrite mulr_ile1. -Qed. - -Canonical probmulR (p q : {prob R}) := - Eval hnf in @Prob.mk _ (Prob.p p * Prob.p q) (prob_mulR_subproof p q). - -(*Module OProb. -Section def. -Record t := mk { - p :> {prob R}; - Op1 : (0 -> prob. - -Canonical oprobcplt (p : oprob) := Eval hnf in OProb.mk (onem_oprob (OProb.O1 p)). *) -Coercion OProb.p : oprob >-> prob. - -Section oprob_lemmas. -Implicit Types p q : {oprob R}. - -Lemma oprob_gt0 p : 0 < Prob.p (OProb.p p). -Proof. by case: p => p /= /andP [] /RltP. Qed. - -Lemma oprob_lt1 p : Prob.p (OProb.p p) < 1. -Proof. by case: p => p /= /andP [] _ /RltP. Qed. - -Lemma oprob_ge0 p : 0 <= Prob.p (OProb.p p). Proof. exact/ltRW/oprob_gt0. Qed. - -Lemma oprob_le1 p : Prob.p (OProb.p p) <= 1. Proof. exact/ltRW/oprob_lt1. Qed. - -Lemma oprob_neq0 p : Prob.p (OProb.p p) != 0 :> R. -Proof. by move:(oprob_gt0 p); rewrite ltR_neqAle=> -[] /nesym /eqP. Qed. - -Lemma oprob_neq1 p : Prob.p (OProb.p p) != 1 :> R. -Proof. by move:(oprob_lt1 p); rewrite ltR_neqAle=> -[] /eqP. Qed. - -Lemma oprobK (p : {oprob R}) : p = ((Prob.p (OProb.p p)).~).~%:opr. -Proof. by apply/val_inj/val_inj=> /=; rewrite onemK. Qed. - -Lemma prob_trichotomy' (p : {prob R}) (P : {prob R} -> Prop) : - P 0%:pr -> P 1%:pr -> (forall o : {oprob R}, P o) -> P p. -Proof. -move=> p0 p1 po. -have [-> //|[->//| p01]] := prob_trichotomy p. -exact (po (OProb.mk p01)). -Qed. - -Lemma oprobadd_gt0 p q : 0 < Prob.p (OProb.p p) + (Prob.p (OProb.p q)). -Proof. exact/addR_gt0/oprob_gt0/oprob_gt0. Qed. - -Lemma oprobadd_neq0 p q : Prob.p (OProb.p p) + Prob.p (OProb.p q) != 0%coqR. -Proof. by move: (oprobadd_gt0 p q); rewrite ltR_neqAle => -[] /nesym /eqP. Qed. - -End oprob_lemmas. - -Lemma oprob_divRnnm n m : (0 < n)%nat -> (0 < m)%nat -> (0 < divRnnm n m < 1)%coqR. -Proof. -rewrite /divRnnm. -split; first by apply divR_gt0; [rewrite ltR0n | rewrite ltR0n addn_gt0 H orTb]. -rewrite ltR_pdivr_mulr ?mul1R ?ltR_nat // ?ltR0n ?addn_gt0 ?H ?orTb //. -by rewrite -[X in (X < _)%nat](addn0 n) ltn_add2l. -Qed. - -Lemma oprob_mulR_subproof (p q : {oprob R}) : (0 < Prob.p (OProb.p p) * Prob.p (OProb.p q) < 1)%O. -Proof. -apply/andP; split. - by rewrite mulr_gt0//; apply/RltP/oprob_gt0. -by rewrite mulr_ilt1//; apply/RltP/oprob_lt1. -Qed. - -Canonical oprobmulR (p q : {oprob R}) := - Eval hnf in @OProb.mk R (probmulR p q) (oprob_mulR_subproof p q). - -Lemma s_of_pq_oprob_subproof (p q : {oprob R}) : (0 < Prob.p [s_of p, q] < 1)%O. -Proof. -rewrite s_of_pqE; apply/andP; split. -- rewrite onem_gt0//= mulr_ilt1 ?onem_ge0 ?onem_lt1//. - by have /andP[] := OProb.O1 p. - by have /andP[] := OProb.O1 q. -- rewrite onem_lt1// mulr_gt0// onem_gt0//. - by have /andP[] := OProb.O1 p. - by have /andP[] := OProb.O1 q. -Qed. - -Canonical oprob_of_s_of_pq (p q : {oprob R}) := - Eval hnf in OProb.mk (s_of_pq_oprob_subproof p q). - -Lemma s_of_gt0_oprob (p : {oprob R}) (q : {prob R}) : 0 < Prob.p [s_of p, q]. -Proof. by apply/RltP; rewrite s_of_gt0//; exact/oprob_neq0. Qed. - -Lemma r_of_pq_oprob_subproof (p q : {oprob R}) : (0 < Prob.p [r_of OProb.p p, OProb.p q] < 1)%O. -Proof. -rewrite r_of_pqE; apply/andP; split. - rewrite divr_gt0////. - exact/RltP/oprob_gt0. - rewrite s_of_pqE//. - have := OProb.O1 (oprobcplt (oprobmulR (oprobcplt p) (oprobcplt q))). - by move/andP=> [] /=. -apply/RltP. -rewrite -RdivE. -rewrite ltR_pdivr_mulr ?mul1R; last by apply/(oprob_gt0). -rewrite ltR_neqAle; split; last exact/RleP/ge_s_of. -rewrite s_of_pqE; apply/eqP/ltR_eqF. -rewrite onemM !onemK -!RplusE -RoppE -addRA. -apply/ltR_addl. -have := oprob_gt0 (oprobmulR (oprobcplt p) q). -by rewrite /= onemE mulrBl mul1r -RminusE//. -Qed. - -Canonical oprob_of_r_of_pq (p q : {oprob R}) := - Eval hnf in OProb.mk (r_of_pq_oprob_subproof p q). - -Lemma r_of_p0_oprob (p : {oprob R}) : [r_of OProb.p p, 0%:pr] = 1%:pr. -Proof. by apply/r_of_p0/oprob_neq0. Qed. - -Record Qplus := mkRrat { num : nat ; den : nat }. - -Definition Q2R (q : Qplus) := INR (num q) / INR (den q).+1. - -Coercion Q2R : Qplus >-> R. - -Module Rpos. -Record t := mk { - v : R ; - H : (v > 0)%mcR }. -Definition K (r : t) := H r. -Arguments K : simpl never. -Module Exports. -Notation Rpos := t. -Notation "r %:pos" := (@mk r (@K _)) : reals_ext_scope. -Coercion v : Rpos >-> R. -End Exports. -End Rpos. -Export Rpos.Exports. - -HB.instance Definition _ := [isSub for Rpos.v]. -HB.instance Definition _ := [Choice of Rpos by <:]. - -Definition rpos_coercion (p : Rpos) : Real.sort R := Rpos.v p. -Coercion rpos_coercion : Rpos >-> Real.sort. - -Definition mkRpos x H := @Rpos.mk x (introT (RltP _ _) H). - -Canonical Rpos1 := @mkRpos 1 Rlt_0_1. - -Lemma Rpos_gt0 (x : Rpos) : 0 < x. Proof. by case: x => p /= /RltP. Qed. -Global Hint Resolve Rpos_gt0 : core. - -Lemma Rpos_neq0 (x : Rpos) : val x != 0. -Proof. by case: x => p /=; rewrite /RltP lt0r => /andP[]. Qed. - -Lemma addRpos_gt0 (x y : Rpos) : ((x + y)%coqR > 0)%mcR. -Proof. exact/RltP/addR_gt0. Qed. -Canonical addRpos x y := Rpos.mk (addRpos_gt0 x y). - -Lemma mulRpos_gt0 (x y : Rpos) : ((x * y)%coqR > 0)%mcR. -Proof. exact/RltP/mulR_gt0. Qed. -Canonical mulRpos x y := Rpos.mk (mulRpos_gt0 x y). - -Lemma divRpos_gt0 (x y : Rpos) : (((x : R) / (y : R))%coqR > 0)%mcR. -Proof. exact/RltP/divR_gt0. Qed. -Canonical divRpos x y := Rpos.mk (divRpos_gt0 x y). - -(* TODO: Canonical oprob_Rpos (p : oprob) := @mkRpos p (oprob_gt0 p). *) - -Lemma oprob_divRposxxy (x y : Rpos) : (0 < x / (x + y) < 1)%coqR. -Proof. -split; first by apply/divR_gt0. -rewrite ltR_pdivr_mulr ?mul1R; last exact/RltP/addRpos_gt0. -by rewrite ltR_addl. -Qed. - -Lemma oprob_divRposxxy' (x y : Rpos) : (0 < x / (x + y) < 1)%O. -Proof. -have [/RltP ? /RltP ?] := oprob_divRposxxy x y. exact/andP. -Qed. - -Lemma prob_divRposxxy (x y : Rpos) : (0 <= x / (x + y) <= 1)%coqR. -Proof. -have [] := oprob_divRposxxy x y. -move/RltP/Order.POrderTheory.ltW/RleP => ?. -move/RltP/Order.POrderTheory.ltW/RleP => ?. -by []. -Qed. - -Lemma prob_divRposxxy' (x y : Rpos) : (0 <= x / (x + y) <= 1)%O. -Proof. -have [/RleP ? /RleP ?] := prob_divRposxxy x y. exact/andP. -Qed. - -Canonical divRposxxy (x y : Rpos) := - Eval hnf in Prob.mk (prob_divRposxxy' x y). - -Lemma divRposxxyC r q : divRposxxy q r = (Prob.p (divRposxxy r q)).~%:pr. -Proof. -apply val_inj => /=; rewrite [in RHS]addRC. -rewrite [in RHS]RdivE onem_div// ?addrK//. - by rewrite RplusE RdivE. -exact: Rpos_neq0. -Qed. - -Lemma onem_divRxxy (r q : Rpos) : (rpos_coercion r / (rpos_coercion r + q)).~ = q / (q + r). -Proof. -rewrite /onem; apply/eqP; rewrite subr_eq. -rewrite !RplusE (addrC (r : R)) RdivE -mulrDl divff//. -by rewrite gtR_eqF//; apply: addR_gt0. -Qed. - -Module Rnng. -Local Open Scope R_scope. -Record t := mk { - v : R ; - H : (0 <= v)%mcR }. -Definition K (r : t) := H r. -Arguments K : simpl never. -Module Exports. -Notation Rnng := t. -Notation "r %:nng" := (@mk r (@K _)). -Coercion v : t >-> R. -End Exports. -End Rnng. -Export Rnng.Exports. - -HB.instance Definition _ := [isSub for Rnng.v]. -HB.instance Definition _ := [Choice of Rnng by <:]. - -Section Rnng_theory. -Local Open Scope R_scope. - -Definition mkRnng x H := @Rnng.mk x (introT (RleP _ _) H). - -Lemma Rnng_ge0 (x : Rnng) : 0 <= x. -Proof. by case: x => p /= /RleP. Qed. -Local Hint Resolve Rnng_ge0 : core. - -Canonical Rnng0 := Eval hnf in @mkRnng 0 (Rle_refl 0). -Canonical Rnng1 := Eval hnf in @mkRnng R1 Rle_0_1. - -Lemma addRnng_ge0 (x y : Rnng) : (0 <= (x : R) + y)%mcR. -Proof. exact/RleP/addR_ge0. Qed. -Canonical addRnneg x y := Rnng.mk (addRnng_ge0 x y). - -Lemma mulRnng_ge0 (x y : Rnng) : (0 <= (x : R) * y)%mcR. -Proof. exact/RleP/mulR_ge0. Qed. -Canonical mulRnneg x y := Rnng.mk (mulRnng_ge0 x y). - -End Rnng_theory. - -Global Hint Resolve Rnng_ge0 : core. - -Lemma s_of_Rpos_probA (p q r : Rpos) : - [s_of (p / (p + (q + r)))%:pos%:pr, (q / (q + r))%:pos%:pr] = - ((p + q) / (p + q + r))%:pos%:pr. -Proof. -apply val_inj; rewrite /= s_of_pqE /onem /=. -rewrite -!RminusE. -rewrite (_ : 1%mcR = 1)// -RmultE. -field. -by split; exact/eqP/Rpos_neq0. -Qed. - -Lemma r_of_Rpos_probA (p q r : Rpos) : - [r_of (p / (p + (q + r)))%:pos%:pr, (q / (q + r))%:pos%:pr] = - (p / (p + q))%:pos%:pr. -Proof. -apply/val_inj; rewrite /= r_of_pqE s_of_pqE /onem /=. -rewrite -!RminusE -R1E -!RmultE -!RinvE. -field. -do 3 (split; first exact/eqP/Rpos_neq0). -rewrite (addRC p (q + r)) addRK {4}[in q + r]addRC addRK. -rewrite mulRC -mulRBr (addRC _ p) addRA addRK mulR_neq0. -by split; exact/eqP/Rpos_neq0. -Qed. diff --git a/lib/bigop_ext.v b/lib/bigop_ext.v index 1a6cbcee..d6e4ed8d 100644 --- a/lib/bigop_ext.v +++ b/lib/bigop_ext.v @@ -1,7 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum matrix lra. -Require Import (*ssrR Reals_ext*) logb ssr_ext ssralg_ext. +From mathcomp Require boolp. +Require Import ssr_ext ssralg_ext. (******************************************************************************) (* Additional lemmas about bigops *) @@ -11,6 +12,14 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. +Lemma morph_oppr {R : ringType} : {morph @GRing.opp R : x y / (x + y)%R : R}. +Proof. by move=> x y /=; rewrite GRing.opprD. Qed. + +Lemma morph_mulRDr {R : ringType} a : {morph (GRing.mul a) : x y / (x + y)%R : R}. +Proof. by move=> * /=; rewrite GRing.mulrDr. Qed. + +Definition big_morph_oppr {R : ringType} := big_morph _ morph_oppr (@GRing.oppr0 R). + Section bigop_no_law. Variables (R : Type) (idx : R) (op : R -> R -> R). @@ -621,3 +630,75 @@ by move/ih => [u ut Fu0]; exists u => //; rewrite inE ut orbT. Qed. End real. + +Section order. +Import classical.mathcomp_extra Order.Theory. +Local Open Scope ring_scope. +Local Open Scope order_scope. + +Lemma bigmax_le_seq disp (T : porderType disp) (I : eqType) (r : seq I) (f : I -> T) + (x0 x : T) (PP : pred I) : + (x0 <= x)%O -> + (forall i : I, i \in r -> PP i -> (f i <= x)%O) -> + (\big[Order.max/x0]_(i <- r | PP i) f i <= x)%O. +Proof. +move=> x0x cond; rewrite big_seq_cond bigmax_le // => ? /andP [? ?]; exact: cond. +Qed. + +(* seq version of order.bigmax_leP *) +Lemma bigmax_leP_seq disp (T : orderType disp) (I : eqType) (r : seq I) (F : I -> T) + (x m : T) (PP : pred I) : +reflect ((x <= m)%O /\ (forall i : I, i \in r -> PP i -> (F i <= m)%O)) + (\big[Order.max/x]_(i <- r | PP i) F i <= m)%O. +Proof. +apply:(iffP idP); last by case; exact:bigmax_le_seq. +move=> bm; split; first by exact/(le_trans _ bm)/bigmax_ge_id. +by move=> *; exact/(le_trans _ bm)/le_bigmax_seq. +Qed. + +Section classical. +Import boolp. +Lemma bigmax_gt0P_seq (T : realDomainType) (A : eqType) (F : A -> T) + (s : seq A) (PP : pred A) : +reflect (exists i : A, [/\ i \in s, PP i & (0 < F i)%O]) (0 < \big[Num.max/0]_(m <- s | PP m) F m). +Proof. +rewrite ltNge. +apply:(iffP idP). + move=> /bigmax_leP_seq /not_andP []; first by rewrite lexx. + move=> /existsNP [] x /not_implyP [] xs /not_implyP [] PPx /negP. + rewrite -ltNge=> Fx0. + by exists x; repeat (split=> //). +case=> x [] ? ? ?; apply/bigmax_leP_seq/not_andP; right. +apply/existsNP; exists x; do 2 (apply/not_implyP; split=> //). +by apply/negP; rewrite -ltNge. +Qed. +End classical. + +End order. + +Section big_union. + +Definition big_union_disj := big_union. + +(* TODO: this is more generic and should be called big_union *) +Lemma big_union_nondisj (R : Type) (idx : R) (M : Monoid.com_law idx) + (A : finType) (X1 X2 : {set A}) (f : A -> R) : + \big[M/idx]_(a in (X1 :&: X2)) f a = idx -> + \big[M/idx]_(a in (X1 :|: X2)) f a = + M (\big[M/idx]_(a in X1) f a) (\big[M/idx]_(a in X2) f a). +Proof. +move=> I0. +rewrite -setIUY big_union_disj 1?disjoint_sym ?setIYI_disj //. +rewrite I0 Monoid.opm1 big_union_disj; last first. + by rewrite -setI_eq0 setIDA setIC Order.SetSubsetOrder.setIDv // set0D. + (* Order.SetSubsetOrder.setIDv is B :&: (A :\: B) = set0 *) +set lhs := LHS. +rewrite -(setID X1 X2) big_union_disj; last first. + by rewrite -setI_eq0 setIC -setIA Order.SetSubsetOrder.setIDv // setI0. +rewrite I0 Monoid.op1m. +rewrite -[in X in M _ X](setID X2 X1) big_union_disj; last first. + by rewrite -setI_eq0 setIC -setIA Order.SetSubsetOrder.setIDv // setI0. +by rewrite setIC I0 Monoid.op1m. +Qed. + +End big_union. diff --git a/lib/binary_entropy_function.v b/lib/binary_entropy_function.v index 1f170fd2..92005f57 100644 --- a/lib/binary_entropy_function.v +++ b/lib/binary_entropy_function.v @@ -1,8 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect. -Require Import Reals Lra. -Require Import ssrR Reals_ext Ranalysis_ext logb. +From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp Require Import Rstruct reals exp lra. +Require Import ssr_ext realType_ext realType_ln. (******************************************************************************) (* The natural entropy function *) @@ -21,11 +21,13 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. +Local Open Scope ring_scope. -Definition H2ln := fun p => - p * ln p - (1 - p) * ln (1 - p). +Import Order.POrderTheory GRing.Theory Num.Theory. -Lemma derivable_pt_ln_Rminus x : x < 1 -> derivable_pt ln (1 - x). +Definition H2ln {R : realType} : R -> R := fun p : R => (- p * exp.ln p - (1 - p) * exp.ln (1 - p))%mcR. + +(*Lemma derivable_pt_ln_Rminus x : x < 1 -> derivable_pt ln (1 - x). Proof. move=> Hx. exists (/ (1 - x)). @@ -122,10 +124,11 @@ case: (Rlt_le_dec q (1/2)) => [H1|]. lra. by apply decreasing_on_half_to_1 => //; lra. Qed. +*) -Definition H2 p := - (p * log p) + - ((1 - p) * log (1 - p)). +Definition H2 {R : realType} (p : R) : R := (- (p * log p) + - ((1 - p) * log (1 - p)))%mcR. -Lemma bin_ent_0eq0 : H2 0 = 0. +(*Lemma bin_ent_0eq0 : H2 0 = 0. Proof. rewrite /H2 /log. by rewrite !(Log_1, mulR0, mul0R, oppR0, mul1R, mulR1, add0R, addR0, subR0). @@ -137,20 +140,26 @@ rewrite /H2 /log. by rewrite !(Log_1, mulR0, mul0R, oppR0, mul1R, mulR1, add0R, addR0, subR0, subRR). Qed. +*) -Lemma H2_max : forall p, 0 < p < 1 -> H2 p <= 1. +(* +Lemma H2_max : forall p : Rdefinitions.R, 0 < p < 1 -> H2 p <= 1. Proof. -move=> p [Hp0 Hp1]. +move=> p /andP[Hp0 Hp1]. rewrite /H2. -apply (@leR_pmul2l (ln 2)) => //. -rewrite mulR1 mulRDr /log -!mulNR !(mulRC (ln 2)) -!mulRA. -rewrite (mulVR _ ln2_neq0) !mulR1 (mulNR (1 - p)); exact/H2ln_max. +rewrite -(@ler_pM2l _ (ln 2))// ?ln2_gt0//. +rewrite mulr1 mulrDr /log -!mulNr !(mulrC (ln 2)) -!mulrA. +rewrite (@mulVf _ _ ln2_neq0) !mulr1 (mulNr (1 - p)). + +; exact/H2ln_max. Qed. +*) -Lemma H2_max' (x : R): 0 <= x <= 1 -> H2 x <= 1. +(*Lemma H2_max' (x : R): 0 <= x <= 1 -> H2 x <= 1. Proof. move=> [x_0 x_1]. case: x_0 => [?|<-]; last by rewrite bin_ent_0eq0. case: x_1 => [?|->]; last by rewrite bin_ent_1eq0. exact: H2_max. Qed. +*) diff --git a/lib/coqRE.v b/lib/coqRE.v new file mode 100644 index 00000000..902897b6 --- /dev/null +++ b/lib/coqRE.v @@ -0,0 +1,35 @@ +(* infotheo: information theory and error-correcting codes in Coq *) +(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) +From HB Require Import structures. +From mathcomp Require Import all_ssreflect ssralg ssrnum. +Require Import Reals. +From mathcomp Require Import lra. +From mathcomp Require Import Rstruct. + +Local Open Scope R_scope. +Delimit Scope ring_scope with mcR. + +Import Order.POrderTheory GRing.Theory Num.Theory. + +Delimit Scope R_scope with coqR. + +Lemma R1E : 1%coqR = 1%mcR. Proof. by []. Qed. +Lemma R0E : 0%coqR = 0%mcR. Proof. by []. Qed. + +(* NB: PR https://github.com/math-comp/analysis/pull/1461 in progress in MCA *) +Lemma RsqrtE' (x : Rdefinitions.R) : sqrt x = Num.sqrt x. +Proof. +set Rx := Rcase_abs x. +have RxE: Rx = Rcase_abs x by []. +rewrite /sqrt. +rewrite -RxE. +move: RxE. +case: Rcase_abs=> x0 RxE. + by rewrite RxE; have/RltP/ltW/ler0_sqrtr-> := x0. +rewrite /Rx -/(sqrt _) RsqrtE //. +by have/Rge_le/RleP:= x0. +Qed. + +Definition coqRE := + (R0E, R1E, INRE, IZRposE, + RinvE, RoppE, RdivE, RminusE, RplusE, RmultE, RpowE, RsqrtE'). diff --git a/lib/derive_ext.v b/lib/derive_ext.v new file mode 100644 index 00000000..4e209d09 --- /dev/null +++ b/lib/derive_ext.v @@ -0,0 +1,253 @@ +(* infotheo: information theory and error-correcting codes in Coq *) +(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) +From mathcomp Require Import all_ssreflect ssralg ssrnum interval. +From mathcomp Require Import ring lra. +From mathcomp Require Import mathcomp_extra boolp classical_sets functions. +From mathcomp Require Import set_interval. +From mathcomp Require Import reals Rstruct topology normedtype. +From mathcomp Require Import realfun derive exp. +Require Import realType_ext ssralg_ext. + +(******************************************************************************) +(* Additional lemmas about differentiation and derivatives *) +(* *) +(* Variants of lemmas (mean value theorem, etc.) from mathcomp-analysis *) +(* *) +(* TODO: document lemmas *) +(* *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import Order.TTheory GRing.Theory Num.Theory. +Import numFieldTopology.Exports. +Import numFieldNormedType.Exports. + +Local Open Scope ring_scope. + +Section is_derive. + +Lemma is_deriveD_eq [R : numFieldType] [V W : normedModType R] [f g : V -> W] + [x v : V] [Df Dg D : W] : + is_derive x v f Df -> is_derive x v g Dg -> Df + Dg = D -> + is_derive x v (f + g) D. +Proof. by move=> ? ? <-; exact: is_deriveD. Qed. + +Lemma is_deriveB_eq [R : numFieldType] [V W : normedModType R] [f g : V -> W] + [x v : V] [Df Dg D : W] : + is_derive x v f Df -> is_derive x v g Dg -> Df - Dg = D -> + is_derive x v (f - g) D. +Proof. by move=> ? ? <-; exact: is_deriveB. Qed. + +Lemma is_deriveN_eq [R : numFieldType] [V W : normedModType R] [f : V -> W] + [x v : V] [Df D : W] : + is_derive x v f Df -> - Df = D -> is_derive x v (- f) D. +Proof. by move=> ? <-; exact: is_deriveN. Qed. + +Lemma is_deriveM_eq [R : numFieldType] [V : normedModType R] [f g : V -> R] + [x v : V] [Df Dg D : R] : + is_derive x v f Df -> is_derive x v g Dg -> + f x *: Dg + g x *: Df = D -> + is_derive x v (f * g) D. +Proof. by move=> ? ? <-; exact: is_deriveM. Qed. + +Lemma is_deriveV_eq [R : realType] [f : R -> R] [x v Df D : R] : + f x != 0 -> + is_derive x v f Df -> + - f x ^- 2 *: Df = D -> + is_derive x v (inv_fun f) D. +Proof. by move=> ? ? <-; exact: is_deriveV. Qed. + +Lemma is_deriveZ_eq [R : numFieldType] [V W : normedModType R] [f : V -> W] + (k : R) [x v : V] [Df D : W] : + is_derive x v f Df -> k *: Df = D -> + is_derive x v (k \*: f) D. +Proof. by move=> ? <-; exact: is_deriveZ. Qed. + +Lemma is_deriveX_eq [R : numFieldType] [V : normedModType R] [f : V -> R] + (n : nat) [x v : V] [Df D: R] : + is_derive x v f Df -> (n.+1%:R * f x ^+ n) *: Df = D -> + is_derive x v (f ^+ n.+1) D. +Proof. by move=> ? <-; exact: is_deriveX. Qed. + +Lemma is_derive_sum_eq [R : numFieldType] [V W : normedModType R] [n : nat] + [h : 'I_n -> V -> W] [x v : V] [Dh : 'I_n -> W] [D : W] : + (forall i : 'I_n, is_derive x v (h i) (Dh i)) -> + \sum_(i < n) Dh i = D -> + is_derive x v (\sum_(i < n) h i) D. +Proof. by move=> ? <-; exact: is_derive_sum. Qed. + +Lemma is_derive1_lnf [R : realType] [f : R -> R] [x Df : R] : + is_derive x 1 f Df -> 0 < f x -> + is_derive x 1 (ln (R := R) \o f) (Df / f x). +Proof. +move=> hf fx0. +rewrite mulrC; apply: is_derive1_comp. +exact: is_derive1_ln. +Qed. + +Lemma is_derive1_lnf_eq [R : realType] [f : R -> R] [x Df D : R] : + is_derive x 1 f Df -> 0 < f x -> + Df / f x = D -> + is_derive x 1 (ln (R := R) \o f) D. +Proof. by move=> ? ? <-; exact: is_derive1_lnf. Qed. + + +End is_derive. + +Section near_eq. + +Lemma open_norm_subball (R : numFieldType) (M : normedModType R) + (A : set M) (x : M) : + open A -> A x -> + \forall e \near ((0 : R)^')%classic, (ball x `|e| `<=` A)%classic. +Proof. +move/(@conj (open A) _)/[apply]/open_nbhs_nbhs/nbhsr0P. +rewrite -!nbhs_nearE=> H. +under [X in nbhs _ X]funext=> e. + rewrite /subset. + under eq_forall=> y do rewrite -ball_normE /=. + over. +case: H=> e /= e0 He. +exists e=> //= e' /=. +rewrite distrC subr0=> e'e e'0 y xye'. +apply: (He `|e'|). +- by rewrite /= distrC subr0 normr_id. +- by rewrite normr_gt0. +- exact: ltW. +Qed. + +Local Notation DQ f v a h := (h^-1 *: (f (h *: v + a) - f a)). + +Let near_eq_difference_quotient (R : numFieldType) (V W : normedModType R) + (f g : V -> W) (a v : V) : + v != 0 -> (\near a, f a = g a) -> + \forall h \near nbhs (0^')%classic, DQ f v a h = DQ g v a h. +Proof. +move=> vn0 fg. +have fg0: \forall h \near (0^')%classic, f (h *: v + a) = g (h *: v + a). + have:= fg. + rewrite -!nbhs_nearE nbhsE => -[] U [] oU Ua Ufg. + have:= open_norm_subball oU Ua; case=> e /= e0 eU. + exists (e * `|2 *: v|^-1)=> /=. + rewrite mulr_gt0// invr_gt0 normrZ mulr_gt0// ?(normr_gt0 v)//. + by rewrite normr_nat ltr0Sn. + move=> h /= /[1!distrC] /[!subr0] he2v h0. + apply/(Ufg (h *: v + a))/(eU (h * `| 2 *: v|)). + - rewrite /= distrC subr0 normrM normr_id -ltr_pdivlMr//. + rewrite normrZ mulr_gt0// ?(normr_gt0 v)//. + by rewrite normr_nat ltr0Sn. + - rewrite mulf_neq0// normrZ. + rewrite mulf_neq0// normr_eq0//. + by rewrite pnatr_eq0. + - rewrite -ball_normE /=. + rewrite opprD addrCA subrr addr0 normrN !normrZ !normr_id. + rewrite mulrCA ltr_pMl// ?mulr_gt0// ?normr_gt0//. + by rewrite [ltLHS](_ : 1 = 1%:R)// normr_nat ltr_nat. +have:= fg0 => /filterS; apply=> h ->. +move: fg. +by rewrite -nbhs_nearE nbhsE=> -[] U [] oU Ua /(_ a Ua) ->. +Qed. + +Lemma near_eq_derive (R : numFieldType) (V W : normedModType R) + (f g : V -> W) (a v : V) : + v != 0 -> (\near a, f a = g a) -> 'D_v f a = 'D_v g a. +Proof. +move=> vn0 fg. +rewrite /derive. +suff-> : (DQ f v a h @[h --> 0^'])%classic = (DQ g v a h @[h --> 0^'])%classic + by []. +have Dfg := near_eq_difference_quotient vn0 fg. +rewrite eqEsubset; split; apply: near_eq_cvg=> //. +by move/filterS: Dfg; apply=> ?; exact: fsym. +Qed. + +Lemma near_eq_derivable (R : numFieldType) (V W : normedModType R) + (f g : V -> W) (a v : V) : + v != 0 -> (\near a, f a = g a) -> derivable f a v = derivable g a v. +Proof. +move=> vn0 nfg. +rewrite /derivable. +suff-> : (DQ f v a h @[h --> 0^'])%classic = (DQ g v a h @[h --> 0^'])%classic + by []. +have Dfg := near_eq_difference_quotient vn0 nfg. +rewrite eqEsubset; split; apply: near_eq_cvg=> //. +by move/filterS: Dfg; apply=> ?; exact: fsym. +Qed. + +Lemma near_eq_is_derive (R : numFieldType) (V W : normedModType R) + (f g : V -> W) (a v : V) (df : W) : + v != 0 -> (\near a, f a = g a) -> + is_derive a v f df = is_derive a v g df. +Proof. +move=> vn0; move: f g. +suff fg f g (nfg : \near a, f a = g a) : + is_derive a v f df -> is_derive a v g df. + move=> f g nfg; apply: propext; split; apply: fg => //. + suff->: (\near a, g a = f a) = (\near a, f a = g a) by []. + by apply: eq_near=> ?; split; exact: esym. +move/[dup]/@ex_derive=> H. +move/@derive_val<-. +rewrite (near_eq_derive vn0 nfg). +apply/derivableP. +by rewrite -(near_eq_derivable vn0 nfg). +Qed. + +End near_eq. +Arguments near_eq_derive [R V W] f g [a]. +Arguments near_eq_derivable [R V W] f g [a]. +Arguments near_eq_is_derive [R V W] f g [a]. + +Section derivable_monotone. + +(* generalizing Ranalysis_ext.pderive_increasing_ax_{open_closed,closed_open} *) +Lemma derivable1_mono [R : realType] (a b : itv_bound R) (f : R -> R) (x y : R) : + x \in Interval a b -> y \in Interval a b -> + {in Interval a b, forall x, derivable f x 1} -> + (forall t : R, forall Ht : t \in `]x, y[, 0 < 'D_1 f t) -> + x < y -> f x < f y. +Proof. +rewrite !itv_boundlr=> /andP [ax xb] /andP [ay yb]. +move=> derivable_f df_pos xy. +have HMVT1: ({within `[x, y], continuous f})%classic. + apply: derivable_within_continuous=> z /[!itv_boundlr] /andP [xz zy]. + apply: derivable_f. + by rewrite itv_boundlr (le_trans ax xz) (le_trans zy yb). +have HMVT0: forall z : R, z \in `]x, y[ -> is_derive z 1 f ('D_1 f z). + move=> z /[!itv_boundlr] /andP [xz zy]. + apply/derivableP/derivable_f. + rewrite itv_boundlr. + rewrite (le_trans (le_trans ax (lexx x : BLeft x <= BRight x)%O) xz). + by rewrite (le_trans (le_trans zy (lexx y : BLeft y <= BRight y)%O) yb). +rewrite -subr_gt0. +have[z xzy ->]:= MVT xy HMVT0 HMVT1. +by rewrite mulr_gt0// ?df_pos// subr_gt0. +Qed. + +Lemma derivable1_homo [R : realType] (a b : itv_bound R) (f : R -> R) (x y : R) : + x \in Interval a b -> y \in Interval a b -> + {in Interval a b, forall x, derivable f x 1} -> + (forall t:R, forall Ht : t \in `]x, y[, 0 <= 'D_1 f t) -> + x <= y -> f x <= f y. +Proof. +rewrite !itv_boundlr=> /andP [ax xb] /andP [ay yb]. +move=> derivable_f df_nneg xy. +have HMVT1: ({within `[x, y], continuous f})%classic. + apply: derivable_within_continuous=> z /[!itv_boundlr] /andP [xz zy]. + apply: derivable_f. + by rewrite itv_boundlr (le_trans ax xz) (le_trans zy yb). +have HMVT0: forall z : R, z \in `]x, y[ -> is_derive z 1 f ('D_1 f z). + move=> z /[!itv_boundlr] /andP [xz zy]. + apply/derivableP/derivable_f. + rewrite itv_boundlr. + rewrite (le_trans (le_trans ax (lexx x : BLeft x <= BRight x)%O) xz). + by rewrite (le_trans (le_trans zy (lexx y : BLeft y <= BRight y)%O) yb). +rewrite -subr_ge0. +move: xy; rewrite le_eqVlt=> /orP [/eqP-> | xy]; first by rewrite subrr. +have[z xzy ->]:= MVT xy HMVT0 HMVT1. +by rewrite mulr_ge0// ?df_nneg// subr_ge0 ltW. +Qed. + +End derivable_monotone. diff --git a/lib/euclid.v b/lib/euclid.v index 06112170..085b91b2 100644 --- a/lib/euclid.v +++ b/lib/euclid.v @@ -1,5 +1,5 @@ -(* infotheo: information theory and error-correcting codes in Coq *) -(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) +(* infotheo: information theory and error-correcting codes in Coq *) +(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg poly polydiv matrix. (******************************************************************************) @@ -27,7 +27,6 @@ Unset Printing Implicit Defensive. Import GRing.Theory. Local Open Scope ring_scope. - Lemma pair_ind (P : nat -> Type) : P O -> P 1%nat -> (forall m, P m * P m.+1 -> P m.+2) -> @@ -262,7 +261,7 @@ rewrite /stop'; case: ex_maxnP => i Hi ij. rewrite leqNgt; apply/negP => abs. suff /ij : euclid_cont i.+1 by rewrite ltnn. apply/forallP => /= x. -case/boolP : (x == ord_max) => [/eqP->//|Hx]. +have [->//|Hx] := eqVneq x ord_max. have {}Hx : x < i.+1 by rewrite ltn_neqAle Hx /= -ltnS. by move/forallP : Hi => /(_ (Ordinal Hx)). Qed. @@ -351,8 +350,7 @@ elim: i => [? /= | i ih istop]. by rewrite /Euclid.v0 /Euclid.v1 size_poly0 size_poly1. rewrite {2}/Euclid.v Euclid.uvE. do 2 rewrite -/(Euclid.v _ _ _). -case/boolP : (v i.+1 == 0) => vi1_eq0. - by rewrite (eqP vi1_eq0) size_poly0. +have [->|vi1_eq0] := eqVneq (v i.+1) 0; first by rewrite size_poly0. destruct i. rewrite /= /Euclid.v0 /Euclid.v1 size_poly1 addr0 mulr1 size_opp. have r10 : r1 != 0. diff --git a/lib/hamming.v b/lib/hamming.v index 118d0fab..c9bb1188 100644 --- a/lib/hamming.v +++ b/lib/hamming.v @@ -1,10 +1,10 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) Require Import Reals. -From mathcomp Require Import all_ssreflect fingroup zmodp ssralg finalg perm matrix. +From mathcomp Require Import all_ssreflect fingroup zmodp ssralg ssrnum finalg perm matrix. From mathcomp Require Import poly mxalgebra mxpoly. -From mathcomp Require Import Rstruct. -Require Import ssr_ext ssralg_ext f2 num_occ natbin ssrR Reals_ext bigop_ext. +From mathcomp Require Import Rstruct reals. +Require Import ssr_ext ssralg_ext f2 num_occ natbin bigop_ext. (******************************************************************************) (* Hamming weight and Hamming distance *) @@ -51,7 +51,7 @@ Lemma dH_sym n a b : size a = n -> size b = n -> dH a b = dH b a. Proof. move=> Ha Hb. by rewrite /dH (@addb_seq_com n). Qed. Lemma dH_tri_ine : forall n a b c, size a = n -> size b = n -> size c = n -> - dH a b <= dH a c + dH c b. + (dH a b <= dH a c + dH c b)%N. Proof. elim => [ [] // [] // [] // |]. move=> n IH [|ha ta] // [|hb tb] // [|hc tc] // [Ha] [Hb] [Hc]. @@ -79,10 +79,10 @@ Implicit Types u v : 'rV[F]_n. Definition wH v := count (fun x => x != 0) (tuple_of_row v). -Lemma max_wH u : wH u <= n. +Lemma max_wH u : (wH u <= n)%N. Proof. by rewrite /wH (leq_trans (count_size _ _)) // size_tuple. Qed. -Lemma max_wH' u : wH u < n.+1. Proof. by rewrite ltnS max_wH. Qed. +Lemma max_wH' u : (wH u < n.+1)%N. Proof. by rewrite ltnS max_wH. Qed. Lemma wH_sum v : wH v = (\sum_(n0 < n) (v ``_ n0 != 0%R))%nat. Proof. @@ -126,10 +126,10 @@ rewrite coef_poly insubT // => ni. rewrite ltn_ord; congr (u _ _ != _); by apply val_inj. Qed. -Lemma wH_poly_rV (p : {poly F}) : wH (poly_rV p) <= size p. +Lemma wH_poly_rV (p : {poly F}) : (wH (poly_rV p) <= size p)%N. Proof. rewrite /wH /=. -case/boolP : (size p < n) => pn; last first. +case/boolP : (size p < n)%N => pn; last first. rewrite -leqNgt in pn; rewrite (leq_trans _ pn) //. by rewrite (leq_trans (count_size _ _)) // size_map size_enum_ord. have -> : [seq (poly_rV p) ``_ i | i <- enum 'I_n] = @@ -141,7 +141,7 @@ have -> : [seq (poly_rV p) ``_ i | i <- enum 'I_n] = rewrite nth_cat size_map size_enum_ord; case: ifPn => [pi|]. by rewrite (nth_map (Ordinal pi)) ?size_enum_ord // mxE nth_enum_ord. rewrite -leqNgt => /leq_sizeP/(_ _ (leqnn i)) ->; by rewrite nth_nseq ltn_sub2r. -rewrite count_cat [X in _ + X <= _](_ : count _ _ = O) ?addn0; last first. +rewrite count_cat [X in (_ + X <= _)%N](_ : count _ _ = O) ?addn0; last first. rewrite (@eq_in_count _ _ pred0) ?count_pred0 //. move=> i; case/nseqP => -> /= _; by rewrite eqxx. by rewrite count_map (leq_trans (count_size _ _)) // size_enum_ord. @@ -162,7 +162,7 @@ Proof. by rewrite /dH opprD addrA subrr add0r wH_opp. Qed. Lemma dH0x x : dH 0 x = wH x. Proof. by rewrite /dH add0r wH_opp. Qed. -Lemma max_dH u v : dH u v <= n. +Lemma max_dH u v : (dH u v <= n)%N. Proof. rewrite /dH. apply max_wH. Qed. Lemma dH_sym u v : dH u v = dH v u. @@ -406,7 +406,7 @@ transitivity (\sum_(x : 'rV['F_p]_k | [forall j : 'I_k, x ``_ j != 0%R]) 1). transitivity (p.-1 ^ k); last first. rewrite -big_distrl /= sum1dep_card. set s := [set _ | _]. - rewrite (_ : s = set1 (\row_(i < n) if k <= i then 0 else 1)%R) ?cards1 ?mul1n //. + rewrite (_ : s = set1 (\row_(i < n) if (k <= i)%N then 0 else 1)%R) ?cards1 ?mul1n //. apply/setP => /= x; rewrite !inE {s}. apply/idP/idP => [/andP[/forallP H1 /forallP H2]|/eqP H]. apply/eqP/rowP => /= j; rewrite !mxE; case: ifPn => n0j. @@ -419,7 +419,7 @@ by apply: card_rV_wo_zeros. Qed. Local Open Scope ring_scope. -Lemma wH_m_card_gen p n k : prime p -> k <= n -> +Lemma wH_m_card_gen p n k : prime p -> (k <= n)%N -> #|[set a in 'rV['F_p]_n | wH a == k]| = ('C(n, k) * p.-1 ^ k)%N. Proof. move=> primep n0n. @@ -539,7 +539,7 @@ destruct r as [|r']. by rewrite inE subrr wH0 eqxx !inE. set r := r'.+1. apply/set0Pn. -set y : 'rV[F]_n:= (\row_i if i < r then 1 else 0)%R. +set y : 'rV[F]_n:= (\row_i if (i < r)%N then 1 else 0)%R. exists (x + y)%R. rewrite inE dH_wH. rewrite (_ : y = castmx (erefl, subnKC rn) (@row_mx _ 1 r (n -r) (const_mx 1%R) 0)). @@ -617,7 +617,7 @@ Qed. End card_dH. Local Open Scope ring_scope. -Lemma wH_two_pow n p : p < n -> wH (rV_of_nat n (expn 2 p)) = 1%nat. +Lemma wH_two_pow n p : (p < n)%N -> wH (rV_of_nat n (expn 2 p)) = 1%nat. Proof. move=> pn. rewrite wH_bitstring /rV_of_nat /row_of_bitseq /row_of_seq /rowF2_tuplebool /=. @@ -842,20 +842,20 @@ Qed. End AboutwH123. -Local Open Scope R_scope. +Local Open Scope ring_scope. -Lemma hamming_01 m p : +Lemma hamming_01 (R : realType) m p : \sum_(u in 'rV['F_2]_m| u \in [set v |(1 >= wH v)%nat]) - (1 - p) ^ (m - wH u) * p ^ wH u = - (1 - p) ^ m + m%:R * p * (1 - p) ^ (m - 1). + (1 - p) ^+ (m - wH u) * p ^+ wH u = + (1 - p) ^+ m + m%:R * p * (1 - p) ^+ (m - 1) :> R. Proof. rewrite (bigID [pred i | wH i == O]) /=. rewrite (big_pred1 (@GRing.zero _)) /=; last first. by move=> i /=; rewrite !inE -wH_eq0 andb_idl // => /eqP ->. -rewrite wH0 pow_O subn0 mulR1; congr (_ + _). -transitivity (\sum_(i | wH (i : 'rV['F_2]_m) == 1%nat) ((1 - p) ^ (m - 1) * p ^ 1)). +rewrite wH0 expr0 subn0 mulr1; congr (_ + _). +transitivity (\sum_(i | wH (i : 'rV['F_2]_m) == 1%nat) ((1 - p) ^+ (m - 1) * p ^+ 1)). transitivity (\sum_(i|(wH (i : 'rV['F_2]_m) == 1)%nat) - ((1 - p) ^ (m - wH i) * p ^ wH i)). + ((1 - p) ^+ (m - wH i) * p ^+ wH i)). apply eq_bigl => /= i. rewrite !inE. case/boolP : (wH i == 1)%nat => [/eqP -> //|wH_1]. @@ -864,19 +864,25 @@ transitivity (\sum_(i | wH (i : 'rV['F_2]_m) == 1%nat) ((1 - p) ^ (m - 1) * p ^ case n1_0 : n1 => [|? //]. by rewrite wH_0 n1_0 in wH_1. by apply/eq_bigr => /= v /eqP ->. -by rewrite big_const iter_addR pow_1 /= -(mulRC p) mulRA -cardsE wH_m_card bin1. +rewrite big_const iter_addr addr0 expr1 /=. +rewrite -cardsE wH_m_card bin1 mulrC. +rewrite -mulrA. +by rewrite mulr_natl. Qed. -Lemma binomial_theorem m p : - \sum_(b in [set: 'rV['F_2]_m]) (1 - p) ^ (m - wH b) * p ^ wH b = 1. +Lemma binomial_theorem {R : realType} m p : + \sum_(b in [set: 'rV['F_2]_m]) (1 - p) ^+ (m - wH b) * p ^+ wH b = 1 :> R. Proof. -transitivity (((1 - p) + p) ^ m); last by rewrite subRK exp1R. -rewrite RPascal. -transitivity (\sum_(b : 'rV['F_2]_m) (1 - p) ^ (m - wH b) * p ^ wH b). +transitivity (((1 - p) + p) ^+ m); last first. + by rewrite subrK expr1n. +rewrite exprDn. +transitivity (\sum_(b : 'rV['F_2]_m) (1 - p) ^+ (m - wH b) * p ^+ wH b). by apply eq_bigl => /= i; rewrite inE. -rewrite sumRE (classify_big (fun s => Ordinal (max_wH' s)) - (fun x => (1 - p) ^ (m - x) * p ^ x)) /=. +rewrite (classify_big (fun s => Ordinal (max_wH' s)) + (fun x => (1 - p) ^+ (m - x) * p ^+ x)) /=. apply: eq_bigr=> i _. -rewrite -wH_m_card !coqRE; congr (_ %:R %mcR * _). +rewrite -wH_m_card. +rewrite mulr_natl. +congr (_*+ _). by apply eq_card => /= x; rewrite !inE. Qed. diff --git a/lib/logb.v b/lib/logb.v deleted file mode 100644 index c04cd978..00000000 --- a/lib/logb.v +++ /dev/null @@ -1,417 +0,0 @@ -(* infotheo: information theory and error-correcting codes in Coq *) -(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum. -From mathcomp Require Import Rstruct. -Require Import Reals Lra. -Require Import ssrR Reals_ext. -From mathcomp Require Import reals. -Require Import realType_ext. - -(******************************************************************************) -(* log_n x and n ^ x *) -(* *) -(* Definitions and lemmas about the logarithm and the exponential in base n. *) -(* *) -(* Definitions: *) -(* Log == log_n x *) -(* Exp == n ^ x *) -(* log == Log in base 2 *) -(* exp2 == 2 ^ x *) -(******************************************************************************) - -Set Implicit Arguments. -Unset Strict Implicit. -Import Prenex Implicits. - -Local Open Scope R_scope. - -Import Order.POrderTheory GRing.Theory Num.Theory. - -Section addtional_lemmas_about_ln_exp. - -Lemma ln_pos x : 1 < x -> 0 < ln x. -Proof. by move=> x0; rewrite -ln_1; exact: ln_increasing. Qed. - -Lemma ln2_gt0 : 0 < ln 2. Proof. apply ln_pos; lra. Qed. -Local Hint Resolve ln2_gt0 : core. - -Lemma ln2_neq0 : ln 2 != 0. Proof. exact/gtR_eqF. Qed. - -Lemma ln_expR (a : R) (n : nat) : 0 < a -> ln (a ^ n) = n%:R * ln a. -Proof. -move=> a0; elim: n => [|n IH]; first by rewrite expR0 ln_1 mul0R. -rewrite expRS ln_mult //; last exact: expR_gt0. -by rewrite IH S_INR mulRDl mul1R addRC. -Qed. - -Lemma ln_increasing_le a b : 0 < a -> a <= b -> ln a <= ln b. -Proof. -move=> Ha. -case/Rle_lt_or_eq_dec; last first. - by move=> ->; by apply/RleP; rewrite lexx. -by move/(ln_increasing _ _ Ha)/ltRW. -Qed. - -Lemma exp_le_inv x y : exp x <= exp y -> x <= y. -Proof. -case/Rle_lt_or_eq_dec; [move/exp_lt_inv => ?; exact/ltRW | - move/exp_inv => ->]. -by apply/RleP; rewrite lexx. -Qed. - -Lemma exp_pow n : forall k, exp (k%:R * n) = (exp n) ^ k. -Proof. -elim => [|k IH]; first by rewrite mul0R exp_0. -by rewrite S_INR mulRDl mul1R exp_plus IH mulRC. -Qed. - -Lemma leR2e : 2 <= exp 1. Proof. apply Rlt_le, exp_ineq1; lra. Qed. - -Lemma ltRinve1 : exp (-1) < 1. -Proof. rewrite -[X in _ < X]exp_0. apply exp_increasing. lra. Qed. - -Lemma ltRinve21 : exp (-2) < 1. -Proof. rewrite -[X in _ < X]exp_0. apply exp_increasing. lra. Qed. - -Section exp_lower_bound. - -Let exp_dev (n : nat) := fun x => exp x - x ^ n * / (n`!)%:R. - -Let derivable_exp_dev (n : nat) : derivable (exp_dev n). -Proof. -rewrite /exp_dev => x. -apply derivable_pt_minus ; first by apply derivable_pt_exp. -apply derivable_pt_mult ; first by apply derivable_pt_pow. -by apply derivable_pt_const. -Defined. - -Let exp_dev_rec n x : derive_pt (exp_dev n.+1) x (derivable_exp_dev n.+1 x) = exp_dev n x. -Proof. -rewrite /exp_dev derive_pt_minus derive_pt_exp; congr (_ - _). -rewrite derive_pt_mult derive_pt_const mulR0 addR0 derive_pt_pow. -rewrite mulRC mulRA mulRC; congr (_ * _). -rewrite factS natRM invRM ?INR_eq0' //; last by rewrite -lt0n fact_gt0. -by rewrite mulRC mulRA mulRV ?mul1R // INR_eq0'. -Qed. - -Let exp_dev_gt0 : forall n r, 0 < r -> 0 < exp_dev n r. -Proof. -elim => [r rpos | n IH r rpos]. -- rewrite /exp_dev /= mul1R Rinv_1 -exp_0. - by apply subR_gt0, exp_increasing. -- apply: (@ltR_trans 1); first lra. - rewrite (_ : 1 = exp_dev n.+1 0) ; last first. - rewrite /exp_dev exp_0 pow_i ?mul0R ?subR0 //; by apply/ltP. - move: derive_increasing_interv. - move/(_ 0 r (exp_dev n.+1) (derivable_exp_dev n.+1) rpos). - have Haux : forall t : R, - 0 < t < r -> 0 < derive_pt (exp_dev n.+1) t (derivable_exp_dev n.+1 t). - move=>x Hx. - rewrite exp_dev_rec. - by apply IH, Hx. - move/(_ Haux 0 r) => {Haux}. - apply => //. - - by split; [by [] | exact: ltRW]. - - split; [exact: ltRW | ]. - by apply/RleP; rewrite lexx. -Qed. - -Lemma exp_strict_lb (n : nat) x : 0 < x -> x ^ n * / (n`!)%:R < exp x. -Proof. move=> xpos; by apply Rgt_lt, Rminus_gt, Rlt_gt, exp_dev_gt0. Qed. - -Let exp_dev_ge0 n r : 0 <= r -> 0 <= exp_dev n r. -Proof. -move=> Hr. -case/boolP : (r == 0) => [/eqP ->|]; last first. -- move=> Hr2. - have {Hr Hr2}R_pos : 0 < r. - by apply/RltP; rewrite lt0r Hr2/=; exact/RleP. - exact/ltRW/exp_dev_gt0. -- case: n. - + by rewrite /exp_dev exp_0 mul1R invR1 subRR. - + move=> n. - rewrite -(_ : 1 = exp_dev n.+1 0) //. - rewrite /exp_dev exp_0 pow_i ?mul0R ?subR0 //; exact/ltP. -Qed. - -Lemma exp_lb x (n : nat) : 0 <= x -> x ^ n / (n`!)%:R <= exp x. -Proof. move=> xpos; by apply Rge_le, Rminus_ge, Rle_ge, exp_dev_ge0. Qed. - -End exp_lower_bound. - -End addtional_lemmas_about_ln_exp. -Global Hint Resolve ln2_gt0 : core. - -Definition Log (n : R) x := ln x / ln n. - -Lemma Log_expR (a b : R) (n : nat) : 0 < a -> Log b (a ^ n) = n%:R * Log b a. -Proof. by move=> a0; rewrite /Log ln_expR // mulRA. Qed. - -Lemma ltR0Log n x : 1 < n -> 1 < x -> 0 < Log n x. -Proof. move=> ? ?; apply mulR_gt0; [exact/ln_pos | exact/invR_gt0/ln_pos]. Qed. - -Lemma Log_1 (n : R) : Log n 1 = 0. -Proof. by rewrite /Log ln_1 div0R. Qed. - -Lemma Log_n (n : R) : 1 < n -> Log n n = 1. -Proof. by move=> n1; rewrite /Log /Rdiv mulRV //; exact/gtR_eqF/ln_pos. Qed. - -Lemma LogV n x : 0 < x -> Log n (/ x) = - Log n x. -Proof. by move=> x0; rewrite /Log ln_Rinv // -mulNR. Qed. - -Lemma LogM n x y : 0 < x -> 0 < y -> Log n (x * y) = Log n x + Log n y. -Proof. move=> *; by rewrite /Log -mulRDl ln_mult. Qed. - -Lemma LogDiv n x y : 0 < x -> 0 < y -> Log n (x / y) = Log n x - Log n y. -Proof. move=> *; rewrite LogM //; [by rewrite LogV | exact: invR_gt0]. Qed. - -Lemma Log_increasing_le n x y : 1 < n -> 0 < x -> x <= y -> Log n x <= Log n y. -Proof. -move=> n1 x0 xy. -apply leR_wpmul2r. - apply/RleP. - by rewrite RinvE invr_ge0; exact/ltW/RltP/ln_pos. -exact: ln_increasing_le. -Qed. - -Lemma Log_increasing n a b : 1 < n -> 0 < a -> a < b -> Log n a < Log n b. -Proof. -move=> n1 Ha a_b. -rewrite /Log; apply ltR_pmul2r; last exact: ln_increasing. -exact/invR_gt0/ln_pos. -Qed. - -Lemma Log_inv n x y : 1 < n -> 0 < x -> 0 < y -> Log n x = Log n y -> x = y. -Proof. -move=> n1 Hx Hy. -rewrite /Log /Rdiv eqR_mul2r; last exact/invR_neq0/eqP/gtR_eqF/ln_pos. -apply ln_inv => //; exact: H. -Qed. - -Lemma Log_lt_inv n x y : 1 < n -> 0 < x -> 0 < y -> Log n x < Log n y -> x < y. -Proof. -move=> n1 Hx Hy. -rewrite /Log /Rdiv. -have H : 0 < / ln n by exact/invR_gt0/ln_pos. -move/(ltR_pmul2r H); exact: ln_lt_inv. -Qed. - -Lemma Log_le_inv n x y : 1 < n -> 0 < x -> 0 < y -> Log n x <= Log n y -> x <= y. -Proof. -move=> n1 Hx Hy. -case/Rle_lt_or_eq_dec; first by move/(Log_lt_inv n1 Hx Hy)/ltRW. -move/(Log_inv n1 Hx Hy) => ->. -by apply/RleP; rewrite lexx. -Qed. - -(* NB: log is 0 for input < 0 *) -Definition log x := Log 2 x. - -Lemma log1 : log 1 = 0. Proof. by rewrite /log Log_1. Qed. -Lemma log4 : log 4 = 2. -Proof. -rewrite (_ : 4 = 2 ^ 2); last lra. -rewrite /log Log_expR // /Log divRR ?ln2_neq0 // mulR1 !S_INR add0R; field. -Qed. -Lemma log8 : log 8 = 3. -Proof. -rewrite (_ : 8 = 2 ^ 3); last lra. -rewrite /log Log_expR // /Log divRR ?ln2_neq0 // mulR1 !S_INR add0R; field. -Qed. -Lemma log16 : log 16 = 4. -Proof. -rewrite (_ : 16 = 2 ^ 4); last lra. -rewrite /log Log_expR // /Log divRR ?ln2_neq0 // mulR1 !S_INR add0R; field. -Qed. -Lemma log32 : log 32 = 5. -Proof. -rewrite (_ : 32 = 2 ^ 5); last lra. -rewrite /log Log_expR // /Log divRR ?ln2_neq0 // mulR1 !S_INR add0R; field. -Qed. - -Lemma logV x : 0 < x -> log (/ x) = - log x. -Proof. by move/(@LogV 2). Qed. - -Lemma logM x y : 0 < x -> 0 < y -> log (x * y) = log x + log y. -Proof. move=> x0 y0; exact: (@LogM 2 _ _ x0 y0). Qed. - -Lemma logDiv x y : 0 < x -> 0 < y -> log (x / y) = log x - log y. -Proof. move=> x0 y0; exact: (@LogDiv 2 _ _ x0 y0). Qed. - -Lemma logexp1E : log (exp 1) = / ln 2. -Proof. by rewrite /log /Log ln_exp div1R. Qed. - -Lemma log_exp1_Rle_0 : 0 <= log (exp 1). -Proof. -rewrite logexp1E. -apply/RleP. -rewrite RinvE ?ln2_neq0// invr_ge0. -exact/ltW/RltP/ln2_gt0. -Qed. - -Definition Exp (n : R) x := exp (x * ln n). - -Lemma pow_Exp x n : 0 < x -> x ^ n = Exp x n%:R. -Proof. by move=> x0; rewrite /Exp exp_pow exp_ln. Qed. - -Lemma LogK n x : 1 < n -> 0 < x -> Exp n (Log n x) = x. -Proof. -move=> n1 x0. -rewrite /Log /Exp -mulRA mulVR ?mulR1 ?exp_ln //. -rewrite -ln_1. -apply/eqP => /ln_inv H. -have : 0 < n by lra. -move/H => /(_ Rlt_0_1) ?; lra. -Qed. - -Lemma ExpK n x : 1 < n -> Log n (Exp n x) = x. -Proof. -move=> n1. -rewrite /Log /Exp ln_exp /Rdiv -mulRA mulRV ?mulR1 //. -rewrite -ln_1; apply/eqP => /ln_inv H. -have : 0 < n by lra. -move/H => /(_ Rlt_0_1) ?; lra. -Qed. - -Lemma Exp_gt0 n x : 0 < Exp n x. Proof. rewrite /Exp; exact: exp_pos. Qed. -Lemma Exp_ge0 n x : 0 <= Exp n x. Proof. exact/ltRW/Exp_gt0. Qed. -Global Hint Resolve Exp_gt0 : core. -Global Hint Resolve Exp_ge0 : core. - -Lemma Exp_0 n : Exp n 0 = 1. -Proof. by rewrite /Exp mul0R exp_0. Qed. - -Lemma ExpD n x y : Exp n (x + y) = Exp n x * Exp n y. -Proof. by rewrite /Exp mulRDl exp_plus. Qed. - -Lemma natRExp n : (0 < n)%nat -> forall m, Exp n%:R m%:R = (expn n m)%:R. -Proof. -move=> n0. -elim=> [|m IH]; first by rewrite /Exp mul0R exp_0. -rewrite S_INR ExpD expnS natRM IH /Exp mul1R exp_ln; - [by rewrite mulRC | exact/ltR0n]. -Qed. - -Lemma Exp_increasing n x y : 1 < n -> x < y -> Exp n x < Exp n y. -Proof. move=> ? ?; apply/exp_increasing/ltR_pmul2r => //; exact/ln_pos. Qed. - -Lemma Exp_le_inv n x y : 1 < n -> Exp n x <= Exp n y -> x <= y. -Proof. -rewrite /Exp => n1 /exp_le_inv H. -apply/RleP; rewrite -(@ler_pM2l _ (ln n)); last exact/RltP/ln_pos. -by rewrite mulrC -(mulrC y); exact/RleP. -Qed. - -Lemma Exp_le_increasing n x y : 1 < n -> x <= y -> Exp n x <= Exp n y. -Proof. -move=> n1; rewrite /Exp; case/Rle_lt_or_eq_dec. -move/Exp_increasing => x_y; exact/ltRW/x_y. -by move=> ->; apply/RleP; rewrite lexx. -Qed. - -Lemma Exp_Ropp n x : Exp n (- x) = / Exp n x. -Proof. by rewrite /Exp mulNR exp_Ropp. Qed. - -Definition exp2 (x : R) := Exp 2 x. - -Lemma morph_exp2_plus : {morph [eta exp2] : x y / x + y >-> x * y}. -Proof. move=> ? ? /=; by rewrite -ExpD. Qed. - -Lemma exp2_gt0 x : 0 < exp2 x. Proof. exact: Exp_gt0. Qed. -Lemma exp2_ge0 x : 0 <= exp2 x. Proof. exact: Exp_ge0. Qed. -Global Hint Resolve exp2_gt0 : core. -Global Hint Resolve exp2_ge0 : core. - -Lemma exp2_neq0 l : exp2 l <> 0. Proof. exact/eqP/gtR_eqF. Qed. -Global Hint Resolve exp2_neq0 : core. - -Lemma exp2_0 : exp2 0 = 1. -Proof. by rewrite /exp2 -/(Exp 2 0) Exp_0. Qed. - -Lemma natRexp2 m : exp2 m%:R = (expn 2 m)%:R. -Proof. by rewrite -natRExp. Qed. - -Lemma exp2_pow n k : exp2 (k%:R * n) = (exp2 n) ^ k. -Proof. by rewrite /exp2 /Exp -mulRA exp_pow. Qed. - -Lemma exp2_Ropp x : exp2 (- x) = / exp2 x. -Proof. by rewrite /exp2 Exp_Ropp. Qed. - -Lemma logK x : 0 < x -> exp2 (log x) = x. -Proof. move=> Hx; by rewrite /exp2 -/(Exp 2 (log x)) /log -/(Log 2 _) LogK. Qed. - -Lemma exp2K x : log (exp2 x) = x. -Proof. by rewrite /exp2 -/(Exp 2 x) /log -/(Log 2 _) ExpK. Qed. - -Lemma Rle_exp2_log1_L a b : 0 < b -> (exp2 a <= b)%mcR = (a <= log b)%mcR. -Proof. -move=> Hb; move H1 : (_ <= _ )%mcR => [|] /=. -- move/RleP in H1. - have {}H1 : a <= log b. - rewrite (_ : a = log (exp2 a)); last by rewrite exp2K. - exact: Log_increasing_le. - by move/RleP : H1 => ->. -- move H2 : (_ <= _ )%mcR => [|] //=. - move/RleP in H2. - rewrite -(@ExpK 2 a _) // in H2. - apply Log_le_inv in H2 => //. - move/RleP in H2. - by rewrite H2 in H1. -Qed. - -Lemma Rle_exp2_log2_R b c : 0 < b -> (b <= exp2 c)%mcR = (log b <= c)%mcR. -Proof. -move=> Hb; move H1 : (_ <= _)%mcR => [|] /=. -- move/RleP in H1. - have {}H1 : log b <= c. - rewrite (_ : c = log (exp2 c)); last by rewrite exp2K. - apply Log_increasing_le => //; exact: exp2_pos. - by move/RleP in H1. -- move H2 : (_ <= _ )%mcR => [|] //=. - move/RleP in H2. - rewrite -(exp2K c) in H2. - apply Log_le_inv in H2 => //. - move/RleP in H2. - by rewrite H2 in H1. -Qed. - -Lemma Rle2_exp2_log a b c : 0 < b -> - (exp2 a <= b <= exp2 c)%mcR = (a <= log b <= c)%mcR. -Proof. -move=> Hb; move H1 : (_ <= _ )%mcR => [|] /=. -- rewrite Rle_exp2_log1_L // in H1. - by rewrite H1 /= Rle_exp2_log2_R. -- move H2 : (_ <= _ )%mcR => [|] //=. - rewrite -Rle_exp2_log1_L // in H2. - by rewrite H2 in H1. -Qed. - -Lemma exists_frac_part (P : nat -> Prop) : (exists n, P n) -> - forall num den, (0 < num)%nat -> (0 < den)%nat -> - (forall n m, (n <= m)%nat -> P n -> P m) -> - exists n, P n /\ - frac_part (exp2 (n%:R * (log num%:R / den%:R))) = 0. -Proof. -case=> n Pn num den Hden HP. -exists (n * den)%nat. -split. - apply H with n => //. - by rewrite -{1}(muln1 n) leq_mul2l HP orbC. -rewrite natRM -mulRA (mulRCA den%:R) mulRV // ?mulR1; last first. - by rewrite INR_eq0' -lt0n. -by rewrite exp2_pow logK; [exact/frac_part_pow/frac_part_INR | exact/ltR0n]. -Qed. - -Lemma log_prodR_sumR_mlog {A : finType} k (f : A -> R) s : - (forall a, 0 <= f a)%coqR -> - (forall i, 0 < f i)%coqR -> - (- Log k (\prod_(i <- s) f i) = \sum_(i <- s) - Log k (f i))%R. -Proof. -move=> f0 f0'. -elim: s => [|h t ih]. - by rewrite !big_nil Log_1 oppR0. -rewrite big_cons LogM//; last first. - by apply/RltP/prodr_gt0 => a _; exact/RltP. -by rewrite [RHS]big_cons oppRD; congr (_ + _)%coqR. -Qed. - diff --git a/lib/realType_ext.v b/lib/realType_ext.v index 7aebdc25..e059a849 100644 --- a/lib/realType_ext.v +++ b/lib/realType_ext.v @@ -2,7 +2,7 @@ (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From HB Require Import structures. From mathcomp Require Import all_ssreflect ssralg ssrnum. -From mathcomp Require Import reals normedtype. +From mathcomp Require Import reals normedtype sequences. From mathcomp Require Import mathcomp_extra boolp. From mathcomp Require Import lra ring Rstruct. @@ -11,12 +11,15 @@ From mathcomp Require Import lra ring Rstruct. (* *) (* P `<< Q == P is dominated by Q, i.e., forall a, Q a = 0 -> P a = 0 *) (* *) -(* p rob == type of "probabilities", i.e., reals p s.t. 0 <= p <= 1 *) +(* prob == type of "probabilities", i.e., reals p s.t. 0 <= p <= 1 *) +(* oprob == type of "open unit interval", i.e., reals p s.t. 0 < p < 1 *) (* *) (******************************************************************************) Delimit Scope ring_scope with mcR. +Declare Scope reals_ext_scope. +Reserved Notation "+| r |" (at level 0, r at level 99, format "+| r |"). Reserved Notation "p '.~'" (format "p .~", at level 5). Reserved Notation "P '`<<' Q" (at level 51). Reserved Notation "P '`< 0 < y * x -> 0 < y. +Proof. +rewrite le_eqVlt=> /orP [/eqP <- |]. + by rewrite mulr0 ltxx. +by move/pmulr_lgt0->. +Qed. + +Lemma wpmulr_rgt0 (R : numDomainType) (x y : R) : 0 <= x -> 0 < x * y -> 0 < y. +Proof. by rewrite mulrC; exact: wpmulr_lgt0. Qed. +End num_ext. + +(* TODO: gen, call is divr_eq? *) +Lemma eqr_divr_mulr {R : realType} (z x y : R) : z != 0%mcR -> (y / z = x)%mcR <-> (y = x * z)%mcR. +Proof. +move=> z0; split => [<-|->]; first by rewrite -mulrA mulVf // mulr1. +by rewrite -mulrA mulfV // mulr1. +Qed. + +(* TODO: rename as prodr_gt0 *) Lemma prodR_gt0 (R : numDomainType) (A : finType) (F : A -> R) : (forall a, 0 < F a)%mcR -> (0 < \prod_(a : A) F a)%mcR. Proof. by move=> F0; elim/big_ind : _ => // x y ? ?; exact: mulr_gt0. Qed. @@ -41,7 +69,7 @@ Proof. by move=> F0; elim/big_ind : _ => // x y ? ?; exact: mulr_gt0. Qed. (* PR to mathcomp_extra.v? *) Section onem. Local Open Scope ring_scope. -Variable R : realType. +Variable R : realFieldType. Implicit Types r s : R. Lemma onem_le r s : (r <= s) = (`1-s <= `1-r). @@ -64,7 +92,7 @@ Lemma onem_div r s : s != 0 -> `1-(r / s) = (s - r) / s. Proof. by rewrite !onemE => q0; rewrite mulrDl mulNr divff. Qed. Lemma onem_prob r : 0 <= r <= 1 -> 0 <= onem r <= 1. - by move=> /andP[r0 r1]; apply /andP; split; [rewrite onem_ge0|rewrite onem_le1]. Qed. +Proof. by move=> /andP[r0 r1]; apply /andP; split; [rewrite onem_ge0|rewrite onem_le1]. Qed. Lemma onem_eq0 r : (`1-r = 0) <-> (r = 1). Proof. by rewrite /onem; split => [/subr0_eq//|->]; rewrite subrr. Qed. @@ -83,15 +111,76 @@ Proof. by rewrite /onem opprB addrA. Qed. End onem. Notation "p '.~'" := (onem p). + +Section about_the_pow_function. +Local Open Scope ring_scope. + +Lemma x_x2_eq {R : realFieldType} (q : R) : q * (1 - q) = 4^-1 - 4^-1 * (2 * q - 1) ^+ 2. +Proof. by field. Qed. + +Lemma x_x2_max {R : realFieldType} (q : R) : q * (1 - q) <= 4^-1. +Proof. +rewrite x_x2_eq. +have : forall a b : R, 0 <= b -> a - b <= a. move=> *; lra. +apply; apply mulr_ge0; [lra | exact: exprn_even_ge0]. +Qed. + +Lemma x_x2_pos {R : realFieldType} (q : R) : 0 < q < 1 -> 0 < q * (1 - q). +Proof. +move=> q01. +rewrite [ltRHS](_ : _ = - (q - 2^-1)^+2 + (2^-2)); last by field. +rewrite addrC subr_gt0 -exprVn -[ltLHS]real_normK ?num_real//. +rewrite ltr_pXn2r// ?nnegrE; [| exact: normr_ge0 | lra]. +have/orP[H|H]:= le_total (q - 2^-1) 0. + rewrite (ler0_norm H); lra. +rewrite (ger0_norm H); lra. +Qed. + +Lemma x_x2_nneg {R : realFieldType} (q : R) : 0 <= q <= 1 -> 0 <= q * (1 - q). +Proof. +case/andP=> q0 q1. +have[->|qneq0]:= eqVneq q 0; first lra. +have[->|qneq1]:= eqVneq q 1; first lra. +have: 0 < q < 1 by lra. +by move/x_x2_pos/ltW. +Qed. + +(* TODO: prove expR1_lt3 too; PR to mca *) +Lemma expR1_gt2 {R : realType} : 2 < expR 1 :> R. +Proof. +rewrite /expR /exp_coeff. +apply: (@lt_le_trans _ _ (series (fun n0 : nat => 1 ^+ n0 / n0`!%:R) 3)). + rewrite /series /=. + under eq_bigr do rewrite expr1n. + rewrite big_mkord. + rewrite big_ord_recl /= divr1 ltrD2l. + rewrite big_ord_recl /= divr1 -[ltLHS]addr0 ltrD2l. + rewrite big_ord_recl big_ord0 addr0 !factS fact0 /bump /= addn0 !muln1. + by rewrite mulr_gt0// invr_gt0. +apply: limr_ge; first exact: is_cvg_series_exp_coeff_pos. +exists 3=>// n /= n3. +rewrite -subr_ge0 sub_series_geq// sumr_ge0// => i _. +by rewrite mulr_ge0// ?invr_ge0// exprn_ge0. +Qed. + +End about_the_pow_function. + + +Section dominance_defs. + Definition dominates {R : realType} {A : Type} (Q P : A -> R) := locked (forall a, Q a = 0 -> P a = 0)%R. -Notation "P '`<<' Q" := (dominates Q P). +Local Notation "P '`<<' Q" := (dominates Q P). Lemma dominatesP {R : realType} A (Q P : A -> R) : P `<< Q <-> forall a, Q a = 0%R -> P a = 0%R. Proof. by rewrite /dominates; unlock. Qed. +End dominance_defs. + +Notation "P '`<<' Q" := (dominates Q P). + Section dominance. Context {R : realType}. @@ -209,6 +298,7 @@ have [/eqP ->|pneq1] := boolP (p == 1%:pr); first by left. by right; apply/andP; split; [exact/prob_gt0|exact/prob_lt1]. Qed. +(* TODO: rename to prob_onemK and prob_onemKC? *) Lemma probK p : p = ((Prob.p p).~).~%:pr. Proof. by apply val_inj => /=; rewrite onemK. Qed. @@ -257,6 +347,7 @@ Arguments prob1 {R}. (* ---- ---- *) +(* TODO: rename oprob to i01oo (and prob to i01cc) *) Module OProb. Section def. Import GRing.Theory. @@ -275,15 +366,13 @@ HB.instance Definition _ (R : realType) := [Equality of t R by <:]. End Exports. End OProb. Export OProb.Exports. -(*Coercion OProb.p : oprob >-> prob.*) +Coercion OProb.p : oprob >-> prob. Canonical oprobcplt [R: realType] (p : oprob R) := Eval hnf in OProb.mk (onem_oprob (OProb.O1 p)). Reserved Notation "{ 'oprob' T }" (at level 0, format "{ 'oprob' T }"). Notation "{ 'oprob' T }" := (@oprob T). -Definition oprob_coercion (R: realType) (p : {oprob R}) : R := OProb.p p. Notation oprob_to_real o := (Prob.p (OProb.p o)). -(*(R: realType) (o : {oprob R}) := Prob.p (OProb.p o).*) Section oprob_lemmas. Import GRing.Theory. @@ -302,6 +391,13 @@ Import Order.POrderTheory Order.TotalTheory. Lemma oprob_neq0 p : oprob_to_real p != 0 :> R. Proof. by move:(oprob_gt0 p); rewrite lt_neqAle=> /andP -[] /eqP/nesym/eqP. Qed. +Lemma oprob_neq1 p : oprob_to_real p != 1 :> R. +Proof. by move:(oprob_lt1 p); rewrite lt_neqAle=> /andP -[]. Qed. + +Lemma oprob_onemK (p : {oprob R}) : p = ((oprob_to_real p).~).~%:opr. +Proof. by apply/val_inj/val_inj=> /=; rewrite onemK. Qed. + +(* TODO: rename? *) Lemma prob_trichotomy' (p : {prob R}) (P : {prob R} -> Prop) : P prob0 -> P prob1 -> (forall o : {oprob R}, P (OProb.p o)) -> P p. Proof. @@ -310,6 +406,14 @@ have [-> //|[->//|p01]] := prob_trichotomy p. apply (po (@OProb.mk _ _ p01)). Qed. +Lemma oprobadd_gt0 p q : 0 < oprob_to_real p + oprob_to_real q. +Proof. exact/addr_gt0/oprob_gt0/oprob_gt0. Qed. + +Lemma oprobadd_neq0 p q : oprob_to_real p + oprob_to_real q != 0. +Proof. +by move: (oprobadd_gt0 p q); rewrite lt_neqAle => /andP -[] /eqP/nesym/eqP. +Qed. + End oprob_lemmas. Lemma prob_mulr {R : realType} (p q : {prob R}) : (0 <= Prob.p p * Prob.p q <= 1)%R. @@ -587,3 +691,124 @@ rewrite subr_eq0. apply: contra H1 => /eqP H1. by apply/eqP/val_inj; rewrite /= p_of_rsE. Qed. + +Section leR_ltR_sumR_finType. +Context {R : realType}. +Variables (A : finType) (f g : A -> R) (P Q : pred A). +Local Open Scope ring_scope. + +Lemma leR_sumR_support (X : {set A}) : + (forall i, i \in X -> P i -> f i <= g i) -> + \sum_(i in X | P i) f i <= \sum_(i in X | P i) g i. +Proof. +move=> H; elim/big_rec2 : _ => //. +move=> a x y /andP[aX Pa] yx. +by apply lerD => //; apply: H. +Qed. + +Lemma leR_sumRl : (forall i, P i -> f i <= g i) -> + (forall i, Q i -> 0 <= g i) -> (forall i, P i -> Q i) -> + \sum_(i | P i) f i <= \sum_(i | Q i) g i. +Proof. +move=> f_g Qg H; elim: (index_enum _) => [| h t IH]. +- rewrite !big_nil. + by rewrite lexx. +- rewrite !big_cons /=; case: ifP => [Ph|Ph]. + by rewrite (H _ Ph); apply lerD => //; exact: f_g. + case: ifP => // Qh; apply: (le_trans IH). + by rewrite -{1}[X in X <= _](add0r _) lerD2r Qg. +Qed. + +Lemma leR_sumRl_support (U : pred A) : + (forall a, 0 <= f a) -> (forall i, P i -> Q i) -> + \sum_(i in U | P i) f i <= \sum_(i in U | Q i) f i. +Proof. +move=> Hf P_Q; elim: (index_enum _) => [|h t IH]. +- by rewrite !big_nil lexx. +- rewrite !big_cons; case: (h \in U) => //=; case: ifP => // Ph. + + by case: ifP => [Qh|]; [rewrite lerD2l | rewrite (P_Q _ Ph)]. + + by case: ifP => // Qh; rewrite -[X in X <= _]add0r; exact/lerD. +Qed. + +Lemma ltR_sumR_support (X : {set A}) : (0 < #|X|)%nat -> + (forall i, i \in X -> f i < g i) -> + \sum_(i in X) f i < \sum_(i in X) g i. +Proof. +move Hn : #|X| => n; elim: n X Hn => // n IH X Hn _ H. +move: (ltn0Sn n); rewrite -Hn card_gt0; case/set0Pn => a0 Ha0. +rewrite (@big_setD1 _ _ _ _ a0 _ f) //= (@big_setD1 _ _ _ _ a0 _ g) //=. +case: n => [|n] in IH Hn. + rewrite (_ : X :\ a0 = set0); first by rewrite !big_set0 2!addr0; exact: H. + move: Hn. + by rewrite (cardsD1 a0) Ha0 /= add1n => -[] /eqP; rewrite cards_eq0 => /eqP. +apply ltrD; first exact/H. +apply IH => //. +- by move: Hn; rewrite (cardsD1 a0) Ha0 /= add1n => -[]. +- by move=> a; rewrite in_setD inE => /andP[_ ?]; exact: H. +Qed. + +Lemma ltR_sumR : (O < #|A|)%nat -> (forall i, f i < g i) -> + \sum_(i in A) f i < \sum_(i in A) g i. +Proof. +move=> A0 H0. +have : forall i : A, i \in [set: A] -> f i < g i by move=> a _; exact/H0. +move/ltR_sumR_support; rewrite cardsT => /(_ A0). +rewrite big_mkcond /= [in X in _ < X]big_mkcond /=. +rewrite (eq_bigr f) //; last by move=> *; rewrite inE. +by rewrite [in X in _ < X](eq_bigr g) // => *; rewrite inE. +Qed. + +End leR_ltR_sumR_finType. + +Section oprob_lemmas2. +Import GRing.Theory. +Local Open Scope ring_scope. +Variable R : realType. +Implicit Types p q : {oprob R}. + +Lemma oprob_mulr_subproof p q : + (0 < Prob.p (OProb.p p) * Prob.p (OProb.p q) < 1)%O. +Proof. +apply/andP; split. + by rewrite mulr_gt0//; apply/oprob_gt0. +by rewrite mulr_ilt1//; apply/oprob_lt1. +Qed. + +Canonical oprobmulr p q := + Eval hnf in @OProb.mk R (probmulr p q) (oprob_mulr_subproof p q). + +Lemma s_of_pq_oprob_subproof p q : (0 < Prob.p [s_of p, q] < 1)%O. +Proof. +rewrite s_of_pqE; apply/andP; split. +- rewrite onem_gt0//= mulr_ilt1 ?onem_ge0 ?onem_lt1//. + by have /andP[] := OProb.O1 p. + by have /andP[] := OProb.O1 q. +- rewrite onem_lt1// mulr_gt0// onem_gt0//. + by have /andP[] := OProb.O1 p. + by have /andP[] := OProb.O1 q. +Qed. + +Canonical oprob_of_s_of_pq p q := + Eval hnf in OProb.mk (s_of_pq_oprob_subproof p q). + +Lemma r_of_pq_oprob_subproof p q : (0 < Prob.p [r_of OProb.p p, OProb.p q] < 1)%O. +Proof. +rewrite r_of_pqE; apply/andP; split. + by rewrite divr_gt0// oprob_gt0. +rewrite ltr_pdivrMr ?mul1r ?oprob_gt0//. +rewrite lt_neqAle; apply/andP; split; last exact/ge_s_of. +rewrite s_of_pqE lt_eqF//. +rewrite onemM !onemK -addrA ltrDl. +by rewrite -[X in 0 < X - _]mul1r -mulrBl -onemE oprob_gt0. +Qed. + +Canonical oprob_of_r_of_pq p q := + Eval hnf in OProb.mk (r_of_pq_oprob_subproof p q). + +Lemma s_of_gt0_oprob p q : 0 < Prob.p [s_of p, q]. +Proof. by rewrite s_of_gt0// oprob_neq0. Qed. + +Lemma r_of_p0_oprob p : [r_of OProb.p p, 0%:pr] = 1%:pr. +Proof. by apply/r_of_p0/oprob_neq0. Qed. + +End oprob_lemmas2. diff --git a/lib/realType_ln.v b/lib/realType_ln.v new file mode 100644 index 00000000..cd9dbefc --- /dev/null +++ b/lib/realType_ln.v @@ -0,0 +1,954 @@ +(* infotheo: information theory and error-correcting codes in Coq *) +(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval. +From mathcomp Require Import mathcomp_extra boolp classical_sets functions. +From mathcomp Require Import reals signed topology normedtype derive. +From mathcomp Require Import sequences exp realfun. +Require Import ssralg_ext realType_ext derive_ext. + +(******************************************************************************) +(* log_n x and n ^ x *) +(* *) +(* Definitions and lemmas about the logarithm and the exponential in base n. *) +(* *) +(* Definitions: *) +(* log == Log in base 2 *) +(* *) +(* Results about the Analysis of ln: *) +(* Section ln_id_sect. *) +(* about the function x |-> ln x - (x - 1) *) +(* Section xlnx_sect. *) +(* about the function x |-> x * ln x *) +(* Section diff_xlnx *) +(* about the function x |-> xlnx (1 - x) - xlnx x. *) +(* Section Rabs_xlnx *) +(* proof that | x - y | <= a implies | xlnx x - xlnx y | <= - xlnx a *) +(* Section log_concave *) +(* concavity of log *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. + +Local Open Scope ring_scope. + +Import Order.TTheory GRing.Theory Num.Theory. + +Import numFieldTopology.Exports. +Import numFieldNormedType.Exports. + +Section ln_ext. +Context {R : realType}. +Implicit Type x : R. + +Lemma ln2_gt0 : 0 < ln 2 :> R. Proof. by rewrite ln_gt0// ltr1n. Qed. + +Lemma ln2_neq0 : ln 2 != 0 :> R. Proof. by rewrite gt_eqF// ln2_gt0. Qed. + +Lemma ln2_ge0 : 0 <= ln 2 :> R. Proof. by rewrite ltW// ln2_gt0. Qed. + +(* TODO: add to MCA? *) +Lemma lt_ln1Dx x : 0 < x -> ln (1 + x) < x. +Proof. +move=> x1. +rewrite -ltr_expR lnK. + by rewrite expR_gt1Dx// gt_eqF. +by rewrite posrE addrC -ltrBlDr sub0r (le_lt_trans _ x1)// lerN10. +Qed. + +Lemma ln_id_cmp x : 0 < x -> ln x <= x - 1. +Proof. +move=> x0. +rewrite -{1}(subrK 1 x) addrC le_ln1Dx//. +by rewrite -ltrBlDr opprK addrC subrr. +Qed. + +Lemma ln_id_eq x : 0 < x -> ln x = x - 1 -> x = 1 :> R. +Proof. +move=> x0 x1lnx. +have [x1|x1|//] := Order.TotalTheory.ltgtP x 1. +- exfalso. + move: x1lnx; apply/eqP; rewrite lt_eqF//. + rewrite -ltr_expR lnK//. + rewrite -{1}(GRing.subrK 1 x) addrC. + by rewrite expR_gt1Dx// subr_eq0 lt_eqF//. +- exfalso. + move: x1lnx; apply/eqP; rewrite lt_eqF//. + by rewrite -{1}(GRing.subrK 1 x) addrC lt_ln1Dx// subr_gt0. +Qed. + +End ln_ext. + +Section Log. +Context {R : realType}. +Implicit Type x : R. + +Definition Log (n : nat) x : R := ln x / ln n.-1.+1%:R. + +Lemma Log1 (n : nat) : Log n 1 = 0 :> R. +Proof. by rewrite /Log ln1 mul0r. Qed. + +Lemma ler_Log (n : nat) : (1 < n)%N -> {in Num.pos &, {mono Log n : x y / x <= y :> R}}. +Proof. +move=> n1 x y x0 y0. +rewrite /Log ler_pdivrMr prednK ?(leq_trans _ n1)// ?ln_gt0 ?ltr1n//. +by rewrite -mulrA mulVf ?mulr1 ?gt_eqF ?ln_gt0 ?ltr1n// ler_ln. +Qed. + +Lemma LogV n x : 0 < x -> Log n x^-1 = - Log n x. +Proof. by move=> x0; rewrite /Log lnV ?posrE// mulNr. Qed. + +Lemma LogM n x y : 0 < x -> 0 < y -> Log n (x * y) = Log n x + Log n y. +Proof. by move=> *; rewrite /Log -mulrDl lnM. Qed. + +Lemma LogDiv n x y : 0 < x -> 0 < y -> Log n (x / y) = Log n x - Log n y. +Proof. by move=> x0 y0; rewrite LogM ?invr_gt0// LogV. Qed. + +(* TODO: deprecate; use ler_Log *) +Lemma Log_increasing_le n x y : (1 < n)%N -> 0 < x -> x <= y -> Log n x <= Log n y. +Proof. +move=> n1 x0 xy. +apply ler_wpM2r. + rewrite invr_ge0// ltW// ln_gt0//. + by case: n n1 => //= n; rewrite ltr1n. +by rewrite ler_ln// posrE (lt_le_trans x0). +Qed. + +End Log. + +Section Exp. +Context {R : realType}. +Implicit Type x : R. + +(* TODO: rename *) +Lemma powRrM' x (n : R) k : x `^ (n * k%:R) = (x `^ n) ^+ k. +Proof. by rewrite powRrM powR_mulrn// powR_ge0. Qed. + +Lemma LogK n x : (1 < n)%N -> 0 < x -> n%:R `^ (Log n x) = x. +Proof. +move=> n1 x0. +rewrite /Log prednK// 1?ltnW//. +rewrite powRrM {1}/powR ifF; last first. + by apply/negbTE; rewrite powR_eq0 negb_and pnatr_eq0 gt_eqF// ltEnat/= ltnW. +rewrite ln_powR mulrCA mulVf//. + by rewrite mulr1 lnK ?posrE. +by rewrite gt_eqF// -ln1 ltr_ln ?posrE// ?ltr1n// ltr0n ltnW. +Qed. + +(* TODO: move to MCA? *) +Lemma gt1_ltr_powRr (n : R) x y : 1 < n -> x < y -> n `^ x < n `^ y. +Proof. +move=> n1 xy; rewrite /powR ifF; last first. + by apply/negbTE; rewrite gt_eqF// (lt_trans _ n1). +rewrite ifF//; last first. + by apply/negbTE; rewrite gt_eqF// (lt_trans _ n1). +by rewrite ltr_expR// ltr_pM2r// ln_gt0// ltr1n. +Qed. + +(* TODO: move to MCA? *) +Lemma gt1_ler_powRr (n : R) x y : 1 < n -> x <= y -> n `^ x <= n `^ y. +Proof. by move=> n1 xy; rewrite ler_powR// ltW. Qed. + +(* TODO: move *) +Lemma powR2D : {morph (fun x => 2 `^ x) : x y / x + y >-> x * y}. +Proof. by move=> ? ? /=; rewrite powRD// pnatr_eq0// implybT. Qed. + +Lemma powR2sum (I : Type) (r : seq I) (P0 : pred I) (F : I -> R) : + 2 `^ (\sum_(i <- r | P0 i) F i) = \prod_(i <- r | P0 i) 2 `^ F i. +Proof. +by rewrite (big_morph [eta powR 2] powR2D (powRr0 2)). +Qed. + +End Exp. + +Hint Extern 0 (0 <= _ `^ _) => solve [exact/powR_ge0] : core. +Hint Extern 0 (0 < _ `^ _) => solve [exact/powR_gt0] : core. + +Section log. +Context {R : realType}. +Implicit Types x y : R. + +Definition log x := Log 2 x. + +Lemma log1 : log 1 = 0 :> R. +Proof. by rewrite /log Log1. Qed. + +Lemma log2 : log 2 = 1 :> R. +Proof. by rewrite /log /Log divff// gt_eqF// ln2_gt0. Qed. + +Lemma ler_log : {in Num.pos &, {mono log : x y / x <= y :> R}}. +Proof. by move=> x y x0 y0; rewrite /log ler_Log. Qed. + +Lemma logK x : 0 < x -> 2 `^ (log x) = x. +Proof. by move=> x0; rewrite /log LogK. Qed. + +Lemma logV x : 0 < x -> log x^-1 = - log x :> R. +Proof. by move=> x0; rewrite /log LogV. Qed. + +Lemma logM x y : 0 < x -> 0 < y -> log (x * y) = log x + log y. +Proof. move=> x0 y0; exact: (@LogM _ 2 _ _ x0 y0). Qed. + +Lemma logX2 n : log (2 ^+ n) = n%:R :> R. +Proof. +elim: n; rewrite ?expr0 ?log1// => n ih. +by rewrite exprS logM ?exprn_gt0// ih log2 nat1r. +Qed. + +Lemma log4 : log 4 = 2 :> R. +Proof. +rewrite (_ : 4 = 2 ^+ 2); last by rewrite -natrX. +by rewrite logX2. +Qed. + +Lemma log8 : log 8 = 3 :> R. +Proof. +rewrite (_ : 8 = 2 ^+ 3); last by rewrite -natrX. +by rewrite logX2. +Qed. + +Lemma log16 : log 16 = 4 :> R. +Proof. +rewrite (_ : 16 = 2 ^+ 4); last by rewrite -natrX. +by rewrite logX2. +Qed. + +Lemma log32 : log 32 = 5 :> R. +Proof. +rewrite (_ : 32 = 2 ^+ 5); last by rewrite -natrX. +by rewrite logX2. +Qed. + +Lemma logDiv x y : 0 < x -> 0 < y -> log (x / y) = log x - log y. +Proof. by move=> x0 y0; exact: (@LogDiv _ _ _ _ x0 y0). Qed. + +(* TODO: rename, lemma for Log *) +Lemma logexp1E : log (expR 1) = (ln 2)^-1 :> R. +Proof. by rewrite /log /Log/= expRK div1r. Qed. + +Lemma log_exp1_Rle_0 : 0 <= log (expR 1) :> R. +Proof. +by rewrite logexp1E invr_ge0// ltW// ln2_gt0. +Qed. + +Lemma log_id_cmp x : 0 < x -> log x <= (x - 1) * log (expR 1). +Proof. +move=> x0; rewrite logexp1E ler_wpM2r// ?invr_ge0//= ?(ltW (@ln2_gt0 _))//. +exact/ln_id_cmp. +Qed. + +Lemma log_powR (a : R) x : log (a `^ x) = x * log a. +Proof. +by rewrite /log /Log ln_powR// mulrA. +Qed. + +Lemma ltr_log (a b : R) : 0 < a -> a < b -> log a < log b. +Proof. +move=> Ha a_b. +rewrite /log /Log prednK// ltr_pM2r ?invr_gt0 ?ln2_gt0//. +by rewrite ltr_ln ?posrE// (lt_trans _ a_b). +Qed. + +(* TODO: deprecate; use ler_log *) +Lemma log_increasing_le x y : 0 < x -> x <= y -> log x <= log y. +Proof. by move=> x0 xy; exact: (@Log_increasing_le R 2 _ _ isT x0 xy). Qed. + +End log. + +Lemma log_prodr_sumr_mlog {R : realType} {A : finType} (f : A -> R) s : + (forall a, 0 <= f a) -> + (forall i, 0 < f i) -> + - log (\prod_(i <- s) f i) = \sum_(i <- s) - log (f i). +Proof. +move=> f0 f0'. +elim: s => [|h t ih]. + by rewrite !big_nil log1 oppr0. +rewrite big_cons logM//; last exact/prodr_gt0. +by rewrite [RHS]big_cons opprD ih. +Qed. + +Lemma log_exprz {R : realType} (n : nat) (r : R) : + 0 < r -> log (r ^ n) = n%:R * log r. +Proof. +elim: n => [|n' IH lt_0_r]; first by rewrite log1 mul0r. +rewrite exprSz logM ?exprn_gt0// IH//. +by rewrite -nat1r mulrDl mul1r. +Qed. + +From mathcomp Require Import topology normedtype. + +Lemma exp_strict_lb {R : realType} (n : nat) (x : R) : + 0 < x -> x ^+ n / n`!%:R < expR x. +Proof. +move=> x0. +case: n => [|n]. + by rewrite expr0 fact0 mul1r invr1 pexpR_gt1. +rewrite expRE. +rewrite (lt_le_trans _ (nondecreasing_cvgn_le _ _ n.+2))//=. +- rewrite /pseries/= /series/=. + rewrite big_mkord big_ord_recr/=. + rewrite [in ltRHS]mulrC ltrDr lt_neqAle; apply/andP; split. + rewrite eq_sym psumr_neq0//=. + apply/hasP; exists ord0. + by rewrite mem_index_enum. + by rewrite fact0 expr0 invr1 mulr1. + move=> i _. + by rewrite mulr_ge0 ?exprn_ge0 ?invr_ge0// ltW. + rewrite sumr_ge0// => i _. + by rewrite mulr_ge0 ?invr_ge0// exprn_ge0// ltW. +- move=> a b ab. + rewrite /pseries/= /series/=. + rewrite -(subnKC ab) /index_iota !subn0 iotaD big_cat//=. + rewrite ler_wpDr// sumr_ge0// => i _. + by rewrite mulr_ge0 ?invr_ge0// exprn_ge0// ltW. +- have := is_cvg_series_exp_coeff_pos x0. + rewrite /exp_coeff /pseries /series/=. + by under boolp.eq_fun do under eq_bigr do rewrite mulrC. +Qed. + +(* TODO: move to MCA *) +Lemma derivable_ln {R : realType} x : 0 < x -> derivable (@ln R) x 1. +Proof. by move=> x0; apply: ex_derive; exact: is_derive1_ln. Qed. + +(* TODO: move *) +Lemma gt0_near_nbhs {R : realType} (x : R) : 0 < x -> + \forall x0 \near nbhs x, 0 < x0. +Proof. +move=> x0. +exists (x / 2) => //=. + by rewrite divr_gt0//. +move=> A/=. +have [//|A0] := ltP 0 A. +rewrite ltNge => /negP; rewrite boolp.falseE; apply. +rewrite ger0_norm ?subr_ge0; last first. + by rewrite (le_trans A0)// ltW. +rewrite lerBrDr. +rewrite (@le_trans _ _ (x/2))//. +rewrite gerDl//. +by rewrite ler_piMr// ltW// invf_lt1// ltr1n. +Unshelve. all: by end_near. Qed. + +(* TODO: PR to analysis *) +Lemma ltr0_derive1_decr (R : realType) (f : R -> R) (a b : R) : + (forall x, x \in `]a, b[%R -> derivable f x 1) -> + (forall x, x \in `]a, b[%R -> f^`() x < 0) -> + {within `[a, b], continuous f}%classic -> + forall x y, a <= x -> x < y -> y <= b -> f y < f x. +Proof. +move=> fdrvbl dflt0 ctsf x y leax ltxy leyb; rewrite -subr_gt0. +case: ltgtP ltxy => // xlty _. +have itvW : {subset `[x, y]%R <= `[a, b]%R}. + by apply/subitvP; rewrite /<=%O /= /<=%O /= leyb leax. +have itvWlt : {subset `]x, y[%R <= `]a, b[%R}. + by apply subitvP; rewrite /<=%O /= /<=%O /= leyb leax. +have fdrv z : z \in `]x, y[%R -> is_derive z 1 f (f^`()z). + rewrite in_itv/= => /andP[xz zy]; apply: DeriveDef; last by rewrite derive1E. + by apply: fdrvbl; rewrite in_itv/= (le_lt_trans _ xz)// (lt_le_trans zy). +have [] := @MVT _ f (f^`()) x y xlty fdrv. + apply: (@continuous_subspaceW _ _ _ `[a, b]); first exact: itvW. + by rewrite continuous_subspace_in. +move=> t /itvWlt dft dftxy; rewrite -oppr_lt0 opprB dftxy. +by rewrite pmulr_llt0 ?subr_gt0// dflt0. +Qed. + +(* TODO: PR to analysis *) +Lemma gtr0_derive1_incr (R : realType) (f : R -> R) (a b : R) : + (forall x, x \in `]a, b[%R -> derivable f x 1) -> + (forall x, x \in `]a, b[%R -> 0 < f^`() x) -> + {within `[a, b], continuous f}%classic -> + forall x y, a <= x -> x < y -> y <= b -> f x < f y. +Proof. +move=> fdrvbl dfgt0 ctsf x y leax ltxy leyb. +rewrite -ltrN2; apply: (@ltr0_derive1_decr _ (\- f) a b). +- by move=> z zab; apply: derivableN; exact: fdrvbl. +- move=> z zab; rewrite derive1E deriveN; last exact: fdrvbl. + by rewrite ltrNl oppr0 -derive1E dfgt0. +- by move=> z; apply: continuousN; exact: ctsf. +- exact: leax. +- exact: ltxy. +- exact: leyb. +Qed. + + +Section differentiable. + +Lemma differentiable_ln {R : realType} (x : R) : 0 < x -> differentiable (@ln R) x. +Proof. move=>?; exact/derivable1_diffP/ex_derive/is_derive1_ln. Qed. + +Lemma differentiable_Log {R : realType} (n : nat) (x : R) : + 0 < x -> (1 < n)%nat -> differentiable (@Log R n) x. +Proof. +move=> *. +apply: differentiableM. + exact: differentiable_ln. +apply: differentiableV=> //. +rewrite prednK; last exact: (@ltn_trans 1). +by rewrite neq_lt ln_gt0 ?orbT// ltr1n. +Qed. + +End differentiable. + +Lemma is_derive1_Logf [R : realType] [f : R -> R] [n : nat] [x Df : R] : + is_derive x 1 f Df -> 0 < f x -> (1 < n)%nat -> + is_derive x 1 (Log n (R := R) \o f) ((ln n%:R)^-1 * Df / f x). +Proof. +move=> hf fx0 n1. +rewrite (mulrC _ Df) -mulrA mulrC. +apply: is_derive1_comp. +rewrite mulrC; apply: is_deriveM_eq. + exact: is_derive1_ln. +rewrite scaler0 add0r prednK 1?(@ltn_trans 1)//. +by rewrite mulr_regl; exact: mulrC. +Qed. + +Lemma is_derive1_Logf_eq [R : realType] [f : R -> R] [n : nat] [x Df D : R] : + is_derive x 1 f Df -> 0 < f x -> (1 < n)%nat -> + (ln n%:R)^-1 * Df / f x = D -> + is_derive x 1 (Log n (R := R) \o f) D. +Proof. by move=> ? ? ? <-; exact: is_derive1_Logf. Qed. + +Lemma is_derive1_LogfM [R : realType] [f g : R -> R] [n : nat] [x Df Dg : R] : + is_derive x 1 f Df -> is_derive x 1 g Dg -> + 0 < f x -> 0 < g x -> (1 < n)%nat -> + is_derive x 1 (Log n (R := R) \o (f * g)) ((ln n%:R)^-1 * (Df / f x + Dg / g x)). +Proof. +move=> hf hg fx0 gx0 n1. +apply: is_derive1_Logf_eq=> //. + exact: mulr_gt0. +rewrite -!mulr_regr /(f * g) invfM /= -mulrA; congr (_ * _). +rewrite addrC (mulrC _^-1) mulrDl; congr (_ + _); rewrite -!mulrA; congr (_ * _). + by rewrite mulrA mulfV ?gt_eqF // div1r. +by rewrite mulrCA mulfV ?gt_eqF // mulr1. +Qed. + +Lemma is_derive1_LogfM_eq [R : realType] [f g : R -> R] [n : nat] [x Df Dg D : R] : + is_derive x 1 f Df -> is_derive x 1 g Dg -> + 0 < f x -> 0 < g x -> (1 < n)%nat -> + (ln n%:R)^-1 * (Df / f x + Dg / g x) = D -> + is_derive x 1 (Log n (R := R) \o (f * g)) D. +Proof. by move=> ? ? ? ? ? <-; exact: is_derive1_LogfM. Qed. + +Lemma is_derive1_LogfV [R : realType] [f : R -> R] [n : nat] [x Df : R] : + is_derive x 1 f Df -> 0 < f x -> (1 < n)%nat -> + is_derive x 1 (Log n (R := R) \o (inv_fun f)) (- (ln n%:R)^-1 * (Df / f x)). +Proof. +move=> hf fx0 n1. +apply: is_derive1_Logf_eq=> //; + [by apply/is_deriveV; rewrite gt_eqF | by rewrite invr_gt0 |]. +rewrite invrK -mulr_regl !(mulNr,mulrN) -mulrA; congr (- (_ * _)). +by rewrite expr2 invfM mulrC !mulrA mulfV ?gt_eqF // div1r mulrC. +Qed. + +Lemma is_derive1_LogfV_eq [R : realType] [f : R -> R] [n : nat] [x Df D : R] : + is_derive x 1 f Df -> 0 < f x -> (1 < n)%nat -> + - (ln n%:R)^-1 * (Df / f x) = D -> + is_derive x 1 (Log n (R := R) \o (inv_fun f)) D. +Proof. by move=> ? ? ? <-; exact: is_derive1_LogfV. Qed. + +Section xlnx_sect. + +Section xlnx. +Context {R : realType}. + +Definition xlnx_total (y : R) := y * ln y. + +Lemma derivable_xlnx_total x : 0 < x -> derivable xlnx_total x 1. +Proof. by move=> x0; apply: derivableM => //; exact: derivable_ln. Qed. + +Lemma xlnx_total_neg (x : R) : 0 < x < 1 -> xlnx_total x < 0. +Proof. +case/andP => lt0x ltx1. +rewrite -(opprK 0) ltrNr oppr0 -mulrN. +apply mulr_gt0 => //. +by rewrite ltrNr oppr0 ln_lt0// lt0x. +Qed. + +Lemma continuous_at_xlnx_total (r : R) : 0 < r -> continuous_at r xlnx_total. +Proof. by move=> r0; apply: cvgM => //; exact: continuous_ln. Qed. + +Definition xlnx (x : R) := if 0 < x then xlnx_total x else 0. + +Lemma xlnx_0 : xlnx 0 = 0. +Proof. by rewrite /xlnx ltxx. Qed. + +Lemma xlnx_1 : xlnx 1 = 0. +Proof. by rewrite /xlnx ltr01 /xlnx_total ln1 mulr0. Qed. + +Lemma xlnx_neg x : 0 < x < 1 -> xlnx x < 0. +Proof. by move=> /andP[x0 x1]; rewrite /xlnx x0 xlnx_total_neg ?x0. Qed. + +Lemma continuous_at_xlnx (r : R) : continuous_at r xlnx. +Proof. +apply/cvgrPdist_le => /= eps eps_pos. +have [r_gt0|r_lt0|<-{r}] := ltgtP 0 r. +- have := continuous_at_xlnx_total r_gt0. + move=> /cvgrPdist_le/(_ _ eps_pos)[k/= k_pos Hk]. + exists (Num.min k r). + by rewrite lt_min r_gt0 k_pos. + move=> x/=; rewrite lt_min => /andP[rxk rxr]. + rewrite /xlnx r_gt0. + have -> : 0 < x. + rewrite -(addr0 x) -[in ltRHS](subrr r) addrA addrAC. + apply (@le_lt_trans _ _ ((x + - r) + `| x + - r |)). + by rewrite addrC -lerBlDr sub0r -normrN ler_norm. + by rewrite ltrD2l distrC. + exact: Hk. +- exists (- r). + by rewrite ltrNr oppr0. + move=> x/= rxr. + rewrite /xlnx. + have -> : 0 < x = false. + apply/negbTE. + rewrite -leNgt. + rewrite -(addr0 x) -{1}(subrr r) addrA addrAC. + apply (@le_trans _ _ ((x + - r) - `| x + - r |)). + by rewrite lerD2l lerNr distrC ltW. + by rewrite subr_le0 ler_norm. + have -> : (0 < r) = false. + by apply/negbTE; rewrite -leNgt; apply/ltW. + by rewrite subrr normr0 ltW. +- exists (expR (- 2 / eps)); first by rewrite expR_gt0. + move=> x/=; rewrite sub0r normrN => Hx2. + rewrite /xlnx ltxx sub0r normrN. + case: ifPn => Hcase; last by rewrite normr0 ltW. + rewrite (ger0_norm (ltW Hcase)) in Hx2. + rewrite -{1}(lnK Hcase). + set X := ln x. + have X_neg : X < 0. + apply (@lt_trans _ _ (-2 / eps)). + by rewrite -ltr_expR lnK. + by rewrite mulNr ltrNl oppr0 divr_gt0//. + apply/ltW. + apply: (@lt_le_trans _ _ (2 / (- X))). + + rewrite ltr0_norm; last first. + by rewrite /xlnx_total pmulr_rlt0 ?expR_gt0 ?lnK. + rewrite -mulrN. + rewrite -(@ltr_pM2r _ ((- X)^-1)); last first. + by rewrite invr_gt0 ltrNr oppr0. + rewrite lnK// -mulrA divff ?mulr1; last first. + by rewrite oppr_eq0 lt_eqF. + rewrite -(invrK 2) -mulrA. + rewrite invrN mulNr (mulrN (X^-1)) opprK -invfM -expr2 invrK. + rewrite (_ : 2 = 2`!%:R)//. + have := @exp_strict_lb _ 2 (- X). + rewrite ltrNr oppr0 => /(_ X_neg). + rewrite expRN. + rewrite -[X in X < _ -> _]invrK. + rewrite ltf_pV2 ?posrE ?expR_gt0 ?invr_gt0 ?mulr_gt0//=; last 3 first. + by rewrite ltrNr oppr0. + by rewrite ltrNr oppr0. + by rewrite invr_gt0. + by rewrite lnK// sqrrN invf_div. + + move: Hx2. + rewrite -ltr_ln ?posrE ?expR_gt0//. + rewrite -/X. + rewrite expRK. + rewrite mulNr ltrNr. + rewrite ltr_pdivrMr//. + by rewrite -ltr_pdivrMl 1?ltrNr ?oppr0// mulrC => /ltW. +Qed. + +Lemma derivable_xlnx x : 0 < x -> derivable xlnx x 1. +Proof. +move=> x0; rewrite (near_eq_derivable _ xlnx_total)//. +- exact: derivable_xlnx_total. +- near=> z. + rewrite /xlnx ifT//. + near: z. + exact: gt0_near_nbhs. +Unshelve. all: by end_near. Qed. + +Lemma derive_xlnxE x : 0 < x -> 'D_1 xlnx x = ln x + 1. +Proof. +move=> x_pos. +rewrite /xlnx. +transitivity ('D_1 (fun x0 : R^o => x0 * ln x0) x). + apply: near_eq_derive. + by rewrite oner_eq0. + near=> z. + rewrite ifT//. + near: z. + exact: gt0_near_nbhs. +rewrite deriveM//=; last exact: derivable_ln. +rewrite derive_val addrC; congr +%R. + by rewrite /GRing.scale/= mulr1. +rewrite (@derive_val _ _ _ _ _ _ _ (is_derive1_ln x_pos)). +by rewrite -(@mulfV _ x)// gt_eqF. +Unshelve. all: by end_near. Qed. + +(* +Lemma pderivable_Ropp_xlnx : pderivable (fun y => - xlnx y) (fun x => 0 < x <= exp (- 1)). +Proof. +move=> x /= Hx. +apply derivable_pt_opp. +apply derivable_pt_xlnx. +apply Hx. +Defined. + +Lemma xlnx_sdecreasing_0_Rinv_e_helper : forall (t : R) (Ht : 0 < t <= exp (-1)), + 0 < (if t == exp (-1) then 1 else derive_pt (fun x => - xlnx x) t (pderivable_Ropp_xlnx Ht)). +Proof. +move=> t [t0 te]; case: ifPn => [//|] /eqP Hcase. +rewrite derive_pt_opp derive_pt_xlnx //. +rewrite ltR_oppr oppR0 addRC -ltR_subRL sub0R. +apply exp_lt_inv; by rewrite exp_ln // ltR_neqAle. +Qed. +*) + +Lemma xlnx_sdecreasing_0_Rinv_e x y : + 0 <= x <= expR (-1) -> + 0 <= y <= expR (-1) -> x < y -> xlnx y < xlnx x. +Proof. +move=> /andP[x1 x2] /andP[y1 y2] xy. +have [->|x0] := eqVneq x 0. +- rewrite xlnx_0; apply xlnx_neg. + rewrite (le_lt_trans x1 xy)/=. + rewrite (le_lt_trans y2)//. + by rewrite expR_lt1// ltrN10. +- rewrite -[X in _ < X]opprK ltrNr. + have {}x0 : 0 < x. + by rewrite lt_neqAle eq_sym x0 x1. + have {x1 y1}y0 : 0 < y. + by rewrite (le_lt_trans x1). + apply: (@derivable1_mono _ (BRight 0) (BRight (expR (-1))) (fun x => - xlnx x)) => //. + + by rewrite in_itv//= (x0). + + by rewrite in_itv//= (y0). + + move=> /= z. + rewrite in_itv/= => /andP[z0 z1]. + apply: derivableN. + by apply: derivable_xlnx => //. + + move=> /= t. + rewrite in_itv/= => /andP[tx ty]. + rewrite [ltRHS](_ : _ = 'D_1 (fun x : R => - (x * ln x)) t); last first. + apply: near_eq_derive. + by rewrite oner_eq0. + near=> z. + rewrite /xlnx. + case: ifPn => z0 //. + rewrite oppr0. + by rewrite ln0 ?mulr0// ?oppr0// leNgt. + rewrite deriveN; last first. + apply: derivableM => //. + apply: ex_derive. + apply: is_derive1_ln. + by rewrite (lt_trans _ tx). + rewrite ltrNr oppr0. + rewrite deriveM//; last first. + apply: ex_derive. + apply: is_derive1_ln. + by rewrite (lt_trans _ tx). + have := is_derive1_ln (lt_trans x0 tx). + move/(@derive_val R R^o R^o) => ->. + rewrite derive_id [X in X + _]mulfV ?gt_eqF//; last by rewrite (lt_trans x0). + rewrite (@lt_le_trans _ _ (1 + ln y))//. + rewrite ltrD2l. + rewrite /GRing.scale/= mulr1. + by rewrite ltr_ln ?posrE ?(lt_trans x0)// ltW. + rewrite (@le_trans _ _ (1 + ln (expR (-1))))//. + by rewrite lerD2l ler_ln ?posrE// expR_gt0. + by rewrite expRK subrr. +Unshelve. all: by end_near. Qed. + +Lemma xlnx_decreasing_0_Rinv_e x y : + 0 <= x <= expR (-1) -> 0 <= y <= expR (-1) -> x <= y -> xlnx y <= xlnx x. +Proof. +move=> Hx Hy Hxy. +have [->|/eqP H] := eqVneq x y; first by rewrite lexx. +apply/ltW/xlnx_sdecreasing_0_Rinv_e => //. +rewrite lt_neqAle Hxy andbT. +exact/eqP. +Qed. + +End xlnx. + +Section diff_xlnx. +Context {R : realType}. + +Definition diff_xlnx (x : R) := xlnx (1 - x) - xlnx x. + +Lemma derivable_pt_diff_xlnx x : 0 < x < 1 -> derivable diff_xlnx x 1. +Proof. +move=> /andP[x0 x1]. +apply: derivableB. + apply/derivable1_diffP. + have := (@differentiable_comp _ _ _ _ (fun t : R^o => 1 - t)%R + (xlnx: R^o -> R^o)). + apply => //. + apply/derivable1_diffP. + apply: derivable_xlnx. + by rewrite subr_gt0. +exact: derivable_xlnx. +Qed. + +Lemma derive_pt_diff_xlnx x : 0 < x < 1 -> + derivable diff_xlnx x 1 -> + 'D_1 diff_xlnx x = -(2 + ln (x * (1-x))). +Proof. +move=> /andP[] x0 x1 H. +rewrite deriveB/=; last 2 first. + (* TODO: copy past *) + apply/derivable1_diffP. + have := (@differentiable_comp _ _ _ _ (fun t : R^o => 1 - t)%R xlnx). + apply => //. + apply/derivable1_diffP. + apply: derivable_xlnx. + by rewrite subr_gt0. + exact: derivable_xlnx. +rewrite -derive1E derive1_comp; last 2 first. + apply: derivableB. + exact: derivable_cst. + exact: derivable_id. + apply: derivable_xlnx. + by rewrite subr_gt0. +rewrite derive_xlnxE//. +rewrite [X in X * _]derive1E. +rewrite derive_xlnxE; last by rewrite subr_gt0. +rewrite derive1E deriveB; last 2 first. + exact: derivable_cst. + exact: derivable_id. +rewrite derive_cst derive_id sub0r mulrN1 -opprB; congr (- _). +rewrite opprK addrACA addrC; congr +%R. +by rewrite lnM// posrE subr_gt0. +Qed. + +Lemma diff_xlnx_0 : diff_xlnx 0 = 0. +Proof. by rewrite /diff_xlnx subr0 xlnx_0 xlnx_1 subrr. Qed. + +(* +Lemma diff_xlnx_1 : diff_xlnx 1 = 0. +Proof. by rewrite /diff_xlnx subRR xlnx_0 xlnx_1 subRR. Qed. +*) + +Lemma derive_diff_xlnx_gt0 x : 0 < x < 1 -> x < expR (-2) -> 0 < 'D_1 diff_xlnx x. +Proof. +move=> /andP[x0 x1] xltexp2. +rewrite derive_pt_diff_xlnx; last 2 first. + by rewrite x0. + apply: derivable_pt_diff_xlnx. + by rewrite x0. +rewrite ltrNr oppr0. +rewrite -[X in X + _]opprK addrC. +rewrite subr_lt0. +rewrite -ltr_expR lnK; last first. + by rewrite posrE mulr_gt0// subr_gt0. +apply: (@lt_trans _ _ (expR (-2) * (1 - x))). + by rewrite ltr_pM2r ?subr_gt0. +rewrite -[ltRHS]mulr1. +rewrite ltr_pM2l ?expR_gt0//. +by rewrite ltrBlDl addrC -ltrBlDl subrr. +Qed. + +Lemma continuous_at_diff_xlnx (r : R) : continuous_at r diff_xlnx. +Proof. +move=> z. +apply: cvgB => //. + apply: cvg_comp; last exact: continuous_at_xlnx. + apply: cvgB => //. + exact: cvg_cst. +by apply: continuous_at_xlnx. +Qed. + +Lemma diff_xlnx_sincreasing_0_Rinv_e2 (x y : R) : + 0 <= x <= expR (-2) -> 0 <= y <= expR (-2) -> + x < y -> diff_xlnx x < diff_xlnx y. +Proof. +move=> /andP[x0 x2] /andP[y0 y2] xy. +apply: (@gtr0_derive1_incr _ _ 0 (expR (- 2))) => //. +- move=> z; rewrite in_itv/= => /andP[z0 z2]. + apply: derivable_pt_diff_xlnx. + by rewrite z0/= (lt_le_trans z2)// -[leRHS]expR0 ler_expR lerNl oppr0. +- move=> z; rewrite in_itv/= => /andP[z0 z2]. + rewrite derive1E derive_diff_xlnx_gt0// z0/=. + by rewrite (lt_le_trans z2)// -[leRHS]expR0 ler_expR lerNl oppr0. +- apply: continuous_subspaceT => z. + exact: continuous_at_diff_xlnx. +Qed. + +Lemma xlnx_ineq (x : R) : 0 <= x <= expR (-2) -> xlnx x <= xlnx (1-x). +Proof. +move=> /andP[Hx1 Hx2]. +rewrite -subr_ge0. +rewrite -diff_xlnx_0 -/(diff_xlnx x). +have [->|/eqP Hnot0] := eqVneq 0 x; first by rewrite lexx. +apply/ltW/diff_xlnx_sincreasing_0_Rinv_e2 => //. + by rewrite lexx expR_ge0. + by rewrite Hx1 Hx2. +rewrite lt_neqAle Hx1 andbT. +exact/eqP. +Qed. + +End diff_xlnx. + +Section Rabs_xlnx. +Context {R : realType}. + +Definition xlnx_delta a (x : R) := xlnx (x + a) - xlnx x. + +Lemma derivable_xlnx_delta (eps : R) (Heps : 0 < eps < 1) x (Hx : 0 < x < 1 - eps) : + derivable (xlnx_delta eps) x 1. +Proof. +rewrite /xlnx_delta. +apply: derivableB => /=. + apply/derivable1_diffP/differentiable_comp => //. + apply/derivable1_diffP. + apply: derivable_xlnx. + move: Heps Hx => /andP[? _] /andP[? _]. + by rewrite addr_gt0. +apply: derivable_xlnx. +by case/andP : Hx. +Qed. + +Lemma derive_pt_xlnx_delta eps (Heps : 0 < eps < 1) x (Hx : 0 < x < 1 - eps) : + 'D_1 (xlnx_delta eps) x = ln (x + eps) - ln x. +Proof. +rewrite deriveB//=; last 2 first. + apply/derivable1_diffP/differentiable_comp => //. + apply/derivable1_diffP. + apply: derivable_xlnx. + rewrite addr_gt0//. + by case/andP: Hx. + by case/andP: Heps. + apply: derivable_xlnx. + by case/andP : Hx. +rewrite derive_xlnxE; last first. + by case/andP: Hx. +rewrite -derive1E. +rewrite derive1_comp//; last first. + apply: derivable_xlnx. + rewrite addr_gt0//. + by case/andP: Hx. + by case/andP: Heps. +rewrite derive1E derive_xlnxE; last first. + rewrite addr_gt0//. + by case/andP: Hx. + by case/andP: Heps. +rewrite derive1E. +rewrite deriveD//. +rewrite derive_id derive_cst addr0 mulr1. +by rewrite opprD addrACA subrr addr0. +Qed. + +Lemma continuous_at_xlnx_delta (r : R) eps : continuous_at r (xlnx_delta eps). +Proof. +move=> z. +apply: cvgB. + apply: cvg_comp; last first. + exact: continuous_at_xlnx. + apply: cvgD. + exact: cvg_id. + exact: cvg_cst. +exact: continuous_at_xlnx. +Qed. + +Lemma increasing_xlnx_delta eps (Heps : 0< eps < 1) : + forall x y : R, 0 <= x <= 1 - eps -> 0 <= y <= 1 - eps -> x < y -> + xlnx_delta eps x < xlnx_delta eps y. +Proof. +move=> x y /andP[x0 x1] /andP[y0 y1] xy. +apply: (@gtr0_derive1_incr _ _ 0 (1 - eps)) => //. +- move=> z; rewrite in_itv/= => /andP[z0 z1]. + apply: derivable_xlnx_delta => //. + by rewrite z0. +- move=> z; rewrite in_itv/= => /andP[z0 z1]. + rewrite derive1E derive_pt_xlnx_delta//. + rewrite subr_gt0 ltr_ln ?posrE//. + by rewrite ltrDl; case/andP : Heps. + by rewrite addr_gt0//; case/andP : Heps. + by rewrite z0. +- apply: continuous_subspaceT => z. + exact: continuous_at_xlnx_delta. +Qed. + +Lemma xlnx_delta_bound eps : 0 < eps <= expR (-2) -> + forall x, 0 <= x <= 1 - eps -> `| xlnx_delta eps x | <= - xlnx eps. +Proof. +move=> /andP[Heps1 Heps2] x /andP[Hx1 Hx2]. +rewrite ler_norml; apply/andP; split. +- rewrite opprK (_ : xlnx eps = xlnx_delta eps 0); last first. + by rewrite /xlnx_delta add0r xlnx_0 subr0. + have [->|xnot0] := eqVneq x 0; first by rewrite lexx. + apply/ltW/increasing_xlnx_delta => //. + + rewrite Heps1/=. + by rewrite (le_lt_trans Heps2)// expR_lt1// ltrNl oppr0//. + + rewrite lexx/= subr_ge0. + rewrite (le_trans Heps2)//. + by rewrite ltW// expR_lt1// ltrNl oppr0//. + + by rewrite Hx1. + + by rewrite lt_neqAle eq_sym xnot0. +- apply: (@le_trans _ _ (xlnx_delta eps (1 - eps))). + have [->|xnot0] := eqVneq x (1 - eps); first by rewrite lexx. + apply/ltW/increasing_xlnx_delta => //. + + rewrite Heps1/=. + by rewrite (le_lt_trans Heps2)// expR_lt1// ltrNl oppr0//. + + by rewrite Hx1. + + rewrite lexx andbT subr_ge0. + rewrite (le_trans Heps2)//. + by rewrite ltW// expR_lt1// ltrNl oppr0//. + + by rewrite lt_neqAle xnot0/=. + rewrite /xlnx_delta subrK xlnx_1 sub0r lerNr opprK. + apply: xlnx_ineq. + by rewrite (ltW Heps1)/=. +Qed. + +(* TODO: rename *) +Lemma Rabs_xlnx (a : R) (Ha : 0 <= a <= expR (-2)) x y : + 0 <= x <= 1 -> 0 <= y <= 1 -> `| x - y | <= a -> + `| xlnx x - xlnx y | <= - xlnx a. +Proof. +move=> /andP[Hx1 Hx2] /andP[Hy1 Hy2] H. +have [Hcase|Hcase|Hcase] := ltgtP x y. +- have Haux : y = x + `| x - y |. + by rewrite distrC gtr0_norm ?subr_gt0 // addrC subrK. + rewrite Haux -normrN opprD opprK addrC. + apply (@le_trans _ _ (- xlnx `| x - y |)). + apply xlnx_delta_bound. + + apply/andP; split. + * by rewrite distrC gtr0_norm ?subr_gt0. + * apply (@le_trans _ _ a) => //. + by case/andP: Ha. + + by rewrite Hx1/= lerBrDr -Haux. + rewrite lerNr opprK. + apply xlnx_decreasing_0_Rinv_e => //. + + apply/andP; split; first exact: normr_ge0. + apply (@le_trans _ _ a) => //. + apply (@le_trans _ _ (expR (- 2))). + by case/andP: Ha. + by rewrite ler_expR// lerN2 ler1n. + + apply/andP; split. + by case/andP : Ha. + case/andP : Ha => Ha /le_trans; apply. + by rewrite ler_expR// lerN2 ler1n. +- have Haux : x = y + `| x - y |. + by rewrite gtr0_norm ?subr_gt0// addrCA subrr addr0. + rewrite distrC in H Haux. + rewrite Haux. + apply (@le_trans _ _ (- xlnx `| y - x |)). + apply xlnx_delta_bound. + + apply/andP; split. + * by rewrite distrC gtr0_norm ?subr_gt0. + * rewrite (le_trans H)//. + by case/andP : Ha. + + by rewrite Hy1/= lerBrDr -Haux. + rewrite lerNr opprK. + apply xlnx_decreasing_0_Rinv_e => //. + + apply/andP; split. + * by rewrite ltr0_norm ?subr_lt0// opprB subr_ge0 ltW. + * rewrite (le_trans H)//. + case/andP : Ha => _ /le_trans; apply. + by rewrite ler_expR lerN2 ler1n. + + apply/andP; split. + by case/andP : Ha. + case/andP : Ha => _ /le_trans; apply. + by rewrite ler_expR lerN2 ler1n. +- subst x ; rewrite subrr normr0 lerNr oppr0. + have [<-|anot0] := eqVneq 0 a; first by rewrite xlnx_0 lexx. + apply/ltW/xlnx_neg; apply/andP; split. + + rewrite lt_neqAle anot0/=. + by case/andP : Ha. + + case/andP : Ha => _ /le_lt_trans; apply. + by rewrite expR_lt1 ltrNl oppr0 ltr0n. +Qed. + +End Rabs_xlnx. + +End xlnx_sect. diff --git a/lib/ssrR.v b/lib/ssrR.v deleted file mode 100644 index 394bd6c7..00000000 --- a/lib/ssrR.v +++ /dev/null @@ -1,1539 +0,0 @@ -(* infotheo: information theory and error-correcting codes in Coq *) -(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From HB Require Import structures. -From mathcomp Require Import all_ssreflect ssralg ssrnum. -Require Import Reals. -From mathcomp Require Import lra. -From mathcomp Require Import Rstruct. - -(******************************************************************************) -(* SSReflect-like lemmas for Coq Reals *) -(* *) -(* Various lemmas that make it a bit more comfortable to use the Reals of *) -(* the Coq standard library with SSReflect. *) -(* *) -(* Basic ideas: *) -(* - Mostly renaming of lemmas for the standard library to mimick ssrnat, *) -(* ssrnum, etc. *) -(* - No ssralg instantiation so that the field and lra tactics remain *) -(* available. *) -(* - Use Prop instead of bool: = becomes <-> but rewrite is still *) -(* possible thanks to setoids and the view mechanism allows for apply/, *) -(* exact/, etc. *) -(* - Most lemmas come with a boolean counterpart (same name, ending with *) -(* "'"): *) -(* + Lemma ltR_neqAle' m n : (m (m <> n) /\ (m <= n). *) -(* *) -(* Details: *) -(* - boolean relations: *) -(* + they do not compute but can be used to write boolean predicates *) -(* + boolean equality for Reals as an eqtype *) -(* + boolean inequalities: *) -(* * notations: (O < n)%nat. (for Reals) *) -(* corresponds to *) -(* Lemma ltr0n n : (0 < n%:R :> R) = (0 < n)%N. (from ssrnum) *) -(* (instead of lt_0_INR : forall n : nat, (0 < n)%coq_nat -> 0 < INR n *) -(* in the standard library) *) -(* * Lemma INR_eq0 n : (n%:R = 0) <-> (n = O). *) -(* instead of the one-sided INR_eq in the standard library *) -(* * Lemma leR_add2r {p m n} : m + p <= n + p <-> m <= n. *) -(* - ssr-like lemmas (not so good matches): *) -(* + Lemma invR_gt0 : forall x : R, 0 < x -> 0 < / x *) -(* corresponds to *) -(* Lemma invr_gt0 x : (0 < x^-1) = (0 < x). *) -(* *) -(* Instantiation of MathComp's canonical big operators with Coq reals *) -(* *) -(* Various lemmas for iterated sum, prod, and max *) -(* *) -(******************************************************************************) - -Reserved Notation "n %:R" (at level 2, left associativity, format "n %:R"). -Reserved Notation "'min(' x ',' y ')'" (format "'min(' x ',' y ')'"). -Reserved Notation "'max(' x ',' y ')'" (format "'max(' x ',' y ')'"). - -Notation "\sum_ ( i <- r | P ) F" := (\big[Rplus/R0]_(i <- r | P%B) F) - (at level 41, F at level 41, i, r at level 50, - format "'[' \sum_ ( i <- r | P ) '/ ' F ']'") : R_scope. -Notation "\sum_ ( i <- r ) F" := (\big[Rplus/R0]_(i <- r) F) - (at level 41, F at level 41, i, r at level 50, - format "'[' \sum_ ( i <- r ) '/ ' F ']'") : R_scope. -Notation "\sum_ ( m <= i < n | P ) F" := (\big[Rplus/R0]_(m <= i < n | P%B) F) - (at level 41, F at level 41, i, m, n at level 50, - format "'[' \sum_ ( m <= i < n | P ) '/ ' F ']'") : R_scope. -Notation "\sum_ ( m <= i < n ) F" := (\big[Rplus/R0]_(m <= i < n) F) - (at level 41, F at level 41, i, m, n at level 50, - format "'[' \sum_ ( m <= i < n ) '/ ' F ']'") : R_scope. -Notation "\sum_ ( i | P ) F" := (\big[Rplus/R0]_(i | P%B) F) - (at level 41, F at level 41, i at level 50, - format "'[' \sum_ ( i | P ) '/ ' F ']'") : R_scope . -Notation "\sum_ i F" := (\big[Rplus/R0]_i F) - (at level 41, F at level 41, i at level 0, right associativity, - format "'[' \sum_ i '/ ' F ']'") : R_scope. -Notation "\sum_ ( i : t | P ) F" := (\big[Rplus/R0]_(i : t | P%B) F) - (at level 41, F at level 41, i at level 50, - only parsing) : R_scope. -Notation "\sum_ ( i : t ) F" := (\big[Rplus/R0]_(i : t) F) - (at level 41, F at level 41, i at level 50, - only parsing) : R_scope. -Notation "\sum_ ( i < n | P ) F" := (\big[Rplus/R0]_(i < n | P%B) F) - (at level 41, F at level 41, i, n at level 50, - format "'[' \sum_ ( i < n | P ) '/ ' F ']'") : R_scope. -Notation "\sum_ ( i < n ) F" := (\big[Rplus/R0]_(i < n) F) - (at level 41, F at level 41, i, n at level 50, - format "'[' \sum_ ( i < n ) '/ ' F ']'") : R_scope. -Notation "\sum_ ( i 'in' A | P ) F" := (\big[Rplus/R0]_(i in A | P%B) F) - (at level 41, F at level 41, i, A at level 50, - format "'[' \sum_ ( i 'in' A | P ) '/ ' F ']'") : R_scope. -Notation "\sum_ ( i 'in' A ) F" := (\big[Rplus/R0]_(i in A) F) - (at level 41, F at level 41, i, A at level 50, - format "'[' \sum_ ( i 'in' A ) '/ ' F ']'") : R_scope. - -Notation "\prod_ ( i <- r | P ) F" := (\big[Rmult/R1]_(i <- r | P%B) F) - (at level 36, F at level 36, i, r at level 50, - format "'[' \prod_ ( i <- r | P ) '/ ' F ']'") : R_scope. -Notation "\prod_ ( i <- r ) F" := (\big[Rmult/R1]_(i <- r) F) - (at level 36, F at level 36, i, r at level 50, - format "'[' \prod_ ( i <- r ) '/ ' F ']'") : R_scope. -Notation "\prod_ ( m <= i < n | P ) F" := (\big[Rmult/R1]_(m <= i < n | P%B) F) - (at level 36, F at level 36, i, m, n at level 50, - format "'[' \prod_ ( m <= i < n | P ) '/ ' F ']'") : R_scope. -Notation "\prod_ ( m <= i < n ) F" := (\big[Rmult/R1]_(m <= i < n) F) - (at level 36, F at level 36, i, m, n at level 50, - format "'[' \prod_ ( m <= i < n ) '/ ' F ']'") : R_scope. -Notation "\prod_ ( i | P ) F" := (\big[Rmult/R1]_(i | P%B) F) - (at level 36, F at level 36, i at level 50, - format "'[' \prod_ ( i | P ) '/ ' F ']'") : R_scope. -Notation "\prod_ i F" := (\big[Rmult/R1]_i F) - (at level 36, F at level 36, i at level 0, - format "'[' \prod_ i '/ ' F ']'") : R_scope. -Notation "\prod_ ( i : t | P ) F" := (\big[Rmult/R1]_(i : t | P%B) F) - (at level 36, F at level 36, i at level 50, - only parsing) : R_scope. -Notation "\prod_ ( i : t ) F" := (\big[Rmult/R1]_(i : t) F) - (at level 36, F at level 36, i at level 50, - only parsing) : R_scope. -Notation "\prod_ ( i < n | P ) F" := (\big[Rmult/R1]_(i < n | P%B) F) - (at level 36, F at level 36, i, n at level 50, - format "'[' \prod_ ( i < n | P ) '/ ' F ']'") : R_scope. -Notation "\prod_ ( i < n ) F" := (\big[Rmult/R1]_(i < n) F) - (at level 36, F at level 36, i, n at level 50, - format "'[' \prod_ ( i < n ) '/ ' F ']'") : R_scope. -Notation "\prod_ ( i 'in' A | P ) F" := (\big[Rmult/R1]_(i in A | P%B) F) - (at level 36, F at level 36, i, A at level 50, - format "'[' \prod_ ( i 'in' A | P ) '/ ' F ']'") : R_scope. -Notation "\prod_ ( i 'in' A ) F" := (\big[Rmult/R1]_(i in A) F) - (at level 36, F at level 36, i, A at level 50, - format "'[' \prod_ ( i 'in' A ) '/ ' F ']'") : R_scope. - - -Notation "\rmax_ ( i <- r | P ) F" := (\big[Rmax/R0]_(i <- r | P%B) F) - (at level 41, F at level 41, i, r at level 50, - format "'[' \rmax_ ( i <- r | P ) '/ ' F ']'"). -Notation "\rmax_ ( i <- r ) F" := (\big[Rmax/R0]_(i <- r) F) - (at level 41, F at level 41, i, r at level 50, - format "'[' \rmax_ ( i <- r ) '/ ' F ']'"). -Notation "\rmax_ ( i | P ) F" := (\big[Rmax/R0]_(i | P%B) F) - (at level 41, F at level 41, i at level 50, - format "'[' \rmax_ ( i | P ) '/ ' F ']'"). -Notation "\rmax_ ( i : t | P ) F" := (\big[Rmax/R0]_(i : t | P%B) F) - (at level 41, F at level 41, i at level 50, - only parsing). -Notation "\rmax_ ( i : t ) F" := (\big[Rmax/R0]_(i : t) F) - (at level 41, F at level 41, i at level 50, - only parsing). -Notation "\rmax_ ( i 'in' A | P ) F" := (\big[Rmax/R0]_(i in A | P%B) F) - (at level 41, F at level 41, i, A at level 50, - format "'[' \rmax_ ( i 'in' A | P ) '/ ' F ']'"). -Notation "\rmax_ ( i 'in' A ) F" := (\big[Rmax/R0]_(i in A) F) - (at level 41, F at level 41, i, A at level 50, - format "'[' \rmax_ ( i 'in' A ) '/ ' F ']'"). -Reserved Notation "\min^ b '_(' a 'in' A ) F" (at level 41, - F at level 41, a, A at level 50, - format "'[' \min^ b '_(' a 'in' A ) '/ ' F ']'"). - -Declare Scope min_scope. - -Local Open Scope R_scope. -Delimit Scope ring_scope with mcR. - -Import Order.POrderTheory GRing.Theory Num.Theory. - -(* "^" = pow : R -> nat -> R *) -Notation "x ^- n" := (/ (x ^ n)) : R_scope. - -Notation "`| x |" := (Rabs x) : R_scope. - -Notation "n %:R" := (INR n) : R_scope. - -Global Hint Resolve Rlt_R0_R2 : core. -Global Hint Resolve Rlt_0_1 : core. -Global Hint Resolve Rle_0_1 : core. - -Definition add0R : left_id 0 Rplus := Rplus_0_l. -Definition addR0 : right_id 0 Rplus := Rplus_0_r. - -Lemma addRC : commutative Rplus. -Proof. by move=> m n; rewrite Rplus_comm. Qed. - -Lemma addRA : associative Rplus. -Proof. by move=> m n p; rewrite Rplus_assoc. Qed. - -Lemma addRCA : left_commutative Rplus. Proof. by move=> ? ? ?; ring. Qed. - -Lemma addRAC : right_commutative Rplus. Proof. by move=> ? ? ?; ring. Qed. - -Lemma addRK (a : R) : cancel (Rplus^~ a) (Rminus^~ a). -Proof. move=> ?; ring. Qed. - -Lemma addRR r : r + r = 2 * r. -Proof. by field. Qed. - -Lemma addRN r : r + - r = 0. -Proof. exact: Rplus_opp_r r. Qed. - -Definition subR0 : right_id 0 Rminus := Rminus_0_r. -Definition sub0R := Rminus_0_l. - -Lemma subRR a : a - a = 0. Proof. by rewrite Rminus_diag_eq. Qed. - -Lemma subRKC m n : m + (n - m) = n. Proof. ring. Qed. - -Lemma subRK m n : n - m + m = n. Proof. ring. Qed. - -Lemma subR_eq0 (x y : R) : (x - y = 0) <-> (x = y). -Proof. by split => [/Rminus_diag_uniq //|->]; rewrite subRR. Qed. -Lemma subR_eq0' (x y : R) : (x - y == 0) = (x == y). -Proof. by apply/idP/idP => /eqP/subR_eq0/eqP. Qed. - -Lemma subR_eq x y z : (x - z = y) <-> (x = y + z). -Proof. by split; [move=> <-; rewrite subRK|move=> ->; rewrite addRK]. Qed. -Lemma subR_eq' x y z : (x - z == y) = (x == y + z). -Proof. by apply/eqP/eqP => /subR_eq. Qed. - -Lemma subRBA m n p : m - (n - p) = m + p - n. -Proof. by field. Qed. - -Definition mul0R : left_zero 0 Rmult := Rmult_0_l. -Definition mulR0 : right_zero 0 Rmult := Rmult_0_r. -Definition mul1R : ssrfun.left_id 1%R Rmult := Rmult_1_l. -Definition mulR1 : ssrfun.right_id 1%R Rmult := Rmult_1_r. -Definition mulRN := Ropp_mult_distr_r_reverse. -Definition mulNR := Ropp_mult_distr_l_reverse. -Lemma mulRN1 x : x * -1 = -x. Proof. by rewrite mulRN mulR1. Qed. -Lemma mulN1R x : -1 * x = -x. Proof. by rewrite mulNR mul1R. Qed. - -Definition mulRC : commutative Rmult := Rmult_comm. - -Lemma mulRA : associative Rmult. -Proof. by move=> m n p; rewrite Rmult_assoc. Qed. - -Lemma mulRCA : left_commutative Rmult. Proof. by move=> ? ? ?; ring. Qed. -Lemma mulRAC : right_commutative Rmult. Proof. by move=> ? ? ?; ring. Qed. - -Lemma mulRDl : left_distributive Rmult Rplus. -Proof. by move=> *; rewrite Rmult_plus_distr_r. Qed. -Lemma mulRDr : right_distributive Rmult Rplus. -Proof. by move=> *; rewrite Rmult_plus_distr_l. Qed. -Lemma mulRBl : left_distributive Rmult Rminus. -Proof. by move=> *; ring. Qed. -Lemma mulRBr : right_distributive Rmult Rminus. -Proof. by move=> *; ring. Qed. - -Lemma mulR_eq0 (x y : R) : (x * y = 0) <-> ((x = 0) \/ (y = 0)). -Proof. -split => [/Rmult_integral //| [] ->]; by rewrite ?mul0R ?mulR0. -Qed. -Lemma mulR_eq0' (x y : R) : (x * y == 0) = ((x == 0) || (y == 0)). -Proof. -apply/idP/idP => [/eqP/mulR_eq0[]/eqP-> //|]; first by rewrite orbT. -by case/orP => /eqP ->; rewrite ?mulR0 ?mul0R. -Qed. - -Lemma mulR_neq0 (x y : R) : (x * y <> 0) <-> ((x <> 0) /\ (y <> 0)). -Proof. by rewrite mulR_eq0; tauto. Qed. -Lemma mulR_neq0' (x y : R) : (x * y != 0) = ((x != 0) && (y != 0)). -Proof. by rewrite mulR_eq0' negb_or. Qed. - -Lemma eqR_mul2l {r r1 r2} : r <> 0 -> (r * r1 = r * r2) <-> (r1 = r2). -Proof. by move=> r0; split => [/Rmult_eq_reg_l/(_ r0) | ->]. Qed. - -Lemma eqR_mul2r {r r1 r2} : r <> 0 -> (r1 * r = r2 * r) <-> (r1 = r2). -Proof. by move=> r0; split => [/Rmult_eq_reg_r/(_ r0)|->]. Qed. - -Definition ltRR := Rlt_irrefl. - -Definition ltRW {m n} : m < n -> m <= n := Rlt_le m n. - -Lemma gtR_eqF a b : a < b -> b != a. -Proof. by move=> ab; apply/eqP => ba; move: ab; rewrite ba => /ltRR. Qed. - -Lemma ltR_eqF (r1 r2 : R) : r1 < r2 -> r1 != r2. -Proof. by move/Rlt_not_eq/eqP. Qed. - -Lemma ltR_trans y x z : x < y -> y < z -> x < z. -Proof. exact: Rlt_trans. Qed. -Arguments ltR_trans [_] [_] [_]. - -Lemma leR_trans y x z : x <= y -> y <= z -> x <= z. -Proof. exact: Rle_trans. Qed. -Arguments leR_trans [_] [_] [_]. - -Lemma leR_ltR_trans y x z : x <= y -> y < z -> x < z. -Proof. exact: Rle_lt_trans. Qed. -Arguments leR_ltR_trans [_] [_] [_]. - -Lemma ltR_leR_trans y x z : x < y -> y <= z -> x < z. -Proof. exact: Rlt_le_trans. Qed. -Arguments ltR_leR_trans [_] [_] [_]. - -Definition oppR0 := Ropp_0. -Definition oppRK := Ropp_involutive. - -Lemma subR_opp x y : x - - y = x + y. Proof. by rewrite /Rminus oppRK. Qed. -Lemma addR_opp x y : x + - y = x - y. Proof. by []. Qed. - -Definition oppRD := Ropp_plus_distr. -Definition oppRB := Ropp_minus_distr. -Lemma subRB x y z : x - (y - z) = x - y + z. -Proof. by rewrite -addR_opp oppRB addRA addRAC. Qed. -Lemma subRD x y z : x - (y + z) = x - y - z. -Proof. by rewrite -addR_opp oppRD addRA. Qed. - -Lemma oppR_eq0 x : (- x == 0) = (x == 0). -Proof. -apply/idP/idP => [|/eqP ->]; last by rewrite oppR0. -by apply: contraTT; move/eqP/Ropp_neq_0_compat/eqP. -Qed. - -Lemma addR_eq0 x y : (x + y = 0) <-> (x = - y). -Proof. by rewrite -[y in LHS]oppRK subR_eq0. Qed. -Lemma addR_eq0' x y : (x + y == 0) = (x == - y). -Proof. by apply/idP/idP => /eqP/addR_eq0/eqP. Qed. - -Lemma eqR_opp x y : (- x == - y) = (x == y). -Proof. by apply/eqP/eqP => [Hopp|->//]; rewrite -[LHS]oppRK -[RHS]oppRK Hopp. Qed. - -Lemma eqR_oppLR x y : (- x == y) = (x == - y). -Proof. by apply/eqP/eqP => [<-|->]; rewrite oppRK. Qed. - -Lemma oppR_ge0 x : x <= 0 -> 0 <= - x. -Proof. by move/Rle_ge; exact: Ropp_0_ge_le_contravar. Qed. - -Lemma oppR_lt0 x : 0 < x <-> 0 > - x. -Proof. -split; first exact: Ropp_0_lt_gt_contravar. -by move/Ropp_gt_lt_contravar; rewrite oppRK oppR0. -Qed. - -Lemma oppR_gt0 x : 0 > x <-> 0 < - x. -Proof. -split; first exact: Ropp_0_gt_lt_contravar. -by move/Ropp_gt_lt_contravar; rewrite oppRK oppR0. -Qed. - -Lemma leRNlt m n : (m <= n) <-> ~ (n < m). -Proof. split; [exact: Rle_not_lt | exact: Rnot_lt_le]. Qed. - -Lemma ltRNge m n : (m < n) <-> ~ (n <= m). -Proof. split; [exact: Rlt_not_le | exact: Rnot_le_lt]. Qed. - -Lemma leRNgt (x y : R) : (x <= y) <-> ~ (y < x). -Proof. by rewrite leRNlt. Qed. - -Lemma leR_eqVlt m n : (m <= n) <-> (m = n) \/ (m < n). -Proof. -split => [|[->|]]; [ |exact: Rle_refl|exact: ltRW]. -by case/Rle_lt_or_eq_dec => ?; [right|left]. -Qed. - -Lemma ltR_neqAle m n : (m < n) <-> (m <> n) /\ (m <= n). -Proof. -split. - by move=> /RltP; rewrite Order.POrderTheory.lt_neqAle => /andP[/eqP ? /RleP]. -move=> [/eqP mn /RleP nm]. -by apply/RltP; rewrite Order.POrderTheory.lt_neqAle mn. -Qed. - -(* Lemma pnatr_eq0 n : (n%:R == 0 :> R) = (n == 0)%N. *) -Lemma INR_eq0 n : (n%:R = 0) <-> (n = O). -Proof. by split => [|-> //]; rewrite (_ : 0 = 0%:R) // => /INR_eq ->. Qed. -Lemma INR_eq0' n : (n%:R == 0) = (n == O). -Proof. by apply/idP/idP => /eqP/INR_eq0/eqP. Qed. - -Lemma natRD m n : (m + n)%:R = m%:R + n%:R. -Proof. exact: plus_INR. Qed. -Lemma natRB m n : (n <= m)%nat -> (m - n)%:R = m%:R - n%:R. -Proof. by move=> nm; rewrite minus_INR //; exact/leP. Qed. -Lemma natRM m n : (m * n)%:R = m%:R * n%:R. -Proof. by rewrite mult_INR. Qed. - -Lemma eqR_le x y : (x = y) <-> (x <= y <= x). -Proof. split => [->| [] ]; by [split; exact/Rle_refl | exact: Rle_antisym]. Qed. - -Lemma eqR_le_Ngt {x y} : x <= y -> ~ x < y -> y = x. -Proof. by case/leR_eqVlt. Qed. - -Definition leR0n n : 0 <= n%:R := pos_INR n. - -Lemma leR01 : (R0 <= R1)%R. -Proof. by []. Qed. - -Lemma ltR0n n : (0 < n%:R) <-> (O < n)%nat. -Proof. -by split => [/gtR_eqF/eqP/INR_not_0/Nat.neq_0_lt_0/ltP | /ltP/lt_0_INR]. -Qed. - -Lemma leR_oppr x y : (x <= - y) <-> (y <= - x). -Proof. by split; move/Ropp_le_contravar; rewrite oppRK. Qed. - -Lemma leR_oppl x y : (- x <= y) <-> (- y <= x). -Proof. by split; move/Ropp_le_contravar; rewrite oppRK. Qed. - -Lemma ltR_oppr x y : (x < - y) <-> (y < - x). -Proof. by split; move/Ropp_lt_contravar; rewrite oppRK. Qed. - -Lemma ltR_oppl x y : (- x < y) <-> (- y < x). -Proof. by split; move/Ropp_lt_contravar; rewrite oppRK. Qed. - -(* uninteresting lemmas? *) -(* NB: Ropp_gt_lt_contravar *) -(* NB: Ropp_le_ge_contravar *) -(* NB: Ropp_le_cancel *) -(* NB: Ropp_ll_cancel *) - -(*****************************************) -(* inequalities and addition/subtraction *) -(*****************************************) - -Definition addR_ge0 := Rplus_le_le_0_compat. (* 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2 *) -Definition addR_gt0 := Rplus_lt_0_compat. (* 0 < r1 -> 0 < r2 -> 0 < r1 + r2 *) -Definition addR_gt0wr := Rplus_le_lt_0_compat. (* 0 <= r1 -> 0 < r2 -> 0 < r1 + r2 *) -Definition addR_gt0wl := Rplus_lt_le_0_compat. (* 0 < r1 -> 0 <= r2 -> 0 < r1 + r2 *) - -Definition leR_add := Rplus_le_compat. (* r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4 *) - -Lemma leR_add2r {p m n} : m + p <= n + p <-> m <= n. -Proof. by split; [exact: Rplus_le_reg_r | exact: Rplus_le_compat_r]. Qed. - -Lemma leR_add2l {p m n} : p + m <= p + n <-> m <= n. -Proof. by split; [exact: Rplus_le_reg_l | exact: Rplus_le_compat_l]. Qed. - -Definition ltR_add := Rplus_lt_compat. (* r1 < r2 -> r3 < r4 -> r1 + r3 < r2 + r4 *) - -Lemma ltR_add2r {p m n} : m + p < n + p <-> m < n. -Proof. by split; [exact: Rplus_lt_reg_r | exact: Rplus_lt_compat_r]. Qed. - -Lemma ltR_add2l {p m n} : p + m < p + n <-> m < n. -Proof. by split; [exact: Rplus_lt_reg_l | exact: Rplus_lt_compat_l]. Qed. - -Definition leR_lt_add := Rplus_le_lt_compat. (* x <= y -> z < t -> x + z < y + t *) - -Lemma ltR_subRL m n p : (n < p - m) <-> (m + n < p). -Proof. -split => H. -- by move/(@ltR_add2l m) : H; rewrite subRKC. -- by apply (@ltR_add2l m); rewrite subRKC. -Qed. - -Lemma ltR_subl_addr x y z : (x - y < z) <-> (x < z + y). -Proof. -split => H; [apply (@ltR_add2r (-y)) | apply (@ltR_add2r y)]; last by rewrite subRK. -by rewrite -addRA; apply: (ltR_leR_trans H); rewrite Rplus_opp_r addR0; exact/Rle_refl. -Qed. - -Lemma leR_subr_addr x y z : (x <= y - z) <-> (x + z <= y). -Proof. -split => [|H]. - by move=> /RleP; rewrite RminusE lerBrDr => /RleP. -by apply/RleP; rewrite RminusE lerBrDr; exact/RleP. -Qed. - -Lemma leR_subl_addr x y z : (x - y <= z) <-> (x <= z + y). -Proof. -split => [|H]. - by move=> /RleP; rewrite RminusE lerBlDr => /RleP. -by apply/RleP; rewrite RminusE lerBlDr; exact/RleP. -Qed. - -Definition leR_sub_addr := (leR_subl_addr, leR_subr_addr). - -Definition ltR_subr_addl := ltR_subRL. - -Lemma ltR_subl_addl x y z : (x - y < z) <-> (x < y + z). -Proof. -split => [/(@ltR_add2r y)|/(@ltR_add2r (- y))]; first by rewrite subRK addRC. -by rewrite addR_opp (addRC y) addR_opp addRK. -Qed. - -Lemma ltR_subr_addr x y z : (x < y - z) <-> (x + z < y). -Proof. by rewrite ltR_subr_addl addRC. Qed. - -Lemma leR_addl x y : (x <= x + y) <-> (0 <= y). -Proof. by rewrite -{1}(addR0 x) leR_add2l. Qed. -Lemma leR_addr x y : (x <= y + x) <-> (0 <= y). -Proof. by rewrite -{1}(add0R x) leR_add2r. Qed. -Lemma ltR_addl x y : (x < x + y) <-> (0 < y). -Proof. by rewrite -{1}(addR0 x) ltR_add2l. Qed. - -Lemma subR_gt0 x y : (0 < y - x) <-> (x < y). -Proof. by split; [exact: Rminus_gt_0_lt | exact: Rlt_Rminus]. Qed. -Lemma subR_lt0 x y : (y - x < 0) <-> (y < x). -Proof. by split; [exact: Rminus_lt | exact: Rlt_minus]. Qed. -Lemma subR_ge0 x y : (0 <= y - x) <-> (x <= y). -Proof. -split => [|?]; first by move/leR_subr_addr; rewrite add0R. -by apply/leR_subr_addr; rewrite add0R. -Qed. -Lemma subR_le0 x y : (y - x <= 0) <-> (y <= x). -Proof. -by split => [/leR_subl_addr|?]; [|apply/leR_subl_addr]; rewrite add0R. -Qed. - -(***********************************) -(* inequalities and multiplication *) -(***********************************) - -Definition mulR_ge0 := Rmult_le_pos. (* 0 <= r1 -> 0 <= r2 -> 0 <= r1 * r2 *) -Definition mulR_gt0 := Rmult_lt_0_compat. (* 0 < r1 -> 0 < r2 -> 0 < r1 * r2 *) - -Definition leR_wpmul2l := Rmult_le_compat_l. (* 0 <= r -> r1 <= r2 -> r * r1 <= r * r2 *) -Definition leR_wpmul2r := Rmult_le_compat_r. (* 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r *) -Definition leR_pmul := Rmult_le_compat. (* 0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4 *) -Arguments leR_wpmul2l [_] [_] [_]. -Arguments leR_wpmul2r [_] [_] [_]. -Arguments leR_pmul [_] [_] [_] [_]. - -Definition ltR_pmul := Rmult_le_0_lt_compat. (* 0 <= r1 -> 0 <= r3 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4 *) - -(* NB: Rmult_ge_compat_l? *) - -Lemma paddR_eq0 (x y : R) : - 0 <= x -> 0 <= y -> (x + y = 0) <-> (x = 0) /\ (y = 0). -Proof. -move=> x0 y0; split => [|[-> ->]]; last by rewrite addR0. -move=> H; move: (H) => /Rplus_eq_0_l -> //. -by move: H; rewrite addRC => /Rplus_eq_0_l ->. -Qed. -Arguments paddR_eq0 {x} {y}. - -Lemma paddR_neq0 (p q : R) (p0 : 0 <= p) (q0 : 0 <= q) : p + q != 0 <-> p != 0 \/ q != 0. -Proof. -split => [H | /orP]. -- apply/orP; rewrite -negb_and; apply: contra H => /andP[/eqP -> /eqP ->]. - by rewrite addR0. -- rewrite -negb_and; apply: contra => /eqP/paddR_eq0. - by case/(_ p0)/(_ q0) => -> ->; rewrite eqxx. -Qed. -Arguments paddR_neq0 {p} {q}. - -Lemma leR_pmul2l m n1 n2 : 0 < m -> (m * n1 <= m * n2) <-> (n1 <= n2). -Proof. -by move=> m0; split; [exact: Rmult_le_reg_l | exact/Rmult_le_compat_l/ltRW]. -Qed. - -Lemma leR_pmul2r m n1 n2 : 0 < m -> (n1 * m <= n2 * m) <-> (n1 <= n2). -Proof. -by move=> m0; split; [exact: Rmult_le_reg_r | exact/Rmult_le_compat_r/ltRW]. -Qed. - -Lemma ltR_pmul2l m n1 n2 : 0 < m -> (m * n1 < m * n2) <-> (n1 < n2). -Proof. by move=> m0; split; [exact: Rmult_lt_reg_l | exact/Rmult_lt_compat_l]. Qed. - -Lemma ltR_pmul2r m n1 n2 : 0 < m -> (n1 * m < n2 * m) <-> (n1 < n2). -Proof. by move=> m0; split; [exact: Rmult_lt_reg_r | exact/Rmult_lt_compat_r]. Qed. - -Lemma pmulR_lgt0 x y : 0 < x -> (0 < y * x) <-> (0 < y). -Proof. by move=> x0; rewrite -{1}(mul0R x) ltR_pmul2r. Qed. - -Lemma pmulR_lgt0' [x y : R] : 0 < y * x -> 0 <= x -> 0 < y. -Proof. -case/boolP: (x == 0) => [/eqP -> |]; first by rewrite mulR0 => /ltRR. -move=> /eqP /nesym ? /[swap] ? /pmulR_lgt0; apply. -by rewrite ltR_neqAle; split. -Qed. - -Lemma pmulR_rgt0' [x y : R] : 0 < x * y -> 0 <= x -> 0 < y. -Proof. by rewrite mulRC; exact: pmulR_lgt0'. Qed. - -Arguments leR_pmul2l [_] [_] [_]. -Arguments leR_pmul2r [_] [_] [_]. -Arguments ltR_pmul2l [_] [_] [_]. -Arguments ltR_pmul2r [_] [_] [_]. -Arguments pmulR_lgt0 [_] [_]. - -Lemma leR_pmull m n : 1 <= n -> 0 <= m -> m <= n * m. -Proof. -move=> n1 m0; case/boolP : (m == 0) => [/eqP ->|m0']; first by rewrite mulR0; exact/Rle_refl. -by rewrite -{1}(mul1R m) leR_pmul2r // ltR_neqAle; split => //; apply/eqP; rewrite eq_sym. -Qed. - -Lemma leR_pmulr m n : 1 <= n -> 0 <= m -> m <= m * n. -Proof. by move=> n1 m0; rewrite mulRC; apply leR_pmull. Qed. - -Lemma leR_nat m n : (m%:R <= n%:R) <-> (m <= n)%nat. -Proof. by split => [/INR_le/leP|/leP/le_INR]. Qed. - -Lemma ltR_nat m n : (m%:R < n%:R) <-> (m < n)%nat. -Proof. by split => [/INR_lt/ltP|/ltP/lt_INR]. Qed. - -Lemma ltR0n_neq0' n : (0 < n)%nat = (n%:R != 0). -Proof. by rewrite lt0n INR_eq0'. Qed. - -(*************) -(* invR/divR *) -(*************) - -Lemma invR_gt0 x : 0 < x -> 0 < / x. -Proof. by move=> x0; apply Rinv_0_lt_compat. Qed. - -Lemma invR_ge0 x : 0 < x -> 0 <= / x. -Proof. by move=> x0; apply/ltRW/invR_gt0. Qed. - -(* Rinv_neq_0_compat : forall r : R, r <> 0 -> / r <> 0 *) -Lemma invR_neq0 (x : R) : x <> 0 -> / x <> 0. -Proof. exact: Rinv_neq_0_compat. Qed. -Lemma invR_neq0' (x : R) : x != 0 -> / x != 0. -Proof. by move/eqP/invR_neq0/eqP. Qed. - -Lemma invR_eq0 (x : R) : / x = 0 -> x = 0. -Proof. -move/eqP=> H; apply/eqP; apply: contraTT H => H; exact/eqP/invR_neq0/eqP. -Qed. -Lemma invR_eq0' (x : R) : / x == 0 -> x == 0. -Proof. by move/eqP/invR_eq0/eqP. Qed. - -Definition invR1 : / 1 = 1 := Rinv_1. - -Definition invRK (r : R) : / / r = r. -Proof. exact: Rinv_inv. Qed. - -Lemma invRM (r1 r2 : R) : r1 != 0 -> r2 != 0 -> / (r1 * r2) = / r1 * / r2. -Proof. by move=> /eqP r10 /eqP r20; rewrite Rinv_mult. Qed. - -Lemma leR_inv x y : 0 < y -> y <= x -> / x <= / y. -Proof. by move=> x0 y0; apply/Rinv_le_contravar. Qed. - -Lemma invR_le x y : 0 < x -> 0 < y -> / y <= / x -> x <= y. -Proof. -move=> x0 y0 H; rewrite -(invRK x) -(invRK y). -by apply leR_inv => //; exact/invR_gt0. -Qed. - -Lemma ltR_inv x y : 0 < x -> 0 < y -> y < x -> / x < / y. -Proof. by move=> xo y0; apply/Rinv_lt_contravar/mulR_gt0. Qed. - -Lemma divRE x y : x / y = x * / y. Proof. by []. Qed. - -Delimit Scope R_scope with coqR. - -Lemma R1E : 1%coqR = 1%mcR. Proof. by []. Qed. -Lemma R0E : 0%coqR = 0%mcR. Proof. by []. Qed. - -Definition coqRE := - (R0E, R1E, INRE, - RinvE, RoppE, RdivE, RminusE, RplusE, RmultE, RpowE). - -Definition divRR (x : R) : x != 0 -> x / x = 1. -Proof. by move=> x0; rewrite /Rdiv Rinv_r //; exact/eqP. Qed. - -Lemma divR1 (x : R) : x / 1 = x. -Proof. by rewrite /Rdiv invR1 mulR1. Qed. - -Lemma div1R (x : R) : 1 / x = / x. -Proof. by rewrite /Rdiv mul1R. Qed. - -Lemma div0R (x : R) : 0 / x = 0. -Proof. by rewrite /Rdiv mul0R. Qed. - -Lemma divR_ge0 (x y : R) : 0 <= x -> 0 < y -> 0 <= x / y. -Proof. move=> x0 y0; apply mulR_ge0 => //; exact/invR_ge0. Qed. - -Lemma divR_gt0 (x y : R) : 0 < x -> 0 < y -> 0 < x / y. -Proof. exact: Rdiv_lt_0_compat x y. Qed. - -Lemma divRM (r1 r2 x : R) : r1 != 0 -> r2 != 0 -> x / (r1 * r2) = x / r1 * / r2. -Proof. by move=> ? ?; rewrite {1}/Rdiv invRM // mulRA. Qed. - -Lemma divR_neq0' (x y : R) : x != 0 -> y != 0 -> x / y != 0. -Proof. by move => x0 y0; rewrite mulR_neq0' x0 /= invR_neq0'. Qed. - -Lemma divN1R x : -1 / x = - / x. Proof. by rewrite /Rdiv mulN1R. Qed. - -Definition mulRV (x : R) : x != 0 -> x * / x = 1 := divRR x. - -Lemma divRDl : left_distributive Rdiv Rplus. -Proof. by move=> *; rewrite /Rdiv -mulRDl. Qed. - -Lemma divRBl : left_distributive Rdiv Rminus. -Proof. by move=> x y z; rewrite -[in RHS]addR_opp -mulNR divRDl. Qed. - -(* Rinv_l_sym *) -Lemma mulVR (x : R) : x != 0 -> / x * x = 1. -Proof. by move=> x0; rewrite mulRC mulRV. Qed. - -Lemma leR_pdivl_mulr z x y : 0 < z -> (x <= y / z) <-> (x * z <= y). -Proof. -move=> z0; split => [/(leR_wpmul2l (ltRW z0))|H]. -- rewrite mulRC mulRCA mulRV ?mulR1 //; exact/gtR_eqF. -- apply/(@leR_pmul2r z) => //; rewrite -mulRA mulVR ?mulR1 //; exact/gtR_eqF. -Qed. - -Lemma ltR_pdivl_mulr z x y : 0 < z -> (x < y / z) <-> (x * z < y). -Proof. -move=> z0; split => [/(ltR_pmul2l z0)|H]. -- by rewrite mulRC mulRCA mulRV ?mulR1 //; exact/gtR_eqF. -- by apply/(@ltR_pmul2r z) => //; rewrite -mulRA mulVR ?mulR1 //; exact/gtR_eqF. -Qed. - -Lemma eqR_divr_mulr z x y : z != 0 -> (y / z = x) <-> (y = x * z). -Proof. -move=> z0; split => [<-|->]; first by rewrite -mulRA mulVR // mulR1. -by rewrite /Rdiv -mulRA mulRV // mulR1. -Qed. - -Lemma eqR_divl_mulr z x y : z != 0 -> (x = y / z) <-> (x * z = y). -Proof. by move=> z0; split; move/esym/eqR_divr_mulr => /(_ z0) ->. Qed. - -Lemma leR_pdivr_mulr z x y : 0 < z -> (y / z <= x) <-> (y <= x * z). -Proof. -move=> z0; split => [/(leR_wpmul2r (ltRW z0))|H]. -- by rewrite -mulRA mulVR ?mulR1 //; exact/gtR_eqF. -- by apply/(@leR_pmul2r z) => //; rewrite -mulRA mulVR ?mulR1 //; exact/gtR_eqF. -Qed. - -Lemma ltR_pdivr_mulr z x y : 0 < z -> (y / z < x) <-> (y < x * z). -Proof. -move=> z0; split => [/(ltR_pmul2r z0)|H]. -- by rewrite -mulRA mulVR ?mulR1 //; exact/gtR_eqF. -- by apply/(@ltR_pmul2r z) => //; rewrite -mulRA mulVR ?mulR1 //; exact/gtR_eqF. -Qed. - -Lemma invR_le1 x : 0 < x -> (/ x <= 1) <-> (1 <= x). -Proof. by move=> x0; rewrite -(div1R x) leR_pdivr_mulr // mul1R. Qed. - -Lemma invR_gt1 x : 0 < x -> (1 < / x) <-> (x < 1). -Proof. -move=> x0; split => x1; last by rewrite -invR1; apply ltR_inv. -move/ltR_inv : x1; rewrite invRK invR1. -by apply => //; exact/invR_gt0. -Qed. - -(*******) -(* pow *) -(*******) - -Lemma natRexp r n : r%:R ^ n = (expn r n)%:R. -Proof. -by elim: n => // n IH; rewrite (expnSr r n) natRM -addn1 pow_add /= mulR1 IH. -Qed. - -Lemma expR0 (a : R) : a ^ 0 = 1. Proof. exact: pow_O. Qed. - -Definition expRn_gt0 n x := pow_lt x n. - -Lemma expR_eq0 x (n : nat) : (x ^ n.+1 == 0) = (x == 0). -Proof. -apply/idP/idP => [/eqP H|/eqP ->]; apply/eqP; last by rewrite pow_ne_zero. -by move: (pow_nonzero x n.+1); tauto. -Qed. - -Lemma expR_gt0 x : 0 < x -> forall n : nat, 0 < x ^ n. -Proof. by move=> ?; elim => [/= | n IH] => //; exact: mulR_gt0. Qed. - -Lemma expR_ge0 x : 0 <= x -> forall n : nat, 0 <= x ^ n. -Proof. -move=> x_pos; elim => [// | n IH]. -by rewrite -(mulR0 0); apply leR_pmul => //; apply/RleP; rewrite Order.POrderTheory.lexx. -Qed. - -Lemma expR_neq0 x (n : nat) : x != 0 -> x ^ n != 0. -Proof. by move/eqP/(pow_nonzero _ n)/eqP. Qed. - -Lemma exp1R n : 1 ^ n = 1. Proof. exact: pow1. Qed. - -Lemma expRS x (n : nat) : x ^ n.+1 = x * x ^ n. -Proof. by rewrite tech_pow_Rmult. Qed. - -Lemma expR1 x : x ^ 1 = x. Proof. exact: pow_1. Qed. - -Lemma mulRR x : x * x = x ^ 2. Proof. by rewrite expRS expR1. Qed. - -Lemma expRV x (n : nat) : x != 0 -> (/ x ) ^ n = x ^- n. -Proof. -move=> x0; elim : n => /= [ | n IH]; first by rewrite Rinv_1. -by rewrite invRM //; [rewrite IH | exact/expR_neq0]. -Qed. - -(* forall (x y : R) (n : nat), (x * y) ^ n = x ^ n * y ^ n*) -Definition expRM := Rpow_mult_distr. - -Lemma expRB (n m : nat) r : (m <= n)%nat -> r <> 0 -> r ^ (n - m) = r ^ n / (r ^ m). -Proof. -move=> Hr ab. -by rewrite (pow_RN_plus r _ m) // plusE -minusE subnK // powRV //; exact/eqP. -Qed. - -Lemma leR_wiexpR2l x : - 0 <= x -> x <= 1 -> {homo (pow x) : m n / (n <= m)%nat >-> m <= n}. -Proof. -move/RleP; rewrite le0r => /orP[/eqP -> _ m n|/RltP x0 x1 m n /leP nm]. - case: n => [|n nm]. - case: m => [_ |m _]. - by apply/RleP; rewrite Order.POrderTheory.lexx. - by rewrite pow_ne_zero. - rewrite pow_ne_zero; last by case: m nm. - rewrite pow_ne_zero //. - by apply/RleP; rewrite Order.POrderTheory.lexx. -apply invR_le => //. -- exact/expR_gt0. -- exact/expR_gt0. -- rewrite -expRV; last exact/gtR_eqF. - rewrite -expRV; last exact/gtR_eqF. - apply Rle_pow => //. - by rewrite -invR1; apply leR_inv => //; exact/ltRP. -Qed. - -Lemma leR_weexpR2l x : 1 <= x -> {homo (pow x) : m n / (m <= n)%nat >-> m <= n}. -Proof. by move=> x1 m n /leP nm; exact/Rle_pow. Qed. - -Lemma sqrRB a b : (a - b) ^ 2 = a ^ 2 - 2 * a * b + b ^ 2. -Proof. by rewrite /= !mulR1 !mulRDr !mulRBl /=; field. Qed. - -Lemma sqrRD a b : (a + b) ^ 2 = a ^ 2 + 2 * a * b + b ^ 2. -Proof. by rewrite /= !mulR1 !mulRDl !mul1R !mulRDr /=; field. Qed. - -Lemma subR_sqr x y : x ^ 2 - y ^ 2 = (x - y) * (x + y). -Proof. -rewrite mulRDr 2!mulRDl -addRA (addRA (- y * x)) (mulRC x y) (addRC _ (y * x)). -by rewrite mulNR addRN add0R mulNR addR_opp 2!mulRR. -Qed. - -Definition normR0 : `| 0 | = 0 := Rabs_R0. -Definition normRN x : `|- x| = `|x| := Rabs_Ropp x. - -Definition normR_ge0 x : 0 <= `|x| := Rabs_pos x. -Lemma normR0_eq0 r : `| r | = 0 -> r = 0. -Proof. by move: (Rabs_no_R0 r); tauto. Qed. - -Lemma leR0_norm x : x <= 0 -> `|x| = - x. Proof. exact: Rabs_left1. Qed. -Lemma ltR0_norm x : x < 0 -> `|x| = - x. Proof. by move/ltRW/leR0_norm. Qed. -Lemma geR0_norm x : 0 <= x -> `|x| = x. Proof. exact: Rabs_pos_eq. Qed. -Lemma gtR0_norm x : 0 < x -> `|x| = x. Proof. by move/ltRW/geR0_norm. Qed. - -Lemma normRM : {morph Rabs : x y / x * y : R}. -Proof. exact: Rabs_mult. Qed. - -Definition sqR_norm x : `| x | ^ 2 = x ^ 2 := pow2_abs x. - -Definition distRC x y : `|x - y| = `|y - x| := Rabs_minus_sym x y. - -Notation "'min(' x ',' y ')'" := (Rmin x y) : R_scope. -Notation "'max(' x ',' y ')'" := (Rmax x y) : R_scope. - -Module ROrder. - -Lemma minRE x y : min(x, y) = if (x < y)%mcR then x else y. -Proof. -by case: ifP => /RltP; [move/ltRW/Rmin_left|rewrite -leRNgt => /Rmin_right]. -Qed. - -Lemma maxRE x y : max(x, y) = if (x < y)%mcR then y else x. -Proof. -by case: ifP => /RltP; [move/ltRW/Rmax_right|rewrite -leRNgt => /Rmax_left]. -Qed. - -End ROrder. - -Definition maxRA : associative Rmax := Rmax_assoc. -Definition maxRC : commutative Rmax := Rmax_comm. - -Lemma maxRR : idempotent Rmax. -Proof. -move=> x; rewrite Rmax_left //. -by apply/RleP; rewrite Order.POrderTheory.lexx. -Qed. - -Definition leR_maxl m n : m <= max(m, n) := Rmax_l m n. -Definition leR_maxr m n : n <= max(m, n) := Rmax_r m n. -Definition geR_minl m n : min(m, n) <= m := Rmin_l m n. -Definition geR_minr m n : min(m, n) <= n := Rmin_r m n. - -Lemma leR_max x y z : max(y, z) <= x <-> (y <= x) /\ (z <= x). -Proof. -split => [| [yx zx] ]. - move/RleP. - rewrite Order.POrderTheory.le_eqVlt => /orP[/eqP <-|/RltP/Rmax_Rlt]. - by split; [exact: leR_maxl | exact: leR_maxr]. - by case=> ?; split; exact/ltRW. -by rewrite -(Rmax_right _ _ yx); exact: Rle_max_compat_l. -Qed. - -(* NB: the following used to be in Rbigop.v *) - -Lemma iter_mulR x (n : nat) : ssrnat.iter n (Rmult x) 1 = x ^ n. -Proof. elim : n => // n Hn ; by rewrite iterS Hn. Qed. - -Lemma iter_addR x (n : nat) : ssrnat.iter n (Rplus x) 0 = n%:R * x. -Proof. by rewrite iter_addr addr0 -mulr_natr mulrC RmultE INRE. Qed. - -Section temporary_lemmas. - -Local Open Scope ring_scope. - -Lemma sumRE (I : Type) (r : seq I) (P : pred I) (F : I -> R) : - (\sum_(i <- r | P i) F i)%coqR = \sum_(i <- r | P i) F i. -Proof. by []. Qed. - -Lemma bigmaxRE (I : Type) (r : seq I) (P : pred I) (F : I -> R) : - \rmax_(i <- r | P i) F i = \big[Order.max/0]_(i <- r | P i) F i. -Proof. -rewrite /Rmax /Order.max/=. -congr bigop.body. -apply: boolp.funext=> i /=. -congr BigBody. -apply: boolp.funext=> x /=. -apply: boolp.funext=> y /=. -rewrite lt_neqAle. -case: (Rle_dec x y); move/RleP; - first by case/boolP: (x == y) => /= [/eqP -> | _ ->]. -by move/negPf->; rewrite andbF. -Qed. - -End temporary_lemmas. - -Lemma morph_oppR : {morph [eta Ropp] : x y / x + y}. -Proof. by move=> x y /=; field. Qed. - -Definition big_morph_oppR := big_morph _ morph_oppR oppR0. - -Lemma morph_natRD : {morph INR : x y / (x + y)%nat >-> x + y}. -Proof. move=> x y /=; by rewrite natRD. Qed. - -Definition big_morph_natRD := big_morph INR morph_natRD (erefl 0%:R). - -Lemma morph_natRM : {morph INR : x y / (x * y)%nat >-> x * y}. -Proof. move=> x y /=; by rewrite natRM. Qed. - -Definition big_morph_natRM := big_morph INR morph_natRM (erefl 1%:R). - -Lemma morph_mulRDr a : {morph [eta Rmult a] : x y / x + y}. -Proof. move=> * /=; by rewrite mulRDr. Qed. - -Lemma morph_mulRDl a : {morph Rmult^~ a : x y / x + y}. -Proof. move=> x y /=; by rewrite mulRDl. Qed. - -Lemma iter_Rmax a b (Hb : b <= a) k : ssrnat.iter k (Rmax b) a = a. -Proof. elim: k => // k Hk; by rewrite iterS Hk Rmax_right. Qed. - -(** Rle, Rlt lemmas for big sums of reals *) - -Lemma sumR_ord_setT (n : nat) (f : 'I_n -> R) : - \sum_(i < n) f i = \sum_(i in [set: 'I_n]) f i. -Proof. by apply eq_bigl => i; rewrite inE. Qed. - -Lemma sumR_neq0 (U : eqType) (P : U -> R) (s : seq.seq U) : - (forall i, 0 <= P i) -> - \sum_(a0 <- s) P a0 != 0 <-> exists i : U, i \in s /\ 0 < P i. -Proof. -move=> /(_ _) /RleP P0. -rewrite sumRE psumr_neq0 //. -under eq_has do rewrite andTb. -split; first by move=> /hasP [x xs /RltP Px0]; exists x; split. -by case=> x [] xs /RltP Px0; apply/hasP; exists x. -Qed. - -Lemma sumR_gt0 (A : finType) (f : A -> R) (HA : (0 < #|A|)%nat) : - (forall a, 0 < f a) -> 0 < \sum_(a in A) f a. -Proof. -move=> f0; rewrite ltR_neqAle; split; last first. - apply/RleP; rewrite sumRE. - by apply/sumr_ge0 => a _; apply/RleP/ltRW. -apply/nesym/eqP/sumR_neq0; last by move/card_gt0P : HA => [a _]; exists a. -by move=> a; apply/ltRW/f0. -Qed. - -Section leR_ltR_sumR. -Variable A : Type. -Implicit Types (f g : A -> R) (P Q : pred A). - -Lemma leR_sumR r P f g : (forall i, P i -> f i <= g i) -> - \sum_(i <- r | P i) f i <= \sum_(i <- r | P i) g i. -Proof. -move=> leE12. -elim/big_ind2: _ => //. - exact: Rle_refl. -by move=> m1 m2 n1 n2; Lra.lra. -Qed. - -End leR_ltR_sumR. - -Section leR_ltR_sumR_finType. -Variables (A : finType) (f g : A -> R) (P Q : pred A). - -Lemma leR_sumR_support (X : {set A}) : - (forall i, i \in X -> P i -> f i <= g i) -> - \sum_(i in X | P i) f i <= \sum_(i in X | P i) g i. -Proof. -move=> H; elim/big_rec2 : _ => //. - exact: Rle_refl. -move=> a x y /andP[aX Pa] yx. -by apply leR_add => //; apply: H. -Qed. - -Lemma leR_sumRl : (forall i, P i -> f i <= g i) -> - (forall i, Q i -> 0 <= g i) -> (forall i, P i -> Q i) -> - \sum_(i | P i) f i <= \sum_(i | Q i) g i. -Proof. -move=> f_g Qg H; elim: (index_enum _) => [| h t IH]. -- rewrite !big_nil. - by apply/RleP; rewrite lexx. -- rewrite !big_cons /=; case: ifP => [Ph|Ph]. - by rewrite (H _ Ph); apply leR_add => //; exact: f_g. - case: ifP => // Qh; apply: (leR_trans IH). - by rewrite -{1}[X in X <= _](add0R _); exact/leR_add2r/Qg. -Qed. - -Lemma leR_sumRl_support (U : pred A) : - (forall a, 0 <= f a) -> (forall i, P i -> Q i) -> - \sum_(i in U | P i) f i <= \sum_(i in U | Q i) f i. -Proof. -move=> Hf P_Q; elim: (index_enum _) => [|h t IH]. -- by rewrite !big_nil; apply/RleP; rewrite lexx. -- rewrite !big_cons; case: (h \in U) => //=; case: ifP => // Ph. - + by case: ifP => [Qh|]; [rewrite leR_add2l | rewrite (P_Q _ Ph)]. - + by case: ifP => // Qh; rewrite -[X in X <= _]add0R; exact/leR_add. -Qed. - -Lemma ltR_sumR_support (X : {set A}) : (0 < #|X|)%nat -> - (forall i, i \in X -> f i < g i) -> - \sum_(i in X) f i < \sum_(i in X) g i. -Proof. -move Hn : #|X| => n; elim: n X Hn => // n IH X Hn _ H. -move: (ltn0Sn n); rewrite -Hn card_gt0; case/set0Pn => a0 Ha0. -rewrite (@big_setD1 _ _ _ _ a0 _ f) //= (@big_setD1 _ _ _ _ a0 _ g) //=. -case: n => [|n] in IH Hn. - rewrite (_ : X :\ a0 = set0); first by rewrite !big_set0 2!addR0; exact: H. - move: Hn. - by rewrite (cardsD1 a0) Ha0 /= add1n => -[] /eqP; rewrite cards_eq0 => /eqP. -apply ltR_add; first exact/H. -apply IH => //. -- by move: Hn; rewrite (cardsD1 a0) Ha0 /= add1n => -[]. -- by move=> a; rewrite in_setD inE => /andP[_ ?]; exact: H. -Qed. - -Lemma ltR_sumR : (O < #|A|)%nat -> (forall i, f i < g i) -> - \sum_(i in A) f i < \sum_(i in A) g i. -Proof. -move=> A0 H0. -have : forall i : A, i \in [set: A] -> f i < g i by move=> a _; exact/H0. -move/ltR_sumR_support; rewrite cardsT => /(_ A0). -rewrite big_mkcond /= [in X in _ < X]big_mkcond /=. -rewrite (eq_bigr f) //; last by move=> *; rewrite inE. -by rewrite [in X in _ < X](eq_bigr g) // => *; rewrite inE. -Qed. - -End leR_ltR_sumR_finType. - -Lemma leR_sumR_Rabs (A : finType) f : `| \sum_a f a | <= \sum_(a : A) `| f a |. -Proof. -elim: (index_enum _) => [|h t IH]. - by rewrite 2!big_nil Rabs_R0; exact: Rle_refl. -rewrite 2!big_cons. -apply (@leR_trans (`| f h | + `| \sum_(j <- t) f j |)); - [exact/Rabs_triang |exact/leR_add2l]. -Qed. - -Lemma leR_sumR_predU (A : finType) (f : A -> R) (P Q : pred A) : - (forall a, 0 <= f a) -> \sum_(i in A | [predU P & Q] i) f i <= - \sum_(i in A | P i) f i + \sum_(i in A | Q i) f i. -Proof. -move=> Hf. -elim: (index_enum _) => [|h t IH /=]; first by rewrite !big_nil /=; Lra.lra. -rewrite !big_cons /=. -case: ifPn => /=. -- case/orP => [hP | hQ]. - + move: hP; rewrite unfold_in => ->. - case: ifP => // Qh. - * rewrite -addRA; apply leR_add2l. - apply (leR_trans IH). - have : forall a b c, 0 <= c -> a + b <= a + (c + b) by move=> *; Lra.lra. - apply; by apply Hf. - * rewrite -addRA; apply leR_add2l. - exact/(leR_trans IH)/Req_le. - + move: hQ; rewrite unfold_in => ->. - case: ifP => // Ph. - * rewrite -addRA; apply/leR_add2l/(leR_trans IH). - have : forall a b c, 0 <= c -> a + b <= a + (c + b) by move=> *; Lra.lra. - apply; by apply Hf. - * rewrite -(addRC (f h + _)) -addRA; apply/leR_add2l/(leR_trans IH). - by rewrite addRC; apply Req_le. -- rewrite negb_or. - case/andP. - rewrite !unfold_in; move/negbTE => -> /negbTE ->. - exact/IH. -Qed. - -(* TODO: factorize? rename? *) -Lemma leR_sumR_eq (A : finType) (f g : A -> R) (P : pred A) : - (forall a, P a -> f a <= g a) -> - \sum_(a | P a) g a = \sum_(a | P a) f a -> - (forall a, P a -> g a = f a). -Proof. -move=> H1 H2 i Hi; rewrite -subR_eq0; move: i Hi; apply: psumr_eq0P. - by move=> i Pi; rewrite RminusE subr_ge0; apply/RleP/H1. -by rewrite big_split/= -big_morph_oppR; apply/eqP; rewrite subr_eq0 H2. -Qed. - -Section pascal. - -Lemma factE n0 : fact n0 = n0 `!. -Proof. by elim: n0 => // n0 IH /=; rewrite IH factS mulSn -multE. Qed. - -Lemma combinaisonE n0 m0 : (m0 <= n0)%nat -> C n0 m0 = 'C(n0, m0)%:R. -Proof. -move=> ?. -rewrite /C. -apply (@eqR_mul2r (INR (fact m0) * INR (fact (n0 - m0)%coq_nat))). - move/eqP; rewrite mulR_eq0' !INR_eq0' => /orP[|] /eqP; exact/fact_neq_0. -set tmp := INR (fact m0) * _. -rewrite -mulRA mulVR ?mulR1; last first. - by rewrite /tmp mulR_neq0' !INR_eq0' !factE -!lt0n !fact_gt0. -by rewrite /tmp -!natRM !factE !minusE bin_fact. -Qed. - -Lemma sum_f_R0_sumR : forall n (f : nat -> R), - sum_f_R0 f n = \sum_(i < n.+1) f i. -Proof. -elim => [f|n IH f] /=; first by rewrite big_ord_recl /= big_ord0 addR0. -by rewrite big_ord_recr /= IH. -Qed. - -Theorem RPascal k (a b : R) : - (a + b) ^ k = \sum_(i < k.+1) INR ('C(k, i))* (a ^ (k - i) * b ^ i). -Proof. -rewrite addRC Binomial.binomial sum_f_R0_sumR. -apply eq_bigr => i _. -rewrite combinaisonE; last by rewrite -ltnS. -rewrite -minusE; field. -Qed. - -End pascal. - -Section leR_ltR_rprod. - -Lemma prodR_ge0 (A : finType) F : (forall a, 0 <= F a) -> - 0 <= \prod_(a : A) F a. -Proof. by move=> F0; elim/big_ind : _ => // x y ? ?; exact: mulR_ge0. Qed. - -Lemma prodR_eq0 (A : finType) (p : pred A) (F : A -> R) : - (exists2 i : A, p i & F i = 0%R) <-> \prod_(i : A | p i) F i = 0%R. -Proof. -split. -{ by case => [i Hi Hi0]; rewrite (bigD1 i) //= Hi0 mul0R. } -apply big_ind. -- by move=> K; exfalso; auto with real. -- by move=> ? ? ? ?; rewrite mulR_eq0 => -[]; tauto. -- by move=> i Hi Hi0; exists i. -Qed. - -Lemma prodR_ge1 (A : finType) f : (forall a, 1 <= f a) -> - 1 <= \prod_(a : A) f a. -Proof. -elim/big_ind : _ => // [|x y Hx Hy *]. - by move=> _; apply/RleP; rewrite lexx. -by rewrite -{1}(mulR1 1); apply/leR_pmul => //; [exact: Hx | exact: Hy]. -Qed. - -Lemma prodR_constE (x0 : R) (k : nat) : \prod_(i < k) x0 = x0 ^ k. -Proof. by rewrite big_const cardT size_enum_ord iter_mulR. Qed. - -Lemma prodR_card_constE (I : finType) (B : pred I) x0 : \prod_(i in B) x0 = x0 ^ #|B|. -Proof. by rewrite big_const iter_mulR. Qed. - -Lemma prodRN (I : finType) (p : pred I) (F : I -> R) : - \prod_(i in p) - F i = (-1) ^ #|p| * \prod_(i in p) F i. -Proof. -rewrite -prodR_card_constE. -apply: (big_rec3 (fun a b c => a = b * c)). -{ by rewrite mul1R. } -move=> i a b c Hi Habc; rewrite Habc; ring. -Qed. - -Lemma leR_prodR (A : finType) f g : (forall a, 0 <= f a <= g a) -> - \prod_a f a <= \prod_(a : A) g a. -Proof. -move=> fg. -have [/forallP Hf|] := boolP [forall i, f i != 0%R]; last first. - rewrite negb_forall => /existsP[i0 /negPn/eqP fi0]. - rewrite (bigD1 i0) //= fi0 mul0R; apply prodR_ge0. - by move=> i ; move: (fg i) => [Hi1 Hi2]; exact: (leR_trans Hi1 Hi2). -have Hprodf : 0 < \prod_(i : A) f i. - apply/RltP. apply prodr_gt0 => a _. apply/RltP. - move: (Hf a) (fg a) => {}Hf {fg}[Hf2 _]. - by apply/RltP; rewrite lt0r Hf/=; exact/RleP. -apply (@leR_pmul2r (1 * / \prod_(i : A) f i) _ _). - apply divR_gt0 => //; lra. -rewrite mul1R mulRV; last exact/gtR_eqF. -set inv_spec := fun r => if r == 0 then 0 else / r. -rewrite (_ : / (\prod_(a : A) f a) = inv_spec (\prod_(a : A) f a)); last first. - rewrite /inv_spec (_ : \prod_(a : A) f a == 0 = false) //. - exact/negbTE/gtR_eqF. -rewrite (@big_morph _ _ (inv_spec) R1 Rmult R1 Rmult _); last 2 first. - - move=> a b /=. - case/boolP : ((a != 0) && (b != 0)). - + move=> /andP [/negbTE Ha /negbTE Hb]; rewrite /inv_spec Ha Hb. - move/negbT in Ha ; move/negbT in Hb. - have -> : (a * b)%R == 0 = false by rewrite mulR_eq0' (negbTE Ha) (negbTE Hb). - by rewrite invRM //; exact/eqP. - + rewrite negb_and !negbK => /orP[|]/eqP ->; - by rewrite /inv_spec !(eqxx,mul0R,mulR0). - - by rewrite /inv_spec ifF ?invR1 //; exact/negbTE/eqP/R1_neq_R0. -rewrite -big_split /=; apply prodR_ge1 => a. -move/(_ a) in Hf. -move: fg => /(_ a) [Hf2 fg]. -rewrite /inv_spec. -move/negbTE in Hf; rewrite Hf; move/negbT in Hf. -rewrite -(mulRV (f a)) //. -apply leR_wpmul2r => //. -rewrite -(mul1R (/ f a)). -by apply divR_ge0; [Lra.lra |by apply/RltP; rewrite lt0r Hf; exact/RleP]. -Qed. - -End leR_ltR_rprod. - -Section bigmaxR. - -Variables (A : eqType) (F : A -> R) (s : seq A). - -Lemma leR_bigmaxR : forall m, m \in s -> F m <= \rmax_(m <- s) (F m). -Proof. -elim: s => // hd tl IH m; rewrite in_cons; case/orP. -- move/eqP => ->; rewrite big_cons; exact/leR_maxl. -- move/IH => H; rewrite big_cons; exact/(leR_trans H)/leR_maxr. -Qed. - -Lemma bigmaxR_ge0 : (forall r, r \in s -> 0 <= F r) -> 0 <= \rmax_(m <- s) (F m). -Proof. -(* TODO: generalize Order.TotalTheory.bigmax_sup to seq? *) -case: s => [_ | hd tl Hr]. -- by rewrite big_nil; exact/Rle_refl. -- apply (@leR_trans (F hd)); last by rewrite big_cons; exact: leR_maxl. - by apply: Hr; rewrite in_cons eqxx. -Qed. - -End bigmaxR. - -Lemma bigmaxR_undup (I : eqType) g : forall (s : seq I), - \rmax_(c <- s) g c = \rmax_(c <- undup s) g c. -Proof. -elim=> // hd tl IH /=. -rewrite big_cons. -case: ifP => Hcase. -- rewrite -IH Rmax_right //; exact: leR_bigmaxR. -- by rewrite big_cons IH. -Qed. - -Lemma bigmaxR_cat (I : eqType) g : forall (s1 s2 : seq I), - (forall x, x \in s1 ++ s2 -> 0 <= g x) -> - \rmax_(c <- s1 ++ s2) g c = Rmax (\rmax_(c <- s1) g c) (\rmax_(c <- s2) g c). -Proof. -elim => [s2 Hg /= | h1 t1 IH s2 Hg /=]. - by rewrite big_nil Rmax_right //; exact: bigmaxR_ge0. -rewrite 2!big_cons IH ?maxRA // => x Hx; apply: Hg. -by rewrite /= in_cons Hx orbC. -Qed. - -Lemma bigmaxR_perm (I : eqType) g : forall (s1 s2 : seq I), - (forall r, r \in s2 -> 0 <= g r) -> - perm_eq s1 s2 -> uniq s1 -> uniq s2 -> - \rmax_(c0 <- s1) g c0 = \rmax_(c0 <- s2) g c0. -Proof. -(* used perm_big ?*) -move=> s1. -move H : (size s1) => n1. -elim: n1 s1 H => //. - case=> // _ s _ Hs. - suff -> : s = [::]. - move=> _ _; by rewrite !big_nil. - destruct s => //. - move/allP : Hs. - move/(_ s). - by rewrite /= inE eqxx /= => /(_ Logic.eq_refl) /= add1n. -move=> n1 IH1 [|h1 t1] // [] H1 s2 Hg Hs2 K1 K2. -rewrite big_cons. -have [h2 [t2 ht2]] : exists h2 t2, s2 = h2 ++ h1 :: t2. - have /path.splitPr[h2 t2] : h1 \in s2 by rewrite -(perm_mem Hs2) in_cons eqxx. - by exists h2, t2. -have Hs2' : perm_eq t1 (h2 ++ t2). - rewrite ht2 in Hs2. - rewrite -(perm_cons h1). - eapply perm_trans; first by apply Hs2. - by rewrite perm_catC /= perm_cons perm_catC. -have Hg' r : r \in h2 ++ t2 -> 0 <= g r. - move=> rs2; apply Hg. - rewrite ht2 mem_cat in_cons. - rewrite mem_cat in rs2. - case/orP : rs2 => [-> // | -> /=]. - by rewrite orbA orbC. -rewrite (IH1 _ H1 _ Hg' Hs2'); last 2 first. - by case/andP : K1. - rewrite ht2 cat_uniq /= in K2. - case/andP : K2 => K2 /andP [] K4 /andP [] _ K3. - rewrite cat_uniq K2 K3 /= andbC /=. - rewrite negb_or in K4. - by case/andP : K4. -rewrite bigmaxR_cat // maxRA (maxRC (g h1)) -maxRA ht2 bigmaxR_cat; last first. - move=> x Hx; apply Hg; by rewrite ht2. -by rewrite big_cons. -Qed. - -Lemma bigmaxR_eqi (I : finType) g (s1 s2 : seq I) : - (forall r : I, r \in s1 -> 0 <= g r) -> s1 =i s2 -> - \rmax_(c0 <- s1) g c0 = \rmax_(c0 <- s2) g c0. -Proof. -move=> Hg s1s2. -rewrite (bigmaxR_undup _ _ s1) (bigmaxR_undup _ g s2). -apply bigmaxR_perm; [ | | by rewrite undup_uniq | by rewrite undup_uniq]. -- move=> r Hr; apply Hg. - rewrite mem_undup in Hr. - by rewrite s1s2. -- apply uniq_perm; [by rewrite undup_uniq | by rewrite undup_uniq | ]. - move=> i; by rewrite !mem_undup. -Qed. - -Lemma bigmaxR_imset_helper (M I : finType) h (g : I -> R) (s : seq M) : - (forall r : I, r \in enum [set h x | x in s] -> 0 <= g r) -> - \rmax_(c0 <- enum [set h x | x in s]) g c0 = \rmax_(m <- s) g (h m). -Proof. -elim: s => [|hd tl IH Hg /=]. - rewrite big_nil. - set tmp := enum _. - suff -> : tmp = [::] by rewrite big_nil. - rewrite /tmp -[in X in _ = X]enum0. - apply eq_enum => a. - rewrite !inE. - apply/imsetP. case => m. - by rewrite in_nil. -rewrite big_cons -IH; last first. - move=> r Hr. - apply Hg. - rewrite mem_enum. - apply/imsetP. - rewrite mem_enum in Hr. - case/imsetP : Hr => x xtl Hr. - exists x => //. - by rewrite in_cons xtl orbC. -transitivity (\rmax_(c0 <- h hd :: enum [set h x | x in tl]) g c0). -apply bigmaxR_eqi => // x. -rewrite inE !mem_enum. -move Hlhs : (x \in [set _ _ | _ in _]) => lhs. -destruct lhs. - - case/imsetP : Hlhs => x0 Hx0 H. - rewrite in_cons in Hx0. - case/orP : Hx0 => Hx0. - move/eqP : Hx0 => ?; subst x0. - by rewrite H eqxx. - symmetry. - apply/orP; right. - apply/imsetP; by exists x0. - - symmetry. - apply/negbTE. - move/negbT : Hlhs. - apply contra. - case/orP => Hcase. - + move/eqP in Hcase; subst x. - apply/imsetP. - exists hd => //. - by rewrite inE eqxx. - + apply/imsetP. - case/imsetP : Hcase => x0 Hx0 ?; subst x. - exists x0 => //. - by rewrite inE Hx0 orbC. -by rewrite big_cons. -Qed. - -Lemma bigmaxR_imset (M I : finType) h (g : I -> R) : - (forall r : I, r \in [set h x | x in M] -> 0 <= g r) -> - \rmax_(c0 in [set h x | x in M]) g c0 = \rmax_(m in M) g (h m). -Proof. -move=> Hg. -eapply trans_eq. - eapply trans_eq; last first. - apply (@bigmaxR_imset_helper _ I h g (enum M)). - move=> r; rewrite mem_enum; case/imsetP => x; rewrite mem_enum => Hx ->. - apply Hg; apply/imsetP; by exists x. - rewrite big_filter /=. - apply congr_big => //. - move=> i /=. - move Hlhs : (i \in _) => lhs. - destruct lhs. - - case/imsetP : Hlhs => x Hx ?; subst i. - symmetry; apply/imsetP. - exists x => //. - by rewrite mem_enum. - - symmetry. - apply/negbTE. - move/negbT : Hlhs; apply contra. - case/imsetP => m Hm ?; subst i. - apply/imsetP. - by exists m. -apply congr_big => //; by rewrite enumT. -Qed. - -Lemma leR_bigmaxRl (A : finType) (f : A -> R) (s : seq A) a : - (forall a0, 0 <= f a0) -> - (forall a0, a0 \in s -> f a0 <= f a) -> - \rmax_(a0 <- s) f a0 <= f a. -Proof. -elim: s a => [a f0 _ | a0 s' IH a f0 Hf]. - rewrite big_nil; exact/f0. -rewrite big_cons; apply Rmax_lub. -- by apply Hf; rewrite mem_head. -- apply IH => // a1 a1s; apply Hf. - by rewrite in_cons a1s orbC. -Qed. - -Lemma bigmaxR_seq_eq (A : finType) (f : A -> R) (s : seq A) a : - a \in s -> - (forall a0, 0 <= f a0) -> - (forall a0, a0 \in s -> f a0 <= f a) -> - f a = \rmax_(a0 <- s) f a0. -Proof. -elim: s a => // hd tl IH a; rewrite in_cons; case/orP. -- move/eqP => -> Hhpos Hh. - rewrite big_cons. - rewrite Rmax_left //. - apply leR_bigmaxRl => //. - move=> c0 Hc0; apply Hh. - by rewrite in_cons Hc0 orbC. -- move=> atl Hhpos Hh. - rewrite big_cons Rmax_right //. - + apply IH => //. - move=> c0 Hc0; apply Hh. - by rewrite in_cons Hc0 orbC. - + rewrite -(IH a) //. - * apply Hh. - by rewrite in_cons eqxx. - * move=> c0 Hc0. - apply Hh. - by rewrite in_cons Hc0 orbC. -Qed. - -Lemma bigmaxR_eq (A : finType) (C : {set A}) a (f : A -> R): - a \in C -> - (forall a0, 0 <= f a0) -> - (forall c, c \in C -> f c <= f a) -> - f a = \rmax_(c | c \in C) f c. -Proof. -move=> aC f0 Hf. -rewrite -big_filter. -apply bigmaxR_seq_eq => //. -- by rewrite mem_filter aC /= mem_index_enum. -- by move=> a0; rewrite mem_filter mem_index_enum andbT => /Hf. -Qed. - -Local Open Scope R_scope. - -Lemma bigmaxR_distrr I a (a0 : 0 <= a) r (P : pred I) F : - (a * \rmax_(i <- r | P i) F i) = \rmax_(i <- r | P i) (a * F i). -Proof. -elim: r => [| h t IH]. - by rewrite 2!big_nil mulR0. -rewrite 2!big_cons. -case: ifP => Qh //. -by rewrite -IH RmaxRmult. -Qed. - -Lemma bigmaxR_distrl I a (a0 : 0 <= a) r (P : pred I) F : - (\rmax_(i <- r | P i) F i) * a = \rmax_(i <- r | P i) (F i * a). -Proof. -by rewrite mulRC bigmaxR_distrr //; apply congr_big => // ?; rewrite mulRC. -Qed. - -Notation "\min^ b '_(' a 'in' A ) F" := - ((fun a => F) (arg_min b (fun x => x \in A) (fun a => F))) : min_scope. - -Local Open Scope min_scope. - -Lemma leq_bigmin (A : finType) (C : {set A}) (cnot0 : {c0 | c0 \in C}) - a (Ha : a \in C) (h : A -> nat) : - (\min^ (sval cnot0) _(c in C) h c <= h a)%nat. -Proof. by case: arg_minnP; [case: cnot0|move=> a0 a0C; exact]. Qed. - -Lemma bigmaxR_bigmin_helper (A : finType) n (g : nat -> R) : - (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) -> - (forall r, 0 <= g r) -> - forall (C : {set n.-tuple A}) c (_ : c \in C) (d : n.-tuple A -> nat) - (_ : forall c, c \in C -> (d c <= n)%nat) - (cnot0 : {c0 | c0 \in C}), - d c = \min^ (sval cnot0) _(c in C) d c -> - g (d c) = \rmax_(c in C) g (d c). -Proof. -move=> Hdecr Hr C c cC d Hd cnot0 H. -apply (@bigmaxR_eq _ C c (fun a => g (d a))) => //. -move=> /= c0 c0C. -apply/Hdecr/andP; split; [|exact: Hd]. -rewrite H; exact: leq_bigmin. -Qed. - -(* TODO: useful for? *) -Lemma bigmaxR_bigmin (A M : finType) n (f : {ffun M -> n.-tuple A}) (g : nat -> R) - (cnot0 : {c0 | c0 \in f @: M } ) : - (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) -> - (forall r, 0 <= g r) -> - forall m (d : n.-tuple A -> nat) - (_ : forall c0 : n.-tuple A, c0 \in [set f x | x : M] -> (d c0 <= n)%nat), - d (f m) = \min^ (sval cnot0) _(c in [set f x | x in M]) d c -> - g (d (f m)) = \rmax_(m | m \in M) g (d (f m)). -Proof. -move=> n1n2 Hg m d H Hd. -transitivity (\rmax_(c in [set f x | x in M]) g (d c)); last by rewrite bigmaxR_imset. -apply bigmaxR_bigmin_helper with cnot0 => //. -apply/imsetP; by exists m. -Qed. - -From mathcomp Require Import matrix. - -Lemma bigmaxR_bigmin_vec_helper (A : finType) n (g : nat -> R) : - (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) -> - (forall r, 0 <= g r) -> - forall (C : {set 'rV[A]_n}) c (_ : c \in C) (d : 'rV[A]_n -> nat) - (_ : forall c, c \in C -> (d c <= n)%nat) - (cnot0 : {c0 | c0 \in C}), - d c = \min^ (sval cnot0) _(c in C) d c -> - g (d c) = \rmax_(c in C) g (d c). -Proof. -move=> Hdecr Hr C c cC d Hd cnot0 H. -apply (@bigmaxR_eq _ C c (fun a => g (d a))) => //. -move=> /= c0 c0C. -apply/Hdecr/andP; split; [|exact: Hd]. -rewrite H; exact: leq_bigmin. -Qed. - -Lemma bigmaxR_bigmin_vec (A M : finType) n (f : {ffun M -> 'rV[A]_n}) (g : nat -> R) - (cnot0 : {c0 | c0 \in f @: M } ) : - (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) -> - (forall r, 0 <= g r) -> - forall m (d : 'rV[A]_n -> nat) - (_ : forall c0 : 'rV[A]_n, c0 \in f @: M -> (d c0 <= n)%nat), - d (f m) = \min^ (sval cnot0) _(c in f @: M) d c -> - g (d (f m)) = \rmax_(m in M) g (d (f m)). -Proof. -move=> n1n2 Hg m d H Hd. -transitivity (\rmax_(c in f @: M) g (d c)); last by rewrite bigmaxR_imset. -apply bigmaxR_bigmin_vec_helper with cnot0 => //. -by apply/imsetP; exists m. -Qed. diff --git a/lib/ssrZ.v b/lib/ssrZ.v deleted file mode 100644 index 24dce60b..00000000 --- a/lib/ssrZ.v +++ /dev/null @@ -1,418 +0,0 @@ -(* infotheo: information theory and error-correcting codes in Coq *) -(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From HB Require Import structures. -From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat. -Require Import ZArith Lia. - -(******************************************************************************) -(* SSReflect-like lemmas for Coq Z *) -(* *) -(* On the model of ssrR *) -(******************************************************************************) - -(* TODO: we should maybe extend mczify's ssrZ... *) - -Reserved Notation "n %:Z" (at level 2, left associativity, format "n %:Z"). - -Declare Scope zarith_ext_scope. - -Local Open Scope Z_scope. - -Notation "`| x |" := (Z.abs x) : zarith_ext_scope. -Definition natZ := nosimpl Z_of_nat. -Notation "n %:Z" := (natZ n) : zarith_ext_scope. -Notation "z .+1Z" := (Z.succ z) (at level 2, left associativity, - format "z .+1Z") : zarith_ext_scope. -Notation "'| x |" := (Z.abs_nat x) : zarith_ext_scope. -Notation "'gcdZ'" := Z.gcd : zarith_ext_scope. -Notation "'sgZ'" := Z.sgn : zarith_ext_scope. -Notation "'divZ'" := Z.div : zarith_ext_scope. - -Local Open Scope zarith_ext_scope. - -Lemma eqZP : Equality.axiom Zeq_bool. -Proof. by move=> x y; apply: (iffP idP) => H; apply/Zeq_is_eq_bool. Qed. - -HB.instance Definition _ := hasDecEq.Build Z eqZP. - -Arguments eqZP {x y}. - -Lemma natZ0 : 0%:Z = 0%Z. Proof. exact: Nat2Z.inj_0. Qed. - -Lemma natZS n : n.+1%:Z = n%:Z.+1Z. Proof. by rewrite -Zpos_P_of_succ_nat. Qed. - -(* TODO: is it the right name? *) -Lemma intRD n m : (n + m)%:Z = (n%:Z + m%:Z)%Z. Proof. exact/Nat2Z.inj_add. Qed. - -Definition addZ0 := Zplus_0_r. -Definition add0Z := Zplus_0_l. - -Lemma add1Z z : (1 + z)%Z = z.+1Z. Proof. by rewrite Z.add_1_l. Qed. - -Definition addZC : commutative Zplus := Zplus_comm. -Definition addZA : associative Zplus := Zplus_assoc. - -Lemma addZAC : right_commutative Zplus. Proof. by move=> ? ? ?; ring. Qed. - -Lemma addZCA : left_commutative Zplus. Proof. by move=> ? ? ?; ring. Qed. - -Definition addZZ := Zplus_diag_eq_mult_2. - -Definition subZ0 := Z.sub_0_r. -(* aka Zminus_0_r *) -Definition subZZ := Z.sub_diag. - -Definition addZNE a b : a + - b = a - b := Z.add_opp_r a b. - -Definition addZK n : cancel (Zplus^~ n) (Zminus^~ n). -Proof. by move=> ?; exact: Z.add_simpl_r. Qed. - -Definition addZN n : n + - n = 0 := Z.add_opp_diag_r n. -(* aka Zplus_opp_r *) - -Lemma subZKC m n : m + (n - m) = n. Proof. exact: Zplus_minus. Qed. - -Lemma eqZ_add2r p m n : (m + p = n + p) <-> (m = n). -Proof. -by split => [|->//]; rewrite -!(addZC p); exact: Z.add_reg_l. -Qed. -(* NB: Zplus_reg_l *) - -Lemma eqZ_add2l p m n : (p + m = p + n) <-> (m = n). -Proof. by split => [|->//]; exact: Z.add_reg_l. Qed. - -Lemma eqZ_opp x y : (- x = - y) <-> (x = y). -Proof. exact: Z.opp_inj_wd. Qed. - -(* Z.leb_spec0 : forall x y : Z, Bool.reflect (x <= y) (x <=? y) *) -Lemma leZP {m n} : reflect (m <= n) (Zle_bool m n). -Proof. by apply: (iffP idP); apply Z.leb_le. Qed. - -(* Z.ltb_spec0 forall x y : Z, reflect (x < y) (x = n) (m >=? n). -Proof. by apply: (iffP idP); rewrite /Z.ge /Zge_bool; destruct (m ?= n). Qed. - -Lemma gtZP {m n} : reflect (m > n) (m >? n). -Proof. by apply: (iffP idP); rewrite /Z.gt /Zgt_bool; destruct (m ?= n). Qed. - -Lemma leZNgt n m : n <= m <-> ~ m < n. -Proof. by split; [exact: Zle_not_lt | exact: Z.Private_Tac.not_gt_le]. Qed. -Definition leZNgt' := Z.leb_antisym. - -Lemma ltZNge n m : n < m <-> ~ m <= n. -Proof. by split; [exact: Zlt_not_le | exact: Z.Private_Tac.not_ge_lt]. Qed. -Definition ltZNge' := Z.ltb_antisym. - -Definition ltZ_eqF := Z.lt_neq. -(* aka Zlt_not_eq *) - -Lemma gtZ_eqF a b : a < b -> b <> a. -Proof. by move/ltZ_eqF/nesym. Qed. - -Lemma neq_Zlt (a b : Z) : (a != b) <-> (a < b)%Z \/ (b < a)%Z. -Proof. -by split => [/eqP/not_Zeq//|[ab|ba]]; [exact/eqP/ltZ_eqF|exact/eqP/gtZ_eqF]. -Qed. - -Definition leZZ := Z.le_refl. -Definition leZZ' := Z.leb_refl. -Definition ltZZ := Z.lt_irrefl. -Definition ltZZ' := Z.ltb_irrefl. - -Lemma leZ_trans {m n p} : n <= m -> m <= p -> n <= p. -Proof. exact: Z.le_trans. Qed. - -Lemma ltZ_trans {m n p} : n < m -> m < p -> n < p. -Proof. exact: Z.lt_trans. Qed. - -Lemma leZ_ltZ_trans {m n p} : n <= m -> m < p -> n < p. -Proof. exact: Z.le_lt_trans. Qed. - -Lemma ltZ_leZ_trans {m n p} : n < m -> m <= p -> n < p. -Proof. exact: Z.lt_le_trans. Qed. - -Definition oppZK := Z.opp_involutive. -Definition oppZ0 := Z.opp_0. - -Definition ltZW {m n} : m < n -> m <= n := Z.lt_le_incl m n. -(* aka Zlt_le_weak *) -Lemma ltZW' {m n} : m m <=? n. -Proof. by move/ltZP => ?; apply/leZP; lia. Qed. - -Lemma leZ_eqVlt m n : (m <= n) <-> (m = n) \/ (m < n). -Proof. -split => [|[->|]]. - case/Zle_lt_or_eq => ?; by [right|left]. -exact: leZZ. -exact: ltZW. -Qed. -Lemma leZ_eqVlt' m n : (m <=? n) = (m == n) || (m [/leZP/leZ_eqVlt[/eqP -> //|/ltZP ->]|/orP[/eqP ->|/ltZP]]. - by rewrite orbT. -by rewrite leZZ'. -by move/ltZP/ltZW'. -Qed. - -Lemma ltZ_neqAle m n : (m < n) <-> (m <> n) /\ (m <= n). -Proof. -split => [mn|[H]]; last by rewrite leZ_eqVlt => -[|]. -by split; [exact/nesym/gtZ_eqF | exact/ltZW]. -Qed. -Lemma ltZ_neqAle' m n : (m [/ltZP mn|]. - by apply/andP; split; [apply/eqP; lia | exact/ltZW'/ltZP]. -by case/andP => /eqP H1 /leZP H2; apply/ltZP; lia. -Qed. - -Definition mul0Z : left_zero 0 Z.mul := Zmult_0_l. -Definition mulZ0 : right_zero 0 Z.mul := Zmult_0_r. -Definition mul1Z : left_id 1 Z.mul := Zmult_1_l. -Definition mulZ1 : right_id 1 Z.mul := Zmult_1_r. -Definition mulZC : commutative Zmult := Zmult_comm. -Lemma mulN1Z n : -1 * n = - n. -Proof. by rewrite mulZC Zopp_eq_mult_neg_1. Qed. -Lemma mulZN1 n : n * -1 = - n. -Proof. by rewrite Z.opp_eq_mul_m1. Qed. - -Definition mulZN x y : x * (- y) = - (x * y) := Z.mul_opp_r x y. -Definition mulNZ x y : (- x) * y = - (x * y) := Z.mul_opp_l x y. -Lemma mulZNN x y : (- x) * (- y) = x * y. Proof. by rewrite Z.mul_opp_opp. Qed. -(* NB: Z.mul_opp_comm : forall n m : Z, - n * m = n * - m *) -(* NB: Zopp_mult_distr_l : forall n m : Z, - (n * m) = - n * m *) - -Lemma eqZ_mul2l p n m : p <> 0 -> p * n = p * m <-> n = m. -Proof. by move=> p0; split; [exact: Zmult_reg_l | move=> ->]. Qed. - -Lemma eqZ_mul2r p n m : p <> 0 -> n * p = m * p <-> n = m. -Proof. by move=> p0; split; [exact: Z.mul_reg_r | move=> ->]. Qed. - -Lemma mulZDl : left_distributive Zmult Zplus. -Proof. by move=> *; rewrite Z.mul_add_distr_r. (* aka Zmult_plus_distr_l *) Qed. -Lemma mulZDr : right_distributive Zmult Zplus. -Proof. by move=> *; rewrite Z.mul_add_distr_l. (* aka Zmult_plus_distr_r *) Qed. -Lemma mulZBl : left_distributive Zmult Zminus. -Proof. by move=> *; rewrite Z.mul_sub_distr_r. (* aka Zmult_minus_distr_r *) Qed. -Lemma mulZBr : right_distributive Zmult Zminus. -Proof. by move=> *; rewrite Zmult_minus_distr_l. Qed. - -Lemma mulZ_eq0 x y : (x * y == 0) = ((x == 0) || (y == 0)). -Proof. -apply/idP/idP => [/eqP/Zmult_integral[] ->| ]; try by rewrite eqxx // orbC. -by case/orP => /eqP ->; rewrite ?mulZ0 ?mul0Z. -Qed. - -Definition mulZA : associative Zmult := Zmult_assoc. - -Lemma leZ_oppr x y : (x <= - y) <-> (y <= - x). -Proof. by split=> /Z.opp_le_mono; rewrite oppZK. Qed. - -Lemma leZ_oppl x y : (- x <= y) <-> (- y <= x). -Proof. by split=> /Z.opp_le_mono; rewrite oppZK. Qed. - -Lemma ltZ_oppr x y : (x < - y) <-> (y < - x). -Proof. by split=> /Z.opp_lt_mono; rewrite oppZK. Qed. - -Lemma ltZ_oppl x y : (- x < y) <-> (- y < x). -Proof. by split=> /Z.opp_lt_mono; rewrite oppZK. Qed. - -Definition addZ_ge0 := Z.add_nonneg_nonneg. (* 0 <= n -> 0 <= m -> 0 <= n + m *) -(* aka Zplus_le_0_compat *) -Definition addZ_gt0 := Z.add_pos_pos. (* 0 < n -> 0 < m -> 0 < n + m *) -Definition addZ_gt0wr := Z.add_nonneg_pos. (* 0 <= n -> 0 < m -> 0 < n + m *) -Definition addZ_gt0wl := Z.add_pos_nonneg. (* 0 < n -> 0 <= m -> 0 < n + m *) - -Definition leZ_add := Z.add_le_mono. (* n <= m -> p <= q -> n + p <= m + q *) -(* aka Zplus_le_compat *) -Definition leZ_lt_add := Z.add_le_lt_mono. (* x <= y -> z < t -> x + z < y + t *) -(* aka Zplus_le_lt_compat *) -Definition ltZ_le_add := Z.add_lt_le_mono. (* x < y -> z <= t -> x + z < y + t *) - -Lemma leZ_sub x y z t : x <= y -> t <= z -> x - z <= y - t. -Proof. exact: Z.sub_le_mono. Qed. - -Lemma leZ_add2r {p m n} : m + p <= n + p <-> m <= n. -Proof. by split; [exact: Zplus_le_reg_r | exact: Zplus_le_compat_r]. Qed. -Lemma leZ_add2r' p m n : (m + p <=? n + p) = (m <=? n). -Proof. by apply/idP/idP => [/leZP/leZ_add2r/leZP //|/leZP/leZ_add2r/leZP]. Qed. - -Definition ltZ_add := Z.add_lt_mono. -(* aka Zplus_lt_compat *) - -Lemma leZ_add2l {p m n} : p + m <= p + n <-> m <= n. -Proof. by split; [exact: Zplus_le_reg_l | exact: Zplus_le_compat_l]. Qed. - -Lemma leZ_addl a b c : 0 <= b -> a <= c -> a <= b + c. -Proof. by move=> b0 ac; rewrite -(add0Z a); exact: leZ_add. Qed. - -Lemma leZ_addr a b c : 0 <= c -> a <= b -> a <= b + c. -Proof. by move=> b0 ac; rewrite -(addZ0 a); exact: leZ_add. Qed. - -Lemma ltZ_addl a b c : 0 <= b -> a < c -> a < b + c. -Proof. by move=> b0 ac; rewrite -(add0Z a); exact: leZ_lt_add. Qed. - -Lemma ltZ_addr a b c : 0 < c -> a <= b -> a < b + c. -Proof. by move=> b0 ac; rewrite -(addZ0 a); exact: leZ_lt_add. Qed. - -Lemma addr_leZ a b c : b <= 0 -> a <= c -> a + b <= c. -Proof. by move=> b0 ab; rewrite -(addZ0 c); exact: leZ_add. Qed. - -Lemma ltZ_add2r p {m n : Z} : (m + p < n + p) <-> (m < n). -Proof. by split; [exact/Zplus_lt_reg_r | exact/Zplus_lt_compat_r]. Qed. -Lemma ltZ_add2r' (p m n : Z) : (m + p [/ltZP/ltZ_add2r/ltZP|/ltZP/(@ltZ_add2r p)/ltZP]. Qed. - -Lemma ltZ_add2l p {m n : Z} : (p + m < p + n) <-> (m < n). -Proof. by split; [exact/Zplus_lt_reg_l | exact/Zplus_lt_compat_l]. Qed. -Lemma ltZ_add2l' p {m n} : (p + m n - p <= m - p. -Proof. by move=> ?; lia. Qed. - -Lemma ltZ_sub2r {n m p} : n < m -> n - p < m - p. -Proof. by move=> ?; lia. Qed. - -Definition mulZ_gt0 := Z.mul_pos_pos. (* 0 < n -> 0 < m -> 0 < n * m *) -(* aka Zmult_lt_0_compat *) -Definition mulZ_ge0 := Z.mul_nonneg_nonneg. (* 0 <= n -> 0 <= m -> 0 <= n * m *) -(* aka Zmult_le_0_compat *) - -Lemma pmulZ_rgt0 x y : 0 < x -> (0 < x * y) <-> (0 < y). -Proof. -by move=> x0; split; [rewrite mulZC; apply Zmult_lt_0_reg_r|exact: mulZ_gt0]. -Qed. -(* instead of Zmult_gt_0_lt_0_reg_r and Zmult_lt_0_reg_r *) - -Lemma leZ_wpmul2r p n m : 0 <= p -> n <= m -> n * p <= m * p. -Proof. by move=> *; apply Zmult_le_compat_r. Qed. -Lemma leZ_wpmul2l p n m : 0 <= p -> n <= m -> p * n <= p * m. -Proof. by move=> *; apply Zmult_le_compat_l. Qed. -Lemma leZ_pmul m n p q : 0 <= n -> 0 <= m -> n <= p -> m <= q -> n * m <= p * q. -Proof. by move=> *; exact/Zmult_le_compat. Qed. - -Lemma ltZ_pmul m n p q : 0 < n -> 0 < m -> n <= p -> m < q -> n * m < p * q. -Proof. by move=> *; exact: Zmult_lt_compat2. Qed. - -Lemma leZ_pmul2r m n1 n2 : 0 < m -> n1 * m <= n2 * m <-> (n1 <= n2). -Proof. -move=> m0; split; first by apply: Zmult_le_reg_r; apply Z.lt_gt. -by move=> *; apply leZ_wpmul2r => //; exact: ltZW. -Qed. -Lemma leZ_pmul2r' m n1 n2 : 0 < m -> n1 * m <=? n2 * m = (n1 <=? n2). -Proof. by move=> H; apply/idP/idP => /leZP/(leZ_pmul2r _ _ _ H)/leZP. Qed. - -Lemma leZ_pmul2l m n1 n2 : 0 < m -> m * n1 <= m * n2 <-> (n1 <= n2). -Proof. -move=> m0; split; first by rewrite !(mulZC m); exact: Zmult_lt_0_le_reg_r. -by move/Zmult_le_compat_l; apply; exact/ltZW. -Qed. -Lemma leZ_pmul2l' m n1 n2 : 0 < m -> m * n1 <=? m * n2 = (n1 <=? n2). -Proof. by move=> ?; rewrite -(mulZC n1) -(mulZC n2) leZ_pmul2r'. Qed. - -Lemma ltZ_pmul2r m n1 n2 : 0 < m -> (n1 * m < n2 * m) <-> (n1 < n2). -Proof. -by move=> ?; split; [exact/Zmult_gt_0_lt_reg_r/Z.lt_gt|exact/Zmult_lt_compat_r]. -Qed. -Lemma ltZ_pmul2r' m n1 n2 : 0 < m -> n1 * m H; apply/idP/idP => /ltZP/(ltZ_pmul2r _ _ _ H)/ltZP. Qed. - -Lemma ltZ_pmul2l m n1 n2 : 0 < m -> (m * n1 < m * n2) <-> (n1 < n2). -Proof. by rewrite 2!(mulZC m); exact: ltZ_pmul2r. Qed. - -Lemma pmulZ_rge0 x y : 0 < x -> (0 <= x * y) <-> (0 <= y). -Proof. exact: Z.mul_nonneg_cancel_l. Qed. -(* NB: Zmult_gt_0_le_0_compat *) - -Lemma pmulZ_lgt0 x y : 0 < x -> (0 < y * x) <-> (0 < y). -Proof. by move=> x0; rewrite -{1}(mul0Z x) ltZ_pmul2r. Qed. - -Lemma pmulZ_llt0 x y : 0 < x -> (y * x < 0) <-> (y < 0). -Proof. by move=> x0; rewrite -{1}(mul0Z x) ltZ_pmul2r. Qed. - -Lemma mulZ_ge0_le0 a b : 0 <= a -> b <= 0 -> a * b <= 0. -Proof. by move: a b => [|a|a] // b Ha Hb; case: b Hb. Qed. - -Lemma leZ_subLR m n p : (m - n <= p) <-> (m <= n + p). -Proof. by rewrite Zle_plus_swap Z.sub_opp_r addZC. Qed. - -Lemma ltZ_subLR m n p : (m - n < p) <-> (m < n + p). -Proof. by rewrite Zlt_plus_swap Z.sub_opp_r addZC. Qed. - -Lemma leZ_subRL m n p : (n <= p - m) <-> (m + n <= p). -Proof. -split => [/(@leZ_add2l m)|H]; first by rewrite subZKC. -by apply (@leZ_add2l m); rewrite subZKC. -Qed. - -Lemma ltZadd1 {m n} : m < n + 1 <-> m <= n. Proof. by lia. Qed. - -Lemma leZsub1 a b : a <= b - 1 <-> a < b. -Proof. by rewrite leZ_subRL addZC -ltZadd1 ltZ_add2r. Qed. - -Lemma ltZ_subRL m n p : (n < p - m) <-> (m + n < p). -Proof. -split => [/(@ltZ_add2l m)|H]; first by rewrite subZKC. -by apply (@ltZ_add2l m); rewrite subZKC. -Qed. -(* NB: Z.lt_add_lt_sub_r : forall n m p : Z, n + p < m <-> n < m - p *) -Lemma ltZ_subRL' m n p : (n /ltZP/ltZ_subRL/ltZP. Qed. - -Definition ltZ_addr_subl := ltZ_subRL. - -Lemma leZ0n n : 0 <= n%:Z. Proof. exact: Zle_0_nat. Qed. - -Lemma Z_S n : Z_of_nat n.+1 = Z_of_nat n + 1. -Proof. by rewrite inj_S. Qed. - -Lemma Z_of_nat_inj : forall x y, Z_of_nat x = Z_of_nat y -> x = y. -Proof. exact: Nat2Z.inj. Qed. - -Lemma Z_of_nat_inj_neq x y : Z_of_nat x <> Z_of_nat y -> x <> y. -Proof. by move=> H H'; apply H; f_equal. Qed. - -Lemma leZ_nat n m : (n <= m)%nat = (n%:Z <=? m%:Z). -Proof. -case/boolP : (n <= m)%nat => H; first by apply/esym/leZP/Nat2Z.inj_le/leP. -by apply/esym/negbTE; by apply: contra H => /leZP/Nat2Z.inj_le/leP. -Qed. - -Lemma ltZ_nat n m : (n < m)%nat = (n%:Z H; first by apply/esym/ltZP/Nat2Z.inj_lt/ltP. -by apply/esym/negbTE; apply: contra H => /ltZP/Nat2Z.inj_lt/ltP. -Qed. - -Definition normZ0 := Z.abs_0. - -Lemma normZM : {morph Z.abs : x y / x * y : Z}. Proof. exact: Z.abs_mul. Qed. -(*Lemma Z.abs_mul : forall n m : Z, `|n * m| = `|n| * `|m|*) - -Lemma geZ0_norm x : 0 <= x -> `|x| = x. Proof. exact: Z.abs_eq. Qed. - -Lemma normZ_ge0 : forall z, 0 <= `| z |. Proof. by case. Qed. - -Lemma ltZ_norml x y : `|x| < y <-> (- y < x < y). -Proof. -split => [H | [H1 H2] ]. -- case: (Z_le_gt_dec x 0) => x0; first by rewrite Zabs_non_eq // in H; lia. - rewrite Z.abs_eq // in H; last by lia. - by split => //; lia. -- case: (Z_le_gt_dec 0 x) => x0; first by rewrite Z.abs_eq. - by rewrite Zabs_non_eq; [lia | exact/ltZW/Z.gt_lt]. -Qed. - -Lemma leZ_norml x y : `|x| <= y <-> (- y <= x <= y). -Proof. -split => [H | [H1 H2] ]. -- case: (Z_le_gt_dec x 0) => x0; first by rewrite Zabs_non_eq // in H; lia. - rewrite Z.abs_eq // in H; last by lia. - by split => //; lia. -- case: (Z_le_gt_dec 0 x) => x0; first by rewrite Z.abs_eq. - by rewrite Zabs_non_eq; [lia | exact/ltZW/Z.gt_lt]. -Qed. diff --git a/lib/ssr_ext.v b/lib/ssr_ext.v index 51931ab1..e2b710c3 100644 --- a/lib/ssr_ext.v +++ b/lib/ssr_ext.v @@ -12,14 +12,19 @@ Declare Scope vec_ext_scope. Notation "t '!_' i" := (tnth t i) (at level 9) : tuple_ext_scope. Reserved Notation "A `* B" (at level 46, left associativity). +Reserved Notation "A :+: B" (at level 52, left associativity). Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Lemma addb_tri_ine a b c : a (+) b <= (a (+) c) + (c (+) b). +Section ssrbool_ext. + +Lemma addb_tri_ine (a b c : bool) : a (+) b <= (a (+) c) + (c (+) b). Proof. move: a b c; by case; case; case. Qed. +End ssrbool_ext. + Section ssrnat_ext. Lemma nat_of_pos_not_0 : forall p, nat_of_pos p <> O. @@ -102,25 +107,6 @@ Proof. by rewrite -(nat_of_binK (BinNat.Npos k)). Qed. End ssrnat_ext. -Definition swap {A B : Type} (ab : A * B) := (ab.2, ab.1). - -Lemma injective_swap (A B : finType) (E : {set A * B}) : {in E &, injective swap}. -Proof. by case=> a b [a0 b0] /= _ _ [-> ->]. Qed. - -Lemma set_swap (A B : finType) (P : B -> A -> bool) : - [set h : {: B * A} | P h.1 h.2 ] = swap @: [set h | P h.2 h.1]. -Proof. -apply/setP => /= -[b a]; rewrite !inE /=; apply/idP/imsetP => [H|]. -- by exists (a, b) => //=; rewrite inE. -- by case=> -[a0 b0]; rewrite inE /= => ? [-> ->]. -Qed. - -Lemma setT_bool : [set: bool] = [set true; false]. -Proof. -apply/eqP; rewrite eqEsubset; apply/andP; split => //. -by apply/subsetP => x; rewrite !inE; case: x. -Qed. - Section Flatten. Variables (A B : eqType) (f : A -> seq B). @@ -177,10 +163,6 @@ Qed. End Flatten. -Lemma eq_in_map_seqs {A B : eqType} (f1 f2 : A -> B) l1 l2 : - l1 = l2 -> {in l1, f1 =1 f2} -> map f1 l1 = map f2 l2. -Proof. by move=> <-; apply eq_in_map. Qed. - Section seq_ext. Variables A B : Type. @@ -298,6 +280,10 @@ End Pad. Section seq_eqType_ext. +Lemma eq_in_map_seqs {A B : eqType} (f1 f2 : A -> B) l1 l2 : + l1 = l2 -> {in l1, f1 =1 f2} -> map f1 l1 = map f2 l2. +Proof. by move=> <-; apply eq_in_map. Qed. + Variables A B : eqType. Lemma take_index (a : A) s : a \notin take (index a s) s. @@ -454,6 +440,8 @@ Qed. End seq_eqType_ext. +Section seq_bool. + Lemma addb_nseq b : forall r v, size v = r -> [seq x.1 (+) x.2 | x <- zip (nseq r b) v] = map (pred1 (negb b)) v. Proof. @@ -482,41 +470,56 @@ elim => [[] // [] //| n IH [|ha ta] // [|hb tb] //= f [Ha] [Hb]]. by rewrite /addb_seq /= -IH. Qed. -Lemma ord1 (i : 'I_1) : i = ord0. Proof. case: i => [[]] // ?; exact/eqP. Qed. - -Lemma ord2 (i : 'I_2) : (i == ord0) || (i == Ordinal (erefl (1 < 2))). -Proof. by case: i => -[|[|]]. Qed. +End seq_bool. -Lemma ord3 (i : 'I_3) : - [|| i == ord0, i == Ordinal (erefl (1 < 3)) | i == Ordinal (erefl (2 < 3))]. -Proof. by case: i => -[|[|[|]]]. Qed. - -Lemma enum_inord (m : nat) : enum 'I_m.+1 = [seq inord i | i <- iota 0 m.+1]. -Proof. -rewrite -val_enum_ord -map_comp. -transitivity ([seq i | i <- enum 'I_m.+1]); first by rewrite map_id. -apply eq_map => i /=; by rewrite inord_val. -Qed. - -Lemma split_lshift n m (i : 'I_n) : fintype.split (lshift m i) = inl i. -Proof. by rewrite -/(unsplit (inl i)) unsplitK. Qed. - -Lemma split_rshift n m (i : 'I_m) : fintype.split (rshift n i) = inr i. -Proof. by rewrite -/(unsplit (inr i)) unsplitK. Qed. +Section finfun_ext. Lemma inj_card (A B : finType) (f : {ffun A -> B}) : injective f -> #| A | <= #| B |. Proof. move=> Hf; by rewrite -(@card_imset _ _ f) // max_card. Qed. -Lemma size_index_enum (T : finType) : size (index_enum T) = #|T|. -Proof. by rewrite cardT enumT. Qed. +End finfun_ext. Section finset_ext. Implicit Types A B : finType. +Definition swap {A B : Type} (ab : A * B) := (ab.2, ab.1). + +Lemma injective_swap (A B : finType) (E : {set A * B}) : {in E &, injective swap}. +Proof. by case=> a b [a0 b0] /= _ _ [-> ->]. Qed. + +Lemma set_swap (A B : finType) (P : B -> A -> bool) : + [set h : {: B * A} | P h.1 h.2 ] = swap @: [set h | P h.2 h.1]. +Proof. +apply/setP => /= -[b a]; rewrite !inE /=; apply/idP/imsetP => [H|]. +- by exists (a, b) => //=; rewrite inE. +- by case=> -[a0 b0]; rewrite inE /= => ? [-> ->]. +Qed. + +Lemma setT_bool : [set: bool] = [set true; false]. +Proof. +apply/eqP; rewrite eqEsubset; apply/andP; split => //. +by apply/subsetP => x; rewrite !inE; case: x. +Qed. + Lemma setDUKl A (E F : {set A}) : (E :|: F) :\: E = F :\: E. Proof. by rewrite setDUl setDv set0U. Qed. +Lemma setDIlW (T : finType) (A B C : {set T}) : + A :&: B :\: C = A :&: B :\: C :&: B. +Proof. +apply/setP=> x; rewrite !inE. +by case: (x \in A); case: (x \in B); case: (x \in C). +Qed. + +Lemma setIDACW (T : finType) (A B C : {set T}) : + (A :\: B) :&: C = A :&: C :\: B :&: C. +Proof. by rewrite setIDAC setDIlW. Qed. + +Lemma setDAC (T : finType) (A B C : {set T}) : + A :\: B :\: C = A :\: C :\: B. +Proof. by rewrite setDDl setUC -setDDl. Qed. + Lemma setU_setUD A (E F : {set A}) : E :|: F = F :|: E :\: F. Proof. apply/setP => a; rewrite !inE; apply/orP/orP => -[->|H] ; [ @@ -657,8 +660,50 @@ move=> xB; case/(B_covered x)/imsetP: (xB) => y yI xhy. by apply/imsetP; exists y => //; rewrite inE -xhy. Qed. +Lemma big_set2 (R : Type) (idx : R) (op : Monoid.com_law idx) (I : finType) + (a b : I) (F : I -> R) : + a != b -> \big[op/idx]_(i in [set a; b]) F i = op (F a) (F b). +Proof. by move=> ab; rewrite big_setU1 ?inE // big_set1. Qed. + +Definition setY (T : finType) (A B : {set T}) := (A :\: B :|: B :\: A). +Notation "A :+: B" := (setY A B). + +Section setY_lemmas. +Variable (T : finType). +Local Notation "+%S" := (@setY T). +Local Notation "-%S" := idfun. +Local Notation "0" := (@set0 T). + +Lemma setYA : associative +%S. +Proof. +move=> x y z; apply/setP=> i; rewrite !inE. +by case: (i \in x); case: (i \in y); case: (i \in z). +Qed. +Lemma setYC : commutative +%S. +Proof. by move=> *; rewrite /setY setUC. Qed. +Lemma set0Y : left_id 0 +%S. +Proof. by move=> ?; rewrite /setY set0D setD0 set0U. Qed. +Lemma setNY : left_inverse 0 -%S +%S. +Proof. by move=> *; rewrite /setY /= setDv setU0. Qed. +Lemma setIYl : left_distributive (@setI T) +%S. +Proof. by move=> *; rewrite [in LHS]/setY setIUl !setIDACW. Qed. + +Lemma setIUY (A B : {set T}) : + (A :+: B) :|: (A :&: B) = A :|: B. +Proof. by apply/setP=> x; rewrite !inE; case: (x \in A); case: (x \in B). Qed. + +Lemma setIYI_disj (A B : {set T}) : + [disjoint (A :+: B) & (A :&: B)]. +Proof. +rewrite -setI_eq0; apply/eqP/setP=> x; rewrite !inE. +by case: (x \in A); case: (x \in B). +Qed. + +End setY_lemmas. + End finset_ext. Notation "A `* B" := (setX A B) : set_scope. +Notation "A :+: B" := (setY A B). Module Set2. Section set2. @@ -993,6 +1038,8 @@ Qed.*) End perm_enum. +Section fingraph_ext. + Lemma connect_sym1 (D : finType) (r : rel D) : symmetric r -> forall x y, connect r x y -> connect r y x. Proof. @@ -1028,6 +1075,8 @@ Proof. move=> ?; rewrite /connect_sym => ? ?; apply/idP/idP => /connect_sym1; exact. Qed. +End fingraph_ext. + Section uniq_path. Variable A : eqType. @@ -1087,6 +1136,31 @@ End boolP. Section fintype_extra. +Lemma ord1 (i : 'I_1) : i = ord0. Proof. case: i => [[]] // ?; exact/eqP. Qed. + +Lemma ord2 (i : 'I_2) : (i == ord0) || (i == Ordinal (erefl (1 < 2))). +Proof. by case: i => -[|[|]]. Qed. + +Lemma ord3 (i : 'I_3) : + [|| i == ord0, i == Ordinal (erefl (1 < 3)) | i == Ordinal (erefl (2 < 3))]. +Proof. by case: i => -[|[|[|]]]. Qed. + +Lemma enum_inord (m : nat) : enum 'I_m.+1 = [seq inord i | i <- iota 0 m.+1]. +Proof. +rewrite -val_enum_ord -map_comp. +transitivity ([seq i | i <- enum 'I_m.+1]); first by rewrite map_id. +apply eq_map => i /=; by rewrite inord_val. +Qed. + +Lemma split_lshift n m (i : 'I_n) : fintype.split (lshift m i) = inl i. +Proof. by rewrite -/(unsplit (inl i)) unsplitK. Qed. + +Lemma split_rshift n m (i : 'I_m) : fintype.split (rshift n i) = inr i. +Proof. by rewrite -/(unsplit (inr i)) unsplitK. Qed. + +Lemma size_index_enum (T : finType) : size (index_enum T) = #|T|. +Proof. by rewrite cardT enumT. Qed. + Lemma index_enum_cast_ord n m (e : n = m) : index_enum 'I_m = [seq cast_ord e i | i <- index_enum 'I_n]. Proof. @@ -1108,3 +1182,11 @@ by move=> x _ /=; apply/eqP/eqP => [/(congr1 g) <-|->//]. Qed. End fintype_extra. + +Section order_extra. +(* eq_le would be a better name but it is already occupied: + eq_le : (x == y) = (x <= y <= x)%O *) +Lemma eqW {disp : order.Order.disp_t} {T : porderType disp} (x y : T) : + x = y -> (x <= y)%O. +Proof. by move->; exact: Order.POrderTheory.lexx. Qed. +End order_extra. diff --git a/lib/ssralg_ext.v b/lib/ssralg_ext.v index 7280d23c..5a87b3e8 100644 --- a/lib/ssralg_ext.v +++ b/lib/ssralg_ext.v @@ -1,7 +1,7 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From HB Require Import structures. -From mathcomp Require Import all_ssreflect ssralg fingroup finalg perm zmodp. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint fingroup finalg perm zmodp. From mathcomp Require Import matrix mxalgebra vector. Require Import ssr_ext f2. @@ -100,7 +100,6 @@ Lemma row_setK n A (i : 'I_n) (a : A) d : d `[i := a] ``_ i = a. Proof. by rewrite /row_set mxE eqxx. Qed. Section sub_vec_sect. - Variables (A : Type) (n : nat). Definition sub_vec (t : 'rV[A]_n) (S : {set 'I_n}) : 'rV[A]_#| S | := @@ -285,8 +284,9 @@ End row_mx_ext. Section row_mxA'. Variables (A : finType) (n : nat) (i : 'I_n.+1). -Lemma row_mxA' (w1 : 'rV_(n - i)) (a : A) (w : 'rV_i) (H1 : (n.+1 - i)%nat = (n - i)%nat.+1) - (H2 : _) (H3 : (i + 1%nat + (n - i))%nat = n.+1) : +Lemma row_mxA' (w1 : 'rV_(n - i)) (a : A) (w : 'rV_i) + (H1 : (n.+1 - i)%nat = (n - i)%nat.+1) (H2 : _) + (H3 : (i + 1%nat + (n - i))%nat = n.+1) : castmx (erefl 1%nat, H3) (row_mx (row_mx w (\row__ a)) w1) = castmx (erefl 1%nat, H2) (row_mx w (castmx (erefl 1%nat, esym H1) (row_mx (\row_(_ < 1) a) w1))). Proof. @@ -340,7 +340,7 @@ End row_mxA'. Lemma col_matrix (R : ringType) m n (A : 'I_m -> 'cV[R]_(n.+1)) (i : 'I_m) : col i (\matrix_(a < n.+1, b < m) (A b) a ord0) = A i. -Proof. apply/colP => a; by rewrite !mxE. Qed. +Proof. by apply/colP => a; rewrite !mxE. Qed. Lemma ltnS' n m : (n < m.+1)%nat -> (n <= m)%nat. Proof. by rewrite ltnS. Qed. @@ -396,7 +396,7 @@ rewrite big_pred1_eq {1}/perm_mx !mxE eqxx mul1r (eq_bigr (fun _ => 0)). by rewrite !mxE eq_sym H /= mul0r. Qed. -Lemma pid_mx_inj r n (a b : 'rV[R]_r) : r <= n -> +Lemma pid_mx_inj r n (a b : 'rV[R]_r) : (r <= n)%N -> a *m (@pid_mx _ r n r) = b *m (@pid_mx _ r n r) -> a = b. Proof. move=> Hrn /matrixP Heq. @@ -418,10 +418,11 @@ Qed. End AboutPermPid. (* NB: similar to mulmx_sum_row in matrix.v *) -Lemma mulmx_sum_col : forall {R : comRingType} m n (u : 'cV[R]_n) (A : 'M_(m, n)), +(* NB: used in hamming_code.v *) +Lemma mulmx_sum_col {R : comRingType} m n (u : 'cV[R]_n) (A : 'M_(m, n)) : A *m u = \sum_i u i 0 *: col i A. Proof. -move=> R m n u A; apply/colP=> j; rewrite mxE summxE; apply: eq_bigr => i _. +apply/colP => j; rewrite mxE summxE; apply: eq_bigr => i _. by rewrite !mxE mulrC. Qed. @@ -431,19 +432,7 @@ move=> x y; rewrite /col_perm => /matrixP xy; apply/matrixP => i j. by move: (xy i (s^-1%g j)); rewrite !mxE permKV. Qed. -Lemma trmx_cV_0 {k} (x : 'cV['F_2]_k) : (x ^T == 0) = (x == 0). -Proof. -case Hlhs : (_ ^T == _). - symmetry. - move/eqP in Hlhs. - by rewrite -(trmxK x) Hlhs trmx0 eqxx. -symmetry; apply/eqP. -move=> abs; subst x. -by rewrite trmx0 eqxx in Hlhs. -Qed. - Section AboutRank. - Variable F : fieldType. Lemma rank_I n : \rank (1%:M : 'M[F]_n) = n. @@ -471,7 +460,7 @@ Qed. Lemma empty_rV (A : ringType) (a : 'rV[A]_O) : a = 0. Proof. apply/rowP; by case. Qed. -Lemma full_rank_inj m n (A : 'M[F]_(m, n)) : m <= n -> \rank A = m -> +Lemma full_rank_inj m n (A : 'M[F]_(m, n)) : (m <= n)%N -> \rank A = m -> forall (a b : 'rV[F]_m), a *m A = b *m A -> a = b. Proof. move=> Hmn Hrank a b Hab. @@ -522,7 +511,7 @@ End non_trivial_vspace. Section about_row_vectors_on_prime_fields. Lemma card_rV_wo_zeros p n : prime p -> - (\sum_(x : 'rV['F_p]_n | [forall j, x ord0 j != 0%R]) 1)%N = p.-1 ^ n. + (\sum_(x : 'rV['F_p]_n | [forall j, x ord0 j != 0%R]) 1)%N = (p.-1 ^ n)%N. Proof. move=> primep. destruct p as [|p'] => //; destruct p' as [|p'] => //. @@ -561,8 +550,8 @@ Qed. End about_row_vectors_on_prime_fields. -Lemma sum_char2 (F : fieldType) (_ : 2%N \in [char F]) k (f : 'I_k -> F) : - (\sum_(i < k) (f i)) ^+ 2 = \sum_(i < k) (f i) ^+ 2. +Lemma sum_sqr (F : fieldType) (_ : 2%N \in [char F]) k (f : 'I_k -> F) : + (\sum_(i < k) f i) ^+ 2 = \sum_(i < k) (f i) ^+ 2. Proof. elim/big_ind2 : _ => [|x1 x2 y1 y2 <- <-|//] /=; first by rewrite expr0n. by rewrite sqrrD mulr2n addrr_char2 // addr0. @@ -581,7 +570,7 @@ Definition GF : finFieldType := sval (@PrimePowerField q m primeq isT). Lemma char_GFqm : q \in [char GF]. Proof. exact (proj1 (proj2_sig (@PrimePowerField q m primeq isT))). Qed. -Lemma card_GFqm : #| GF | = q ^ m. +Lemma card_GFqm : #| GF | = (q ^ m)%N. Proof. rewrite /GF; by case: (@PrimePowerField q m primeq isT). Qed. End GFqm. @@ -636,24 +625,22 @@ apply/setP => i; rewrite !inE !mxE; apply/idP/idP; apply: contra. by rewrite GF2_of_F2_eq0. Qed. - Section Det_mlinear. - -Variable (R: comRingType). +Context {R : comRingType}. Let det_mlinear_rec n (f : 'I_n.+1 -> 'I_n.+1 -> R) (g : 'I_n.+1 -> R) k : - k <= n.+1 -> + (k <= n.+1)%N -> \det (\matrix_(j, i) (f i j * g j)) = (\prod_(l < k) g (inord l)) * - \det (\matrix_(j, i) (f i j * if j >= k then g j else 1)). + \det (\matrix_(j, i) (f i j * if (j >= k)%N then g j else 1)). Proof. elim: k => [_|k IH]; first by rewrite big_ord0 mul1r. rewrite ltnS => kn. rewrite IH; last by rewrite ltnW. rewrite big_ord_recr /= -mulrA; congr (_ * _). rewrite (@determinant_multilinear _ _ _ - (\matrix_(j, i) (f i j * (if k < j then g j else 1))) - (\matrix_(j, i) (f i j * (if k <= j then g j else 1))) + (\matrix_(j, i) (f i j * (if (k < j)%N then g j else 1))) + (\matrix_(j, i) (f i j * (if (k <= j)%N then g j else 1))) (inord k) (g (inord k)) 0); last 3 first. - rewrite scale0r addr0. apply/rowP => j. @@ -687,3 +674,44 @@ by apply/matrixP => i j; rewrite !mxE ltnNge -ltnS ltn_ord /= mulr1. Qed. End Det_mlinear. + +Section regular_algebra. + +Lemma mulr_regl [R : ringType] (a : R) (x : R^o) : a * x = a *: x. +Proof. by []. Qed. + +Lemma mulr_regr [R : comRingType] (a : R) (x : R^o) : x * a = a *: x. +Proof. by rewrite mulrC. Qed. + +End regular_algebra. + +Section ssrnum_ext. +Import ssrnum Num.Theory. + +Lemma sqrBC (R : realDomainType) (x y : R) : (x - y) ^+ 2 = (y - x) ^+ 2. +Proof. +have:= num_real (x - y) => /real_normK <-. +by rewrite distrC real_normK // num_real. +Qed. + +Lemma ler_abs_sqr (T : realDomainType) (x y : T) : (`|x| <= `|y|) = (x ^+ 2 <= y ^+ 2). +Proof. by rewrite -[LHS]ler_sqr ?nnegrE// ?real_normK// num_real. Qed. +End ssrnum_ext. + +Section ssrint_ext. +Import ssrnum Num.Theory ssrint. + +Lemma sum_exprz {R : numFieldType} (n : nat) x : x != 1 -> + \sum_(i < n) x ^ i.+1 = x * (1 - (x ^ n)) / (1 - x) :> R. +Proof. +move=> neq_x_1. +rewrite -opprB. +rewrite subrX1. +rewrite -opprB mulNr opprK. +rewrite mulrCA mulrC !mulrA mulVf; last first. + by rewrite subr_eq0 eq_sym. +rewrite mul1r big_distrr//=. +by apply: eq_bigr => i _; rewrite exprSz. +Qed. + +End ssrint_ext. diff --git a/probability/bayes.v b/probability/bayes.v index f0d11776..5c43e663 100644 --- a/probability/bayes.v +++ b/probability/bayes.v @@ -1,10 +1,10 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. +Require Import PeanoNat. +From mathcomp Require Import all_ssreflect ssralg ssrnum matrix reals. From mathcomp Require boolp. -From mathcomp Require Import Rstruct. -Require Import Reals. (* Lra Nsatz. *) -Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext fdist proba. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext. +Require Import fdist proba. (******************************************************************************) (* wip *) @@ -26,12 +26,14 @@ Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext fdist proba. Local Open Scope tuple_ext_scope. Local Open Scope fdist_scope. Local Open Scope proba_scope. +Local Open Scope ring_scope. Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. Import Num.Theory. +Import GRing.Theory. Section fin_img. Variables (T : finType) (S : eqType) (f : T -> S). @@ -71,7 +73,7 @@ Qed. End fin_img. Section proba. (* proba.v ? *) -Variables (U : finType) (P : {fdist U}). +Variables (R : realType) (U : finType) (P : R.-fdist U). Definition fdist_choice' : U. move: (fdist_card_neq0 P). @@ -288,10 +290,9 @@ End univ_types. Module BN. Section bn. -Variables (U : finType) (P : {fdist U}) (n : nat). +Variables (R : realType) (U : finType) (P : R.-fdist U) (n : nat). Section preim. -Local Open Scope R_scope. Variable types : 'I_n -> eqType. Variable vars : forall i, {RV P -> types i}. @@ -368,9 +369,9 @@ Definition cinde_preim (e f g : {set 'I_n}) := (preim_vars f vals) (preim_vars g vals). -Lemma cinde_eventsC A (Q : fdist _ A) (E F G : {set A}) : +Lemma cinde_eventsC A (Q : R.-fdist A) (E F G : {set A}) : cinde_events Q E F G -> cinde_events Q F E G. -Proof. rewrite /cinde_events => Hef; by rewrite setIC mulRC. Qed. +Proof. by rewrite /cinde_events => Hef; rewrite setIC GRing.mulrC. Qed. Lemma cinde_preimC (e f g : {set 'I_n}) : cinde_preim e f g -> cinde_preim f e g. @@ -396,12 +397,12 @@ Qed. (* Simple version, using singletons *) -Lemma Rxx2 x : x = x * x -> x = 0 \/ x = 1. +Lemma Rxx2 (x : R) : x = x * x -> x = 0 \/ x = 1. Proof. case/boolP: (x == 0) => Hx. rewrite (eqP Hx); by left. -move/(f_equal (Rdiv ^~ x)). -rewrite divRR // /Rdiv -mulRA mulRV // mulR1 => <-; by right. +move/(f_equal (GRing.mul ^~ x^-1)). +by rewrite mulrV ?unitfE // -mulrA mulrV ?unitfE // mulr1 => <-; right. Qed. Lemma cinde_preim_ok1 (i j k : 'I_n) : @@ -428,7 +429,7 @@ split. rewrite (proj2 (cPr_eq0P _ _ _)); last first. apply/Pr_set0P => u. by rewrite !inE => /andP [] /= /eqP ->; rewrite ac. - by rewrite mul0R. + by rewrite GRing.mul0r. move=> nik c vi HG Hvals; apply: HG => //. by rewrite Hvals set_val_tl // set_val_hd. move=> vk. @@ -442,25 +443,25 @@ split. set x := (X in X = X * X). move/Rxx2 => [] Hx. rewrite -/x Hx. - rewrite (proj2 (cPr_eq0P _ _ _)) ?mul0R //. + rewrite (proj2 (cPr_eq0P _ _ _)) ?GRing.mul0r //. apply/Pr_set0P => u. by rewrite !inE => /andP [] /andP [] /= /eqP ->; rewrite ab. rewrite /cPr. - set den := (X in _ / X). + set den := (X in (_ / X)%mcR). case/boolP: (den == 0) => /eqP Hden. - by rewrite setIC Pr_domin_setI // setIC Pr_domin_setI // !div0R mul0R. - set num := (X in _ * (X / _)). + by rewrite setIC Pr_domin_setI // setIC Pr_domin_setI // !GRing.mul0r. + set num := (X in (_ * (X / _))%mcR). case/boolP: (num == 0) => /eqP Hnum. - by rewrite -setIA setIC Pr_domin_setI // Hnum !div0R mulR0. + by rewrite -setIA setIC Pr_domin_setI // Hnum !GRing.mul0r GRing.mulr0. elim Hnum. apply/Pr_set0P => u. rewrite !inE => /andP [] /= Hi Hk. move: Hx; subst x. - move/(f_equal (Rmult ^~ den)). + move/(f_equal (GRing.mul ^~ den)). move/eqP in Hden. - rewrite /cPr /Rdiv -mulRA mulVR // mulR1 mul1R. - move/(f_equal (Rminus den)). - rewrite subRR setIC -Pr_setD => /Pr_set0P/(_ u). + rewrite /cPr -mulrA mulVr ?unitfE // mulr1 mul1r. + move/(f_equal (fun x => den - x)). + rewrite subrr setIC -Pr_setD => /Pr_set0P/(_ u). by rewrite !inE (eqP Hi) Hk eq_sym ab; exact. case: (ord_eq_dec k j). move=> <- {j} ik b. @@ -470,7 +471,7 @@ split. rewrite (proj2 (cPr_eq0P _ _ _)); last first. apply/Pr_set0P => u. by rewrite !inE => /andP [] /andP [] _ /= /eqP ->; rewrite bc. - rewrite mulRC (proj2 (cPr_eq0P _ _ _)) ?mul0R //. + rewrite GRing.mulrC (proj2 (cPr_eq0P _ _ _)) ?GRing.mul0r //. by apply/Pr_set0P => u; rewrite !inE => /andP [] /= /eqP ->; rewrite bc. move=> nkj nij b HG Hvals; apply: HG => //. by rewrite Hvals set_val_tl // set_val_tl // set_val_hd. @@ -577,14 +578,15 @@ transitivity (\sum_(A : Tfin_img (prod_vars (e :\: e'))) move/subsetP/(_ i): ee'. by cases_in i. rewrite Pr_preim_vars_sub; last by apply/subsetP=> i; cases_in i. - rewrite /Rdiv big_distrl; apply eq_bigr => A _ /=. + rewrite big_distrl; apply eq_bigr => A _ /=. by rewrite -!preim_vars_inter (@preim_vars_set_vals_tl g). under eq_bigr => A _ /=. rewrite Hef (@preim_vars_set_vals_tl g) // (@preim_vars_set_vals_tl f). over. apply/setP => i; move/subsetP/(_ i): ee'; by cases_in i. rewrite -2!big_distrl /=. -congr (_ / _ * _). +rewrite [in RHS]/cPr. +congr (_ * _ * _). rewrite -preim_vars_inter. have -> : e' :|: g = (e :|: g) :\: (e :\: e'). apply/setP => i. @@ -635,7 +637,7 @@ right; rewrite /cinde_events. rewrite (proj2 (cPr_eq0P _ _ _)); last first. apply/Pr_set0P => u; rewrite !inE => Hprod; elim: Hvi. case/andP: Hprod => /andP[] /eqP <- _ /eqP <-; exact: prod_vars_inter. -rewrite (proj2 (cPr_eq0P _ _ _)) ?mul0R //. +rewrite (proj2 (cPr_eq0P _ _ _)) ?GRing.mul0r //. apply/Pr_set0P => u; rewrite !inE => Hprod; elim: Hvi. case/andP: Hprod => /eqP <- /eqP <-; exact: prod_vars_inter. Qed. @@ -652,18 +654,18 @@ Lemma cinde_events_cPr1 (i : 'I_n) : Proof. move=> vals He Hie Hif Hig Hvi. rewrite /cinde_events /cPr. -set den := (X in _ / X). +set den := (X in (_ / X)%mcR). case/boolP: (den == 0) => [/eqP|] Hden. - by rewrite setIC Pr_domin_setI // ?div0R => /esym/R1_neq_R0. + by rewrite setIC Pr_domin_setI // ?mul0r => /esym/eqP; rewrite oner_eq0. set num := Pr _ _ => Hnum. have {}Hnum : num = den. - by rewrite -[RHS]mul1R -Hnum /Rdiv -mulRA mulVR // mulR1. + by rewrite -[RHS]mul1r -Hnum -mulrA mulVf ?mulr1. rewrite -Hnum in Hden. rewrite (proj2 (Pr_set0P _ _)); last first. move=> u; rewrite !inE => /andP[] /andP[] /eqP HA /eqP HB. by rewrite -HA -HB !set_vals_prod_vars in Hvi. suff : `Pr_P[finset (prod_vars f @^-1 B) | finset (prod_vars g @^-1 C)] = 0. - by rewrite /cPr => ->; rewrite mulR0 div0R. + by rewrite /cPr => ->; rewrite GRing.mulr0 GRing.mul0r. (* prove incompatibility between B and C *) apply/cPr_eq0P/Pr_set0P => u. rewrite !inE => /andP [] /eqP HB /eqP HC. @@ -688,7 +690,8 @@ set a := map_fin_img (prod_vars ((e :&: f) :\: g)) v. rewrite (bigD1 a) //= nth_fin_imgK -Hv. rewrite /num (@preim_vars_vals _ (prod_vals (e :&: f :|: g) vals) _ vals); last by move=> j; rewrite set_vals_prod_vals_id. -rewrite -preim_vars_inter addRC => /subR_eq; rewrite subRR => /esym Hnum. +rewrite -preim_vars_inter addrC => /eqP. +rewrite -subr_eq subrr => /eqP/esym Hnum. have : Pr P (preim_vars (e :&: f :|: g) (set_vals (prod_vals (e :&: f :\: g) (set_vals B vals)) vals)) = 0. rewrite (_ : prod_vals _ _ = prod_vars (e :&: f :\: g) u); last first. @@ -696,7 +699,7 @@ have : Pr P (preim_vars (e :&: f :|: g) rewrite -HB set_vals_prod_vars ?ffunE //. move: Hk; cases_in k. rewrite -(@nth_fin_imgK U). - move/psumr_eq0P: Hnum; apply; first by move => *; exact/RleP. + move/psumr_eq0P: Hnum; apply; first by move=> /= *; exact: Pr_ge0. apply/eqP => /(f_equal (fun x => nth_fin_img x)). rewrite !nth_fin_imgK => /(prod_types_app i) /prod_vals_eqP Hi. elim: Hvi; rewrite -He //. @@ -761,7 +764,7 @@ split. move/cPr_eq0P/Pr_set0P => Hx. have HAC : Pr P (finset (prod_vars e @^-1 A) :&: finset (prod_vars g @^-1 C)) = 0. - apply Pr_set0P => u Hu; apply Hx. + apply/Pr_set0P => u Hu; apply Hx. rewrite -preim_vars_inter; apply/preim_varsP => j. move: Hu; rewrite !inE. rewrite /vals => /andP[] /eqP <- /eqP <-. @@ -770,7 +773,7 @@ split. case/boolP: (j \in e) => // je. by rewrite set_vals_tl // set_vals_prod_vars. rewrite /cinde_events (proj2 (cPr_eq0P _ _ _)). - by rewrite (proj2 (cPr_eq0P _ _ _)) // mul0R. + by rewrite (proj2 (cPr_eq0P _ _ _)) // GRing.mul0r. apply/Pr_set0P => u Hu. apply(proj1 (Pr_set0P _ _) HAC). move: Hu; by rewrite !inE => /andP[] /andP[] -> _ ->. @@ -850,7 +853,7 @@ End BN. Section Factorization. Import BN. -Variables (U : finType) (P : {fdist U}) (n : nat). +Variables (R : realType) (U : finType) (P : R.-fdist U) (n : nat). Variable types : 'I_n -> finType. Variable vars : forall i, {RV P -> types i}. Variable bn : t vars. diff --git a/probability/convex.v b/probability/convex.v index 0f12e956..234ae0b7 100644 --- a/probability/convex.v +++ b/probability/convex.v @@ -2,17 +2,12 @@ (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From HB Require Import structures. From mathcomp Require Import all_ssreflect ssralg fingroup perm matrix. -From mathcomp Require Import mathcomp_extra boolp classical_sets Rstruct. -From mathcomp Require Import ssrnum archimedean ereal. -From mathcomp Require Import lra Rstruct reals. -Require Import Reals. -Require Import ssrR Reals_ext Ranalysis_ext ssr_ext ssralg_ext logb. -Require Import realType_ext fdist. +From mathcomp Require Import mathcomp_extra boolp classical_sets. +From mathcomp Require Import ssrnum archimedean ereal signed. +From mathcomp Require Import lra reals. +Require Import ssr_ext ssralg_ext realType_ext realType_ln fdist. From mathcomp Require vector. -Undelimit Scope R_scope. -Delimit Scope R_scope with coqR. - (******************************************************************************) (* Convexity *) (* *) @@ -98,7 +93,6 @@ Delimit Scope R_scope with coqR. (* Lemma second_derivative_convexf_pt == twice derivable is convex *) (******************************************************************************) -Reserved Notation "x <| p |> y" (format "x <| p |> y", at level 49). Reserved Notation "{ 'convex_set' T }" (format "{ 'convex_set' T }"). Reserved Notation "'<|>_' d f" (at level 36, f at level 36, d at level 0, format "<|>_ d f"). @@ -142,32 +136,32 @@ Import Order.POrderTheory GRing.Theory Num.Theory. Local Notation "{ 'fdist' T }" := (_ .-fdist T) : fdist_scope. -#[export] Hint Extern 0 (0 <= _)%coqR => - solve [apply/RleP/(FDist.ge0 _)] : core. -#[export] Hint Extern 0 (_ <= 1)%coqR => - solve [apply/RleP/(FDist.le1 _)] : core. -#[export] Hint Extern 0 (0 <= Prob.p _)%coqR => - solve [apply/RleP/(prob_ge0 _)] : core. -#[export] Hint Extern 0 (Prob.p _ <= 1)%coqR => - solve [apply/RleP/(prob_le1 _)] : core. - -#[export] Hint Extern 0 (onem _ <= 1)%coqR => - exact/RleP/onem_le1 : core. -#[export] Hint Extern 0 (0 <= onem _)%coqR => - exact/RleP/onem_ge0 : core. - -Fixpoint Convn (A : Type) (f : {prob R} -> A -> A -> A) n : {fdist 'I_n} -> ('I_n -> A) -> A := +#[export] Hint Extern 0 (0 <= _)%R => + solve [apply/(FDist.ge0 _)] : core. +#[export] Hint Extern 0 (_ <= 1)%R => + solve [apply/(FDist.le1 _)] : core. +#[export] Hint Extern 0 (0 <= Prob.p _)%R => + solve [apply/(prob_ge0 _)] : core. +#[export] Hint Extern 0 (Prob.p _ <= 1)%R => + solve [apply/(prob_le1 _)] : core. + +#[export] Hint Extern 0 (onem _ <= 1)%R => + exact/onem_le1 : core. +#[export] Hint Extern 0 (0 <= onem _)%R => + exact/onem_ge0 : core. + +Fixpoint Convn {R : realType} (A : Type) (f : {prob R} -> A -> A -> A) n : {fdist 'I_n} -> ('I_n -> A) -> A := match n return forall (e : {fdist 'I_n}) (g : 'I_n -> A), A with | O => fun e g => False_rect A (fdistI0_False e) | m.+1 => fun e g => - match Bool.bool_dec (e ord0 == 1%coqR) true with + match Bool.bool_dec (e ord0 == 1%R) true with | left _ => g ord0 | right H => let G := fun i => g (fdist_del_idx ord0 i) in f (probfdist e ord0) (g ord0) (Convn f (fdist_del (Bool.eq_true_not_negb _ H)) G) end end. -HB.mixin Record isConvexSpace0 T of Choice T := { +HB.mixin Record isConvexSpace0 {R : realType} T of Choice T := { conv : {prob R} -> T -> T -> T ; convn : forall n, {fdist 'I_n} -> ('I_n -> T) -> T ; convnE : forall n d g, convn n d g = Convn conv d g ; @@ -179,16 +173,16 @@ HB.mixin Record isConvexSpace0 T of Choice T := { #[short(type=convType)] -HB.structure Definition ConvexSpace := {T of isConvexSpace0 T & }. -Arguments convn {s n}. +HB.structure Definition ConvexSpace {R : realType} := {T of isConvexSpace0 R T & }. +Arguments convn {R s n}. Notation "a <| p |> b" := (conv p a b) : convex_scope. Local Open Scope convex_scope. Section convex_space_lemmas. -Variables A : convType. +Context {R : realType}. +Variables A : convType R. Implicit Types a b : A. -Import Reals_ext. Lemma conv0 a b : a <| 0%:pr |> b = b. Proof. @@ -203,7 +197,7 @@ rewrite convnE {1}/Convn. case: Bool.bool_dec => [/eqP|/Bool.eq_true_not_negb b01]. rewrite fdist1E; case j0 : (_ == _) => /=. by move=> _; rewrite (eqP j0). - by move/eqP; rewrite eq_sym R1E oner_eq0. + by move/eqP; rewrite eq_sym oner_eq0. rewrite (_ : probfdist _ _ = 0%:pr) ?conv0; last first. apply val_inj => /=; move: b01; rewrite !fdist1E => j0. by case j0' : (_ == _) => //; rewrite j0' eqxx in j0. @@ -215,17 +209,17 @@ rewrite (_ : fdist_del b01 = fdist1 j'); last first. apply/fdist_ext => /= k. rewrite fdist_delE fdistD1E /= !fdist1E /= (negbTE j0) subr0 divr1. congr (GRing.natmul _ (nat_of_bool _)). - move R : (k == _) => [|]. + move Hk : (k == _) => [|]. - apply/eqP/val_inj; rewrite /= /bump leq0n add1n. - by move/eqP : R => -> /=; rewrite prednK // lt0n. - - apply: contraFF R => /eqP. + by move/eqP : Hk => -> /=; rewrite prednK // lt0n. + - apply: contraFF Hk => /eqP. move/(congr1 val) => /=; rewrite /bump leq0n add1n => kj. by apply/eqP/val_inj; rewrite /= -kj. rewrite -/(Convn _ _) -convnE IH /fdist_del_idx ltn0; congr g. by apply val_inj; rewrite /= /bump leq0n add1n prednK // lt0n. Qed. -Let ConvnIE n (g : 'I_n.+1 -> A) (d : {fdist 'I_n.+1}) (i1 : d ord0 != 1%coqR) : +Let ConvnIE n (g : 'I_n.+1 -> A) (d : {fdist 'I_n.+1}) (i1 : d ord0 != 1%R) : convn d g = (g ord0) <| probfdist d ord0 |> (convn (fdist_del i1) (fun x => g (fdist_del_idx ord0 x))). Proof. @@ -244,7 +238,7 @@ Qed. Let ConvnI2E (g : 'I_2 -> A) (d : {fdist 'I_2}) : convn d g = (g ord0) <| probfdist d ord0 |> (g (lift ord0 ord0)). Proof. -have [/eqP|i1] := eqVneq (d ord0) 1%coqR. +have [/eqP|i1] := eqVneq (d ord0) 1%R. rewrite fdist1E1 => /eqP ->; rewrite Convn_fdist1. rewrite (_ : probfdist _ _ = 1%:pr) ?conv1 //. by apply val_inj; rewrite /= fdist1xx. @@ -256,7 +250,8 @@ End convex_space_lemmas. Section segment. -Variable A : convType. +Context {R : realType}. +Variable A : convType R. Definition segment (x y : A) : set A := (fun p => conv p x y) @` [set: {prob R}]. Lemma segment_sym u v : (segment u v `<=` segment v u)%classic. @@ -272,26 +267,27 @@ Lemma segmentR x y : segment x y y. Proof. by exists 0%:pr; rewrite ?conv0. Qed. End segment. -Definition affine (U V : convType) (f : U -> V) := +Definition affine {R : realType} (U V : convType R) (f : U -> V) := forall p, {morph f : a b / a <| p |> b >-> a <| p |> b}. -HB.mixin Record isAffine (U V : convType) (f : U -> V) := { +HB.mixin Record isAffine {R : realType} (U V : convType R) (f : U -> V) := { affine_conv : affine f }. -HB.structure Definition Affine (U V : convType) := {f of isAffine U V f}. +HB.structure Definition Affine {R : realType} (U V : convType R) := {f of isAffine R U V f}. Notation "{ 'affine' T '->' R }" := (Affine.type T R) : convex_scope. Section affine_function_instances. -Variables (U V W : convType) (f : {affine V -> W}) (h : {affine U -> V}). +Context {R : realType}. +Variables (U V W : convType R) (f : {affine V -> W}) (h : {affine U -> V}). Let affine_idfun : affine (@idfun U). Proof. by []. Qed. -HB.instance Definition _ := isAffine.Build _ _ idfun affine_idfun. +HB.instance Definition _ := isAffine.Build _ _ _ idfun affine_idfun. Let affine_comp : affine (f \o h). Proof. by move=> x y t /=; rewrite 2!affine_conv. Qed. -HB.instance Definition _ := isAffine.Build _ _ (f \o h) affine_comp. +HB.instance Definition _ := isAffine.Build _ _ _ (f \o h) affine_comp. End affine_function_instances. @@ -299,7 +295,9 @@ Declare Scope scaled_scope. Delimit Scope scaled_scope with scaled. Section scaled. +Context {R : realType}. Variable A : Type. +Local Open Scope ring_scope. (* Note: we need the argument of Scaled to be an Rpos, because otherwise addpt cannot make a commutative monoid: @@ -310,14 +308,14 @@ Variable A : Type. addpt (Scaled 0 x) (addpt (Scaled 0 y) (Scaled 0 z)) = Scaled 0 x addpt (addpt (Scaled 0 x) (Scaled 0 y)) (Scaled 0 z) = Scaled 0 z So we cannot allow 0 as argument to Scaled. *) -Inductive scaled := Scaled of Rpos & A | Zero. +Inductive scaled := Scaled of {posnum R} & A | Zero. -Definition sum_of_scaled (m : scaled) : Rpos * A + unit := +Definition sum_of_scaled (m : scaled) : {posnum R} * A + unit := match m with Scaled r a => inl _ (r, a) | Zero => inr _ tt end. Local Notation "p *: a" := (Scaled p a). -Definition scaled_of_sum (m : (Rpos * A) + unit) := +Definition scaled_of_sum (m : ({posnum R} * A) + unit) := match m with inl p => p.1 *: p.2 | inr n => Zero end. Lemma sum_of_scaledK : cancel sum_of_scaled scaled_of_sum. @@ -328,53 +326,62 @@ Definition S1 a : scaled := 1%:pos *: a. Lemma Scaled_inj p : injective (Scaled p). Proof. by move=> x y []. Qed. -Definition S1_inj : injective S1 := @Scaled_inj Rpos1. +Definition S1_inj : injective S1 := @Scaled_inj 1%:pos. -Definition raw_weight (pt : scaled) : R := if pt is r *: _ then r else 0. +Definition raw_weight (pt : scaled) : R := if pt is r *: _ then r%:num else 0. -Lemma weight_ge0 pt : (0 <= raw_weight pt)%coqR. -Proof. by case: pt => /= [[x] /= /RltP/ltRW //|]. Qed. +Lemma weight_ge0 pt : (0 <= raw_weight pt)%R. +Proof. by case: pt => //= [[x] /= /ltW|]. Qed. -Definition weight := mkNNFun weight_ge0. +(*Definition weight := mkNNFun weight_ge0.*) -Definition point pt : (weight pt > 0)%coqR -> A := +Program Definition point pt : (raw_weight pt > 0)%R -> A := match pt with | t *: a => fun=> a - | Zero => fun H : (weight Zero > 0)%coqR => match ltRR 0 H with end + | Zero => fun H : (raw_weight Zero > 0)%R => _ end. +Next Obligation. +move=> _ _/=. +by rewrite ltxx. +Defined. Lemma point_Scaled p x H : @point (p *: x) H = x. Proof. by []. Qed. -Lemma Scaled_point x H : mkRpos H *: @point x H = x. +Lemma Scaled_point x H : PosNum H *: @point x H = x. Proof. -by case: x H => [p x|] H; [congr (_ *: _); apply val_inj | case: (ltRR 0)]. +case: x H => [p x|] /= H; [congr (_ *: _); exact: val_inj|]. +exfalso. +by rewrite ltxx in H. Qed. End scaled. -Arguments Zero {A}. -Arguments point {A} pt. -Arguments weight {A}. +Arguments Zero {R A}. +Arguments point {R A} pt. +Arguments raw_weight {R A}. Notation "p *: a" := (Scaled p a) : scaled_scope. -HB.instance Definition _ (A : eqType) := Equality.copy (scaled A) (can_type (@sum_of_scaledK A)). -HB.instance Definition _ (A : choiceType) := Choice.copy (scaled A) (can_type (@sum_of_scaledK A)). +HB.instance Definition _ {R : realType} (A : eqType) := + Equality.copy (scaled A) (can_type (@sum_of_scaledK R A)). +HB.instance Definition _ {R : realType} (A : choiceType) := + Choice.copy (scaled A) (can_type (@sum_of_scaledK R A)). Section scaled_eqType. +Context {R : realType}. Variable A : eqType. -Lemma S1_neq0 a : S1 a != @Zero A. Proof. by []. Qed. +Lemma S1_neq0 a : S1 a != @Zero R A. Proof. by []. Qed. (* NB: should go away once we do not need coqR anymore *) -Lemma weight_gt0 a : a != @Zero A -> (0 < weight a)%coqR. +Lemma weight_gt0 a : a != @Zero R A -> (0 < raw_weight a)%R. Proof. by case: a => // p x _ /=. Qed. -Lemma weight_gt0b a : a != @Zero A -> (weight a > 0)%mcR. -Proof. by move=> ?; exact/RltP/weight_gt0. Qed. +Lemma weight_gt0b a : a != @Zero R A -> (raw_weight a > 0)%R. +Proof. by move=> ?; exact/weight_gt0. Qed. -Definition weight_neq0 a (a0 : a != @Zero A) := Rpos.mk (weight_gt0b a0). +Definition weight_neq0 a (a0 : a != @Zero R A) := PosNum (weight_gt0b a0). -Local Notation "[ 'point' 'of' x ]" := (@point _ _ (@weight_gt0 _ x)) +Local Notation "[ 'point' 'of' x ]" := (@point _ _ _ (@weight_gt0 _ x)) (at level 0, format "[ 'point' 'of' x ]"). Local Notation "[ 'weight' 'of' x ]" := (weight_neq0 x) (at level 0, format "[ 'weight' 'of' x ]"). @@ -382,54 +389,61 @@ Local Notation "[ 'weight' 'of' x ]" := (weight_neq0 x) Lemma point_S1 a : [point of S1_neq0 a] = a. Proof. by []. Qed. -Lemma weight0_Zero a : weight a = 0%coqR -> a = @Zero A. -Proof. by case: a => //= r c /esym Hr; move/ltR_eqF: (Rpos_gt0 r) => /eqP. Qed. +Lemma weight0_Zero a : raw_weight a = 0%R -> a = @Zero R A. +Proof. +case: a => //= r c rc. +exfalso. +have /= := gt0 r. +rewrite rc// ltxx falseE. +exact. +Qed. End scaled_eqType. -Notation "[ 'point' 'of' x ]" := (@point _ _ (@weight_gt0 _ _ x)) +Notation "[ 'point' 'of' x ]" := (@point _ _ _ (@weight_gt0 _ _ _ x)) (at level 0, format "[ 'point' 'of' x ]"). Notation "[ 'weight' 'of' x ]" := (weight_neq0 x) (at level 0, format "[ 'weight' 'of' x ]"). -HB.mixin Record isQuasiRealCone A of Choice A := { +HB.mixin Record isQuasiRealCone {R : realType} A of Choice A := { addpt : A -> A -> A ; zero : A ; addptC : commutative addpt ; addptA : associative addpt ; addpt0 : right_id zero addpt ; scalept : R -> A -> A ; - scale0pt : forall x, scalept 0%coqR x = zero ; - scale1pt : forall x, scalept 1%coqR x = x ; + scale0pt : forall x, scalept 0%R x = zero ; + scale1pt : forall x, scalept 1%R x = x ; scaleptDr : forall r, {morph scalept r : x y / addpt x y >-> addpt x y} ; - scaleptA : forall p q x, (0 <= p)%coqR -> (0 <= q)%coqR -> - scalept p (scalept q x) = scalept (p * q)%coqR x }. + scaleptA : forall p q x, (0 <= p)%R -> (0 <= q)%R -> + scalept p (scalept q x) = scalept (p * q)%R x }. #[short(type=quasiRealCone)] -HB.structure Definition QuasiRealCone := { A of isQuasiRealCone A & }. +HB.structure Definition QuasiRealCone {R : realType} := { A of isQuasiRealCone R A & }. Section quasireal_cone_theory. -Variable A : quasiRealCone. +Context {R : realType}. +Variable A : quasiRealCone R. -Lemma add0pt : left_id (@zero A) addpt. +Lemma add0pt : left_id (@zero R A) addpt. Proof. by move=> ?; rewrite addptC addpt0. Qed. -Lemma scalept0 p : (0 <= p)%coqR -> scalept p zero = @zero A. +Lemma scalept0 p : (0 <= p)%R -> scalept p zero = @zero R A. Proof. -by move=> p0; rewrite -[in LHS](scale0pt zero) scaleptA// mulR0 scale0pt. +by move=> p0; rewrite -[in LHS](scale0pt zero) scaleptA// mulr0 scale0pt. Qed. HB.instance Definition _ := - Monoid.isComLaw.Build A (@zero A) (@addpt A) addptA addptC add0pt. + Monoid.isComLaw.Build A (@zero R A) (@addpt R A) addptA addptC add0pt. Definition big_morph_scalept q := - @big_morph _ _ (@scalept A q) zero addpt zero _ (@scaleptDr A q). + @big_morph _ _ (@scalept R A q) zero addpt zero _ (@scaleptDr R A q). -Local Notation "\ssum_ ( i <- r ) F" := (\big[addpt/@zero A]_(i <- r) F). -Local Notation "\ssum_ ( i : t ) F" := (\big[addpt/@zero A]_(i : t) F) (only parsing). -Local Notation "\ssum_ i F" := (\big[addpt/@zero A]_i F). -Local Notation "\ssum_ ( i | P ) F" := (\big[addpt/@zero A]_(i | P) F). -Local Notation "\ssum_ ( i < n | P ) F" := (\big[addpt/@zero A]_(i < n | P%B) F). -Local Notation "\ssum_ ( i < n ) F" := (\big[addpt/@zero A]_(i < n) F). +Local Notation "\ssum_ ( i <- r ) F" := (\big[addpt/@zero R A]_(i <- r) F). +Local Notation "\ssum_ ( i : t ) F" := (\big[addpt/@zero R A]_(i : t) F) (only parsing). +Local Notation "\ssum_ i F" := (\big[addpt/@zero R A]_i F). +Local Notation "\ssum_ ( i | P ) F" := (\big[addpt/@zero R A]_(i | P) F). +Local Notation "\ssum_ ( i < n | P ) F" := (\big[addpt/@zero R A]_(i < n | P%B) F). +Local Notation "\ssum_ ( i < n ) F" := (\big[addpt/@zero R A]_(i < n) F). Definition barycenter (pts : seq A) := \ssum_(x <- pts) x. @@ -437,7 +451,7 @@ Lemma barycenter_map (T : finType) (F : T -> A) : barycenter [seq F i | i <- enum T] = \ssum_i F i. Proof. by rewrite /barycenter big_map big_filter. Qed. -Lemma scalept_barycenter p (H : (0 <= p)%coqR) pts : +Lemma scalept_barycenter p (H : (0 <= p)%R) pts : scalept p (barycenter pts) = barycenter [seq scalept p i | i <- pts]. Proof. by rewrite big_morph_scalept ?scalept0// /barycenter big_map. Qed. @@ -449,34 +463,36 @@ exact/perm_big/perm_eq_perm. Qed. End quasireal_cone_theory. -Notation "\ssum_ ( i <- r ) F" := (\big[addpt/@zero _]_(i <- r) F). -Notation "\ssum_ ( i <- r | P ) F" := (\big[addpt/@zero _]_(i <- r | P ) F). -Notation "\ssum_ ( i : t ) F" := (\big[addpt/@zero _]_(i : t) F) (only parsing). -Notation "\ssum_ i F" := (\big[addpt/@zero _]_i F). -Notation "\ssum_ ( i | P ) F" := (\big[addpt/@zero _]_(i | P) F). -Notation "\ssum_ ( i < n | P ) F" := (\big[addpt/@zero _]_(i < n | P%B) F). -Notation "\ssum_ ( i < n ) F" := (\big[addpt/@zero _]_(i < n) F). - -HB.mixin Record isRealCone A of QuasiRealCone A := { - scaleptDl : forall (p q : R) (x : A), (0 <= p)%coqR -> (0 <= q)%coqR -> - scalept (p + q)%coqR x = addpt (scalept p x) (scalept q x) +Notation "\ssum_ ( i <- r ) F" := (\big[addpt/@zero _ _]_(i <- r) F). +Notation "\ssum_ ( i <- r | P ) F" := (\big[addpt/@zero _ _]_(i <- r | P ) F). +Notation "\ssum_ ( i : t ) F" := (\big[addpt/@zero _ _]_(i : t) F) (only parsing). +Notation "\ssum_ i F" := (\big[addpt/@zero _ _]_i F). +Notation "\ssum_ ( i | P ) F" := (\big[addpt/@zero _ _]_(i | P) F). +Notation "\ssum_ ( i < n | P ) F" := (\big[addpt/@zero _ _]_(i < n | P%B) F). +Notation "\ssum_ ( i < n ) F" := (\big[addpt/@zero _ _]_(i < n) F). + +HB.mixin Record isRealCone {R : realType} A of QuasiRealCone R A := { + scaleptDl : forall (p q : R) (x : A), (0 <= p)%R -> (0 <= q)%R -> + scalept (p + q)%R x = addpt (scalept p x) (scalept q x) }. #[short(type=realCone)] -HB.structure Definition RealCone := { A of isRealCone A & }. +HB.structure Definition RealCone {R : realType} := { A of isRealCone R A & }. Section real_cone_theory. -Variable A : realCone. +Context {R : realType}. +Variable A : realCone R. -Lemma scalept_sum (B : finType) (P : pred B) (F : B ->R^+) (x : A) : +Lemma scalept_sum (B : finType) (P : pred B) (F : B -> R) (x : A) : + (forall b, 0 <= F b)%R -> scalept (\sum_(i | P i) F i) x = \ssum_(b | P b) scalept (F b) x. Proof. -apply: (@proj1 _ (0 <= \sum_(i | P i) F i))%coqR. -apply: (big_ind2 (fun y q => scalept q x = y /\ (0 <= q)))%coqR. -+ by split; [rewrite scale0pt//|exact/Rle_refl]. +move=> F0; apply: (@proj1 _ (0 <= \sum_(i | P i) F i))%R. +apply: (big_ind2 (fun y q => scalept q x = y /\ (0 <= q)))%R. ++ by split; [rewrite scale0pt//|]. + move=> _ x2 _ y2 [<- ?] [<- ?]. - by rewrite scaleptDl //; split => //; exact: addR_ge0. -+ by move=> i _; split => //; exact/nneg_f_ge0. + by rewrite scaleptDl //; split => //; exact: addr_ge0. ++ by move=> i _; split => //; exact/F0. Qed. Section barycenter_fdist_convn. @@ -493,8 +509,8 @@ Proof. transitivity (\ssum_i \ssum_(i0 <- enum B) scalept (p i) (scalept (q i i0) (h i0))). by apply eq_bigr => i _; rewrite big_morph_scalept// scalept0. rewrite exchange_big /=; apply eq_bigr => j _; rewrite fdist_convnE. -have HF i : (0 <= p i * q i j)%coqR by exact/mulR_ge0. -rewrite (scalept_sum _ (mkNNFun HF)) /=; apply eq_bigr => i _. +have HF i : (0 <= p i * q i j)%R by exact/mulr_ge0. +rewrite scalept_sum//; apply eq_bigr => i _. by rewrite scaleptA. Qed. @@ -502,102 +518,169 @@ End barycenter_fdist_convn. End real_cone_theory. +From mathcomp Require Import ring. + +(* TODO: move *) +Lemma oprob_divrposxxy {R : realType} (x y : {posnum R}%R) : + (0 < x%:num / (x%:num + y%:num) < 1)%R. +Proof. +rewrite divr_gt0//=. +by rewrite ltr_pdivrMr// mul1r ltrDl. +Qed. + +Lemma prob_divrposxxy {R : realType} (x y : {posnum R}%R) : + (0 <= x%:num / (x%:num + y%:num) <= 1)%R. +Proof. +have /andP[] := oprob_divrposxxy x y. +by move/ltW => -> /ltW ->. +Qed. + +Canonical divrposxxy {R : realType} (x y : {posnum R}%R) := + Eval hnf in Prob.mk (prob_divrposxxy x y). + +Lemma s_of_rpos_probA {R : realType} (p q r : {posnum R}%R) : + [s_of divrposxxy p ((q%:num + r%:num)%E%:pos)%R, divrposxxy q r] = + divrposxxy (p%:num + q%:num)%:pos%R r. +Proof. +apply val_inj; rewrite /= s_of_pqE. +rewrite onemM !onemK/=. +field. +by apply/andP; split => //. +Qed. + +Lemma r_of_rpos_probA {R : realType} (p q r : {posnum R}%R) : + [r_of divrposxxy p (q%:num + r%:num)%:pos%R, divrposxxy q r] = + divrposxxy p q%R. +Proof. +apply/val_inj; rewrite /= r_of_pqE s_of_pqE /onem /=. +field. +apply/and4P; split => //. +rewrite (addrC p%:num (q%:num + r%:num)%:pos%:num)%R addrK {4}[in (q%:num + r%:num)%R]addrC addrK. +by rewrite mulrC -mulrBr (addrC _ p%:num%R) addrA addrK mulf_neq0//. +Qed. + +Lemma onem_divrxxy {R : realType} (r q : {posnum R}%R) : + (r%:num / (r%:num + q%:num)).~ = (q%:num / (q%:num + r%:num))%R. +Proof. +rewrite /onem; apply/eqP; rewrite subr_eq. +by rewrite (addrC (r%:num%R : R)) -mulrDl divff. +Qed. + Section real_cone_instance. +Context {R : realType}. Import Order.TotalTheory. -Variable A : convType. +Variable A : convType R. Local Open Scope R_scope. Local Open Scope convex_scope. Local Open Scope scaled_scope. Let addpt (a b : scaled A) := match a, b with - | r *: x, q *: y => (r + q)%:pos *: (x <| (((r / (r + q))%:pos))%:pr |> y) + | r *: x, q *: y => (r%:num + q%:num)%:pos%R + *: (x <| (*((r%:num / (r%:num + q%:num))%R%:pr : {prob R})*) divrposxxy r q |> y) | _, Zero => a | Zero, _ => b end. Let addptC' : commutative addpt. Proof. -move=> [r x|] [q y|] //=; congr (_ *: _); first by apply: val_inj; rewrite /= addRC. +move=> [r x|] [q y|] //=; congr (_ *: _); first by apply: val_inj; rewrite /= addrC. rewrite convC; congr (_ <| _ |> _); apply/val_inj => /=. -by rewrite RdivE RplusE onem_divRxxy. +by rewrite onem_divrxxy. Qed. Let addptA' : associative addpt. Proof. -move=> [p x|] [q y|] [r z|] //=; congr (_ *: _); first by apply val_inj; rewrite /= addRA. -rewrite convA; congr (_<| _ |> _); first exact: s_of_Rpos_probA. +move=> [p x|] [q y|] [r z|] //=; congr (_ *: _); first by apply val_inj; rewrite /= addrA. +rewrite convA; congr (_<| _ |> _). + by rewrite s_of_rpos_probA. congr (_ <| _ |> _). rewrite /=. -exact: r_of_Rpos_probA. (* TODO: clean *) +exact: r_of_rpos_probA. (* TODO: clean *) Qed. -Let addpt0 : right_id (@Zero A) addpt. Proof. by case. Qed. +Let addpt0 : right_id (@Zero R A) addpt. Proof. by case. Qed. -Let add0pt : left_id (@Zero A) addpt. Proof. by case. Qed. +Let add0pt : left_id (@Zero R A) addpt. Proof. by case. Qed. -Let scalept p (x : scaled A) := - match Rlt_dec 0 p, x with - | left Hr, q *: y => (mkRpos Hr * q)%:pos *: y +Let scalept (p : R) (x : scaled A) := + match pselect (0 < p)%R, x with + | left Hr, q *: y => ((PosNum Hr)%:num * q%:num)%:pos%R *: y | _, _ => Zero end. Let scale0pt x : scalept 0 x = Zero. -Proof. by rewrite /scalept; case: Rlt_dec => // Hr; case: (ltRR 0). Qed. +Proof. +rewrite /scalept/=. +case: pselect => // Hr; exfalso. +by rewrite ltxx in Hr. +Qed. Let scalept0 p : scalept p Zero = Zero. -Proof. by rewrite /scalept; case: Rlt_dec. Qed. +Proof. +rewrite /scalept. +by case: pselect => //. +Qed. Let scale1pt x : scalept 1 x = x. Proof. case: x => [r c|]; last by rewrite scalept0. -by rewrite /scalept/=; case: Rlt_dec => //= ?; congr (_ *: _); apply/val_inj => /=; rewrite mul1R. +rewrite /scalept/=; case: pselect => //= ?. +by congr (_ *: _); apply/val_inj => /=; rewrite mul1r. Qed. Let scaleptDr r : {morph scalept r : x y / addpt x y >-> addpt x y}. Proof. -rewrite /scalept; case: Rlt_dec => // r_gt0 x y. +rewrite /scalept; case: pselect => // r_gt0 x y. case: x => [p x|]; last by rewrite !add0pt. case: y => [q y|]; last by rewrite !addpt0. -congr (_ *: _); first by apply val_inj => /=; rewrite mulRDr. -congr (_ <| _ |> _); apply val_inj; rewrite /= -mulRDr divRM ?gtR_eqF//. -by rewrite /Rdiv -(mulRAC r) mulRV ?mul1R // gtR_eqF. +congr (_ *: _); first by apply val_inj => /=; rewrite mulrDr. +congr (_ <| _ |> _); apply val_inj; rewrite /= -mulrDr invfM//. +by rewrite mulrACA divff ?gt_eqF// mul1r. Qed. -Let scalept_gt0 p (q : Rpos) x (p_gt0 : 0 < p) : - scalept p (q *: x) = (mkRpos p_gt0 * q)%:pos *: x. +Let scalept_gt0 (p : R) (q : {posnum R}%R) x (p_gt0 : (0 < p)%R) : + scalept p (q *: x) = ((PosNum p_gt0)%:num * q%:num)%:pos%R *: x. Proof. -by rewrite /scalept; case: Rlt_dec => // Hr; congr (_ *: _); exact/val_inj. +rewrite /scalept. +case: pselect => // p0. +by congr (_ *: _); exact/val_inj. Qed. -Let scaleptA p q x : 0 <= p -> 0 <= q -> scalept p (scalept q x) = scalept (p * q) x. +Let scaleptA (p q : R) x : (0 <= p)%R -> (0 <= q)%R -> + scalept p (scalept q x) = scalept (p * q)%R x. Proof. -case=> Hp; last by rewrite -Hp mul0R !scale0pt. -case=> Hq; last by rewrite -Hq mulR0 scale0pt scalept0. -case: x => [r x|]; rewrite ?scalept0 // !scalept_gt0; first exact: mulR_gt0. -by move=> Hpq; congr (_ *: _); apply val_inj => /=; rewrite mulRA. +rewrite le_eqVlt => /predU1P[<-|p0]. + by rewrite mul0r !scale0pt. +rewrite le_eqVlt => /predU1P[<-|q0]. + by rewrite mulr0 scale0pt scalept0. +case: x => [r x|]; rewrite ?scalept0 // !scalept_gt0; first exact: mulr_gt0. +by move=> Hpq; congr (_ *: _); apply val_inj => /=; rewrite mulrA. Qed. HB.instance Definition _ := - isQuasiRealCone.Build (scaled A) addptC' addptA' addpt0 scale0pt scale1pt scaleptDr scaleptA. + isQuasiRealCone.Build R (scaled A) addptC' addptA' addpt0 scale0pt scale1pt scaleptDr scaleptA. -Let scaleptDl p q x : 0 <= p -> 0 <= q -> +Let scaleptDl (p q : R) x : (0 <= p)%R -> (0 <= q)%R -> scalept (p + q) x = addpt (scalept p x) (scalept q x). Proof. -case=> p0; last by rewrite -p0 scale0pt add0R add0pt. -case=> q0; last by rewrite -q0 scale0pt addR0 addpt0. +rewrite le_eqVlt => /predU1P[<-|p0]. + by rewrite scale0pt add0r add0pt. +rewrite le_eqVlt => /predU1P[<-|q0]. + by rewrite scale0pt addr0 addpt0. case: x => [r c|]; last by rewrite !scalept0. -rewrite !scalept_gt0 => [|pq0 /=]; first by apply addR_gt0. -by rewrite convmm; congr (_ *: _); apply val_inj; rewrite /= mulRDl. +rewrite !scalept_gt0 => [|pq0 /=]; first by apply addr_gt0. +by rewrite convmm; congr (_ *: _); apply val_inj; rewrite /= mulrDl. Qed. -HB.instance Definition _ := @isRealCone.Build (scaled A) scaleptDl. +HB.instance Definition _ := @isRealCone.Build R (scaled A) scaleptDl. End real_cone_instance. Section convpt_convex_space. -Variable A : convType. +Context {R : realType}. +Variable A : convType R. Let convpt (p : {prob R}) (x y : scaled A) := addpt (scalept (Prob.p p) x) (scalept (Prob.p p).~ y). @@ -608,7 +691,7 @@ Proof. by rewrite /convpt onem1 scale1pt scale0pt addpt0. Qed. Let convptmm (p : {prob R}) a : convpt p a a = a. Proof. rewrite /convpt -scaleptDl//. -by rewrite RplusE onemKC scale1pt //. +by rewrite onemKC scale1pt //. Qed. Let convptC (p : {prob R}) a b : convpt p a b = convpt ((Prob.p p).~)%:pr b a. @@ -620,114 +703,122 @@ Proof. rewrite /convpt. rewrite !scaleptDr !scaleptA //. rewrite -[RHS]addptA; congr addpt. - by rewrite (p_is_rs p q) mulRC. -rewrite RmultE pq_is_rs mulrC -RmultE. -by rewrite s_of_pqE onemK RmultE. + by rewrite (p_is_rs p q) mulrC. +rewrite pq_is_rs mulrC. +by rewrite s_of_pqE onemK. Qed. Let convn := Convn convpt. HB.instance Definition _ := - @isConvexSpace0.Build (scaled A) convpt convn (fun _ _ _ => erefl) convpt1 convptmm convptC convptA. + @isConvexSpace0.Build R (scaled A) convpt convn (fun _ _ _ => erefl) convpt1 convptmm convptC convptA. -Lemma convptE p (a b : scaled A) : a <| p |> b = convpt p a b. +Lemma convptE p (a b : @scaled R A) : a <| p |> b = convpt p a b. Proof. by []. Qed. End convpt_convex_space. Section scaled_convex. -Variable A : convType. +Context {R : realType}. +Variable A : convType R. Local Open Scope R_scope. Local Open Scope convex_scope. Local Open Scope scaled_scope. -Lemma scalept_Scaled p q (x : A) : scalept p (q *: x) = scalept (p * q) (S1 x). +Lemma scalept_Scaled (p : R) (q : {posnum R}%R) (x : A) : + scalept p (q *: x) = scalept (p * q%:num)%R (S1 x). Proof. rewrite /scalept /=. -case: Rlt_dec => Hp; case: Rlt_dec => Hpq //. -- congr (_ *: _); apply val_inj; by rewrite /= mulR1. -- elim Hpq; by apply /mulR_gt0. -- elim Hp; move/pmulR_lgt0: Hpq; exact. +case: pselect => p0; case: pselect => q0//. +- congr (_ *: _); apply val_inj; by rewrite /= mulr1. +- exfalso. + apply: q0. + by rewrite mulr_gt0. +- exfalso. + apply: p0 => //. + by rewrite pmulr_lgt0 in q0. Qed. -Lemma scalept_gt0 p (q : Rpos) (x : A) (H : 0 < p) : - scalept p (q *: x) = (mkRpos H * q)%:pos *: x. +Lemma scalept_gt0 (p : R) (q : {posnum R}%R) (x : A) (H : (0 < p)%R) : + scalept p (q *: x) = ((PosNum H)%:num * q%:num)%:pos%R *: x. Proof. -rewrite /scalept /= ; case: Rlt_dec => // Hr. +rewrite /scalept /= ; case: pselect => // Hr. by congr (_ *: _); apply val_inj. Qed. -Lemma addptE a b (a0 : a != @Zero A) (b0 : b != Zero) : +Lemma addptE a b (a0 : a != @Zero R A) (b0 : b != Zero) : let p := [weight of a0] in let q := [weight of b0] in let x := [point of a0] in let y := [point of b0] in - addpt a b = (p + q)%:pos *: (x <| ((p / (p + q))%:pos)%:pr |> y). + addpt a b = (p%:num + q%:num)%:pos%R *: (x <| (*((p / (p + q))%:pos)%:pr*) divrposxxy p q |> y). Proof. move: a b => [p x|//] [pb y|//] /= in a0 b0 *. by congr (_ *: (_ <| _ |> _)); exact: val_inj. Qed. -Lemma weight_addpt : {morph @weight A : x y / addpt x y >-> x + y}. -Proof. move=> [p x|] [q y|] //=; by rewrite (add0R, addR0). Qed. +Lemma weight_addpt : {morph @raw_weight R A : x y / addpt x y >-> (x + y)%R}. +Proof. move=> [p x|] [q y|] //=; by rewrite (add0r, addr0). Qed. -Lemma weight0 : weight (@Zero A) = 0. Proof. by []. Qed. +Lemma weight0 : raw_weight (@Zero R A) = 0%R. Proof. by []. Qed. -Lemma scalept_weight p (x : scaled A) : 0 <= p -> weight (scalept p x) = p * weight x. +Lemma scalept_weight p (x : scaled A) : (0 <= p)%R -> raw_weight (scalept p x) = (p * raw_weight x)%R. Proof. -case=> [p0|<-]; last by rewrite scale0pt mul0R. -case: x => [r y|]; first by rewrite /= /scalept/=; case: Rlt_dec. -by rewrite scalept0 ?mulR0//; exact/ltRW. +rewrite le_eqVlt => /predU1P[<-|p0]. + by rewrite scale0pt mul0r. +case: x => [r y|]; first by rewrite /= /scalept/=; case: pselect. +by rewrite scalept0 ?mulr0//; exact/ltW. Qed. -Lemma weight_barycenter (pts : seq (scaled A)) : - weight (barycenter pts) = \sum_(x <- pts) weight x. -Proof. by rewrite (big_morph weight weight_addpt weight0). Qed. +Lemma weight_barycenter (pts : seq (@scaled R A)) : + raw_weight (barycenter pts) = (\sum_(x <- pts) raw_weight x)%R. +Proof. by rewrite (big_morph raw_weight weight_addpt weight0). Qed. Section adjunction. -Lemma affine_S1 : affine (@S1 A). +Lemma affine_S1 : affine (@S1 R A). Proof. move=> p x y. -have /RleP[p0|p0] := prob_ge0 p; last first. +have := prob_ge0 p; rewrite le_eqVlt => /predU1P[p0|p0]. by rewrite (_ : p = 0%:pr) ?conv0 //; exact/val_inj. -have /RleP[p1|p1] := prob_le1 p; last first. +have := prob_le1 p; rewrite le_eqVlt => /predU1P[p1|p1]. by rewrite (_ : p = 1%:pr) ?conv1 //; exact/val_inj. rewrite convptE (scalept_gt0 _ _ p0) (@scalept_gt0 (Prob.p p).~). - exact/RltP/onem_gt0/RltP. + exact/onem_gt0. move=> mp0; congr (_ *: _) => /=. - apply/val_inj => /=; rewrite !mulR1. - by rewrite RplusE onemKC. -by congr (_ <| _ |> _); apply val_inj; rewrite /= !mulR1 addRC subRK divR1. + apply/val_inj => /=; rewrite !mulr1. + by rewrite onemKC. +by congr (_ <| _ |> _); apply val_inj; rewrite /= !mulr1 addrC subrK divr1. Qed. -HB.instance Definition _ := isAffine.Build _ _ (@S1 A) affine_S1. +HB.instance Definition _ := isAffine.Build _ _ _ (@S1 R A) affine_S1. End adjunction. End scaled_convex. -Notation "'<|>_' d f" := (Convn (@conv _) d f) : convex_scope. +Notation "'<|>_' d f" := (Convn (@conv _ _) d f) : convex_scope. Section convex_space_prop1. -Variables T : convType. +Context {R : realType}. +Variables T : convType R. Implicit Types a b : T. Lemma convA0 (p q r s : {prob R}) a b c : - Prob.p p = (Prob.p r * Prob.p s)%coqR :> R -> ((Prob.p s).~ = (Prob.p p).~ * (Prob.p q).~)%coqR -> + Prob.p p = (Prob.p r * Prob.p s)%R :> R -> ((Prob.p s).~ = (Prob.p p).~ * (Prob.p q).~)%R -> a <| p |> (b <| q |> c) = (a <| r |> b) <| s |> c. Proof. move=> H1 H2. have [r0|r0] := eqVneq r 0%:pr. rewrite r0 conv0 (_ : p = 0%:pr) ?conv0; last first. - by apply/val_inj; rewrite /= H1 r0 mul0R. - congr (_ <| _ |> _); move: H2; rewrite H1 r0 mul0R onem0 mul1R. + by apply/val_inj; rewrite /= H1 r0 mul0r. + congr (_ <| _ |> _); move: H2; rewrite H1 r0 mul0r onem0 mul1r. by move/(congr1 (@onem R)); rewrite !onemK => ?; exact/val_inj. have [s0|s0] := eqVneq s 0%:pr. - have p0 : p = 0%:pr by apply/val_inj; rewrite /= H1 s0 mulR0. + have p0 : p = 0%:pr by apply/val_inj; rewrite /= H1 s0 mulr0. rewrite s0 conv0 p0 // ?conv0. rewrite (_ : q = 0%:pr) ?conv0 //. - move: H2; rewrite p0 onem0 mul1R => /(congr1 (@onem R)); rewrite !onemK => sq. + move: H2; rewrite p0 onem0 mul1r => /(congr1 (@onem R)); rewrite !onemK => sq. by rewrite -s0; exact/val_inj. rewrite convA; congr ((_ <| _ |> _) <| _ |> _). apply val_inj; rewrite /= s_of_pqE. @@ -746,17 +837,18 @@ by rewrite convA s_of_pqK// r_of_pqK. Qed. (* NB: this is defined here and not in realType_ext.v because it uses the scope %coqR *) -Lemma onem_probR_ge0 (p: {prob R}) : (0 <= (Prob.p p).~)%coqR. -Proof. exact/RleP/onem_ge0/prob_le1. Qed. +Lemma onem_probR_ge0 (p: {prob R}) : (0 <= (Prob.p p).~)%R. +Proof. exact/onem_ge0/prob_le1. Qed. Hint Resolve onem_probR_ge0 : core. Lemma convACA (a b c d : T) p q : (a <|q|> b) <|p|> (c <|q|> d) = (a <|p|> c) <|q|> (b <|p|> d). Proof. -apply: S1_inj; rewrite ![in LHS]affine_conv/= !convptE. -rewrite !scaleptDr !scaleptA// !(mulRC (Prob.p p)) !(mulRC (Prob.p p).~) addptA addptC. +apply: (@S1_inj R). +rewrite [LHS]affine_conv/= ![in LHS]affine_conv/= !convptE. +rewrite !scaleptDr !scaleptA// !(mulrC (Prob.p p)) !(mulrC (Prob.p p).~) addptA addptC. rewrite (addptC (scalept (Prob.p q * Prob.p p) _)) !addptA -addptA -!scaleptA -?scaleptDr//. -by rewrite !(addptC (scalept _.~ _)) !affine_conv. +by rewrite !(addptC (scalept _.~ _)) !(@affine_conv R). Qed. Lemma convDr (x y z : T) (p q : {prob R}) : @@ -786,37 +878,37 @@ Qed. Local Open Scope vec_ext_scope. Section with_affine_projection. -Variable U : convType. +Variable U : convType R. Variable prj : {affine T -> U}. Local Open Scope scaled_scope. -Definition map_scaled (x : scaled T) : scaled U := +Definition map_scaled (x : @scaled R T) : scaled U := if x is p *: a then p *: prj a else Zero. Lemma affine_map_scaled : affine map_scaled. Proof. move=> p [q x|] [r y|] /=; rewrite 2!convptE ?scalept0 //. - rewrite !(scalept_Scaled (Prob.p p)) !(scalept_Scaled (Prob.p p).~) /= /scalept /=. - case: Rlt_dec => Hpq; case: Rlt_dec => Hpr //=; congr (_ *: _). + case: pselect => Hpq; case: pselect => Hpr //=; congr (_ *: _). by rewrite affine_conv. -- by rewrite !addpt0 !(scalept_Scaled (Prob.p p)) /= /scalept /=; case: Rlt_dec. -- by rewrite !add0pt !(scalept_Scaled (Prob.p p).~) /= /scalept/=; case: Rlt_dec. +- by rewrite !addpt0 !(scalept_Scaled (Prob.p p)) /= /scalept /=; case: pselect. +- by rewrite !add0pt !(scalept_Scaled (Prob.p p).~) /= /scalept/=; case: pselect. Qed. -HB.instance Definition _ := isAffine.Build _ _ map_scaled affine_map_scaled. +HB.instance Definition _ := isAffine.Build _ _ _ map_scaled affine_map_scaled. Lemma S1_Convn_proj n (g : 'I_n -> T) d : S1 (prj (<|>_d g)) = \ssum_(i < n) scalept (d i) (S1 (prj (g i))). Proof. elim: n g d => [|n IH] g d. - by move: (FDist.f1 d); rewrite /= big_ord0 => /Rlt_not_eq; case. + by move: (FDist.f1 d); rewrite /= big_ord0 => /esym/eqP; rewrite oner_eq0. rewrite /=; case: Bool.bool_dec => [/eqP|/Bool.eq_true_not_negb]Hd. rewrite (bigD1 ord0) //= Hd big1 /=. - rewrite addpt0 (@scalept_gt0 _ 1). - by congr (_ *: _); apply val_inj; rewrite /= mulR1. + rewrite addpt0 (@scalept_gt0 _ _ 1). + by congr (_ *: _); apply val_inj; rewrite /= mulr1. move=> i Hi; have := FDist.f1 d. - rewrite (bigD1 ord0) ?inE // Hd /= -RplusE addRC => /(f_equal (Rminus^~ R1)). - rewrite addRK subRR => /eqP. + rewrite (bigD1 ord0) ?inE // Hd /= addrC => /(f_equal (fun x => x - 1)%R). + rewrite addrK subrr => /eqP. rewrite psumr_eq0// => /allP/= => /(_ i). by rewrite mem_index_enum Hi implyTb => /(_ isT)/eqP ->; rewrite scale0pt. set d' := fdist_del Hd. @@ -830,9 +922,10 @@ rewrite /barycenter 2!big_map [in RHS]big_map. apply eq_bigr => i _. rewrite scaleptA // fdist_delE fdistD1E /=. rewrite (mulrC (fun_of_fin (FDist.f d) (lift ord0 i))). -rewrite RmultE mulrA mulrV ?mul1r //. -move: (Hd); apply contra; rewrite R0E R1E => /eqP Hd'. -by rewrite -onem0 -Hd' onemK. +rewrite mulrA mulrV ?mul1r //. +move: (Hd); apply: contraPT. +rewrite unitfE/= negbK => /eqP Hd'. +by rewrite -onem0 -Hd' onemK eqxx. Qed. End with_affine_projection. @@ -846,7 +939,9 @@ Lemma fdist_convn_add n m p (g : 'I_(n + m) -> T) (d : {fdist 'I_n}) <|>_(fdist_add d e p) g = <|>_d (g \o @lshift n m) <| p |> <|>_e (g \o @rshift n m). Proof. -apply: S1_inj; rewrite affine_conv/= !S1_Convn convptE big_split_ord/=. +apply: (@S1_inj R). +rewrite [RHS]affine_conv/=. +rewrite !S1_Convn convptE big_split_ord/=. do 2 rewrite [in RHS]big_morph_scalept ?scalept0//. congr addpt; apply eq_bigr => i _; rewrite (scaleptA _ _ (S1 _)) //; @@ -856,17 +951,18 @@ Qed. End convex_space_prop1. Section convex_space_prop2. -Variables T U : convType. +Context {R : realType}. +Variables T U : convType R. Implicit Types a b : T. Lemma Convn_comp (f : {affine T -> U}) n (g : 'I_n -> T) (d : {fdist 'I_n}) : f (<|>_d g) = <|>_d (f \o g). -Proof. by apply S1_inj; rewrite S1_Convn S1_Convn_proj. Qed. +Proof. by apply (@S1_inj R); rewrite S1_Convn S1_Convn_proj. Qed. Lemma eq_Convn n (g1 g2 : 'I_n -> T) (d1 d2 : {fdist 'I_n}) : g1 =1 g2 -> d1 =1 d2 -> <|>_d1 g1 = <|>_d2 g2. Proof. -move=> Hg Hd; apply S1_inj; rewrite !S1_Convn. +move=> Hg Hd; apply (@S1_inj R); rewrite !S1_Convn. by apply congr_big => // i _; rewrite Hg Hd. Qed. @@ -883,10 +979,10 @@ reflexivity. Qed. Lemma Convn_proj n (g : 'I_n -> T) (d : {fdist 'I_n}) i : - d i = R1 -> <|>_d g = g i. + d i = 1%R -> <|>_d g = g i. Proof. -move=> Hd; apply: S1_inj. -rewrite S1_Convn (bigD1 i)//=. +move=> Hd; apply: (@S1_inj R). +rewrite [LHS]S1_Convn (bigD1 i)//=. rewrite big1; first by rewrite addpt0 Hd scale1pt. move=> j Hj. by move/eqP/fdist1P: Hd => -> //; rewrite scale0pt. @@ -926,7 +1022,7 @@ by rewrite -(I_n_contr (eq_rect 1 (fun n => 'I_1 -> 'I_n) idfun n (esym n1) ord0 Qed. Global Arguments ConvnI1_eq [n g d n1]. -Lemma ConvnIE n (g : 'I_n.+1 -> T) (d : {fdist 'I_n.+1}) (i1 : d ord0 != 1%coqR) : +Lemma ConvnIE n (g : 'I_n.+1 -> T) (d : {fdist 'I_n.+1}) (i1 : d ord0 != 1%R) : <|>_d g = g ord0 <| probfdist d ord0 |> <|>_(fdist_del i1) (fun x => g (fdist_del_idx ord0 x)). Proof. @@ -938,7 +1034,7 @@ Qed. Lemma ConvnI2E' (g : 'I_2 -> T) (d : {fdist 'I_2}) : <|>_d g = g ord0 <| probfdist d ord0 |> g (lift ord0 ord0). Proof. -have [/eqP|i1] := eqVneq (d ord0) 1%coqR. +have [/eqP|i1] := eqVneq (d ord0) 1%R. rewrite fdist1E1 => /eqP ->; rewrite Convn_fdist1. rewrite (_ : probfdist _ _ = 1%:pr) ?conv1 //. by apply val_inj; rewrite /= fdist1xx. @@ -949,7 +1045,7 @@ Qed. Lemma ConvnI2E (g : 'I_2 -> T) (d : {fdist 'I_2}) : convn d g = (g ord0) <| probfdist d ord0 |> (g (lift ord0 ord0)). Proof. -have [/eqP|i1] := eqVneq (d ord0) 1%coqR. +have [/eqP|i1] := eqVneq (d ord0) 1%R. rewrite fdist1E1 convnE => /eqP ->; rewrite Convn_fdist1. rewrite (_ : probfdist _ _ = 1%:pr) ?conv1 //. by apply val_inj; rewrite /= fdist1xx. @@ -958,7 +1054,7 @@ by rewrite ConvnI1E /fdist_del_idx ltnn. Qed. End convex_space_prop2. -HB.factory Record isConvexSpace T of Choice T := { +HB.factory Record isConvexSpace {R : realType} T of Choice T := { conv : {prob R} -> T -> T -> T ; conv1 : forall a b, conv 1%:pr a b = a ; convmm : forall p a, conv p a a = a ; @@ -966,7 +1062,7 @@ HB.factory Record isConvexSpace T of Choice T := { convA : forall (p q : {prob R}) (a b c : T), conv p a (conv q b c) = conv [s_of p, q] (conv [r_of p, q] a b) c }. -HB.builders Context T of isConvexSpace T. +HB.builders Context R T of isConvexSpace R T. Definition convn := Convn conv. @@ -983,7 +1079,7 @@ rewrite /convn {1}/Convn. case: Bool.bool_dec => [/eqP|/Bool.eq_true_not_negb b01]. rewrite fdist1E; case j0 : (_ == _) => /=. by move=> _; rewrite (eqP j0). - by move/eqP; rewrite eq_sym R1E oner_eq0. + by move/eqP; rewrite eq_sym oner_eq0. rewrite (_ : probfdist _ _ = 0%:pr) ?conv0; last first. apply val_inj => /=; move: b01; rewrite !fdist1E => j0. by case j0' : (_ == _) => //; rewrite j0' eqxx in j0. @@ -995,10 +1091,10 @@ rewrite (_ : fdist_del b01 = fdist1 j'); last first. apply/fdist_ext => /= k. rewrite fdist_delE fdistD1E /= !fdist1E /= (negbTE j0) subr0 divr1. congr (GRing.natmul _ (nat_of_bool _)). - move R : (k == _) => [|]. + move Hk : (k == _) => [|]. - apply/eqP/val_inj; rewrite /= /bump leq0n add1n. - by move/eqP : R => -> /=; rewrite prednK // lt0n. - - apply: contraFF R => /eqP. + by move/eqP : Hk => -> /=; rewrite prednK // lt0n. + - apply: contraFF Hk => /eqP. move/(congr1 val) => /=; rewrite /bump leq0n add1n => kj. by apply/eqP/val_inj; rewrite /= -kj. rewrite -/Convn. @@ -1007,7 +1103,7 @@ rewrite IH /fdist_del_idx ltn0; congr g. by apply val_inj; rewrite /= /bump leq0n add1n prednK // lt0n. Qed. -Let ConvnIE n (g : 'I_n.+1 -> T) (d : {fdist 'I_n.+1}) (i1 : d ord0 != 1%coqR) : +Let ConvnIE n (g : 'I_n.+1 -> T) (d : {fdist 'I_n.+1}) (i1 : d ord0 != 1%R) : convn d g = conv (probfdist d ord0) (g ord0) (convn (fdist_del i1) (fun x => g (fdist_del_idx ord0 x))). Proof. @@ -1027,7 +1123,7 @@ Let ConvnI2E : forall (g : 'I_2 -> T) (d : {fdist 'I_2}), convn d g = conv (probfdist d ord0) (g ord0) (g (lift ord0 ord0)). Proof. move=> g d. -have [/eqP|i1] := eqVneq (d ord0) 1%coqR. +have [/eqP|i1] := eqVneq (d ord0) 1%R. rewrite fdist1E1 => /eqP ->. rewrite Convn_fdist1. rewrite (_ : probfdist _ _ = 1%:pr) ?conv1 //. @@ -1036,20 +1132,21 @@ rewrite ConvnIE; congr conv. by rewrite ConvnI1E /fdist_del_idx ltnn. Qed. -HB.instance Definition _ := @isConvexSpace0.Build T +HB.instance Definition _ := @isConvexSpace0.Build R T conv convn (fun _ _ _ => erefl) conv1 convmm convC convA. HB.end. Section convex_space_prop3. -Variables T U : convType. +Context {R : realType}. +Variables T U : convType R. Implicit Types a b : T. (* ref: M.H.Stone, postulates for the barycentric calculus, lemma 2 *) Lemma Convn_perm (n : nat) (d : {fdist 'I_n}) (g : 'I_n -> T) (s : 'S_n) : <|>_d g = <|>_(fdistI_perm d s) (g \o s). Proof. -apply S1_inj; rewrite !S1_Convn (ssum_perm _ s). +apply (@S1_inj R); rewrite !S1_Convn (ssum_perm _ s). by apply eq_bigr => i _; rewrite fdistI_permE. Qed. @@ -1058,7 +1155,7 @@ Theorem Convn_fdist_convn (n m : nat) (d : {fdist 'I_n}) (e : 'I_n -> {fdist 'I_m}) (x : 'I_m -> T) : <|>_d (fun i => <|>_(e i) x) = <|>_(fdist_convn d e) x. Proof. -apply S1_inj; rewrite !S1_Convn -[in RHS]big_enum -ssum_fdist_convn. +apply (@S1_inj R); rewrite !S1_Convn -[in RHS]big_enum -ssum_fdist_convn. by apply eq_bigr => i _; rewrite big_enum S1_Convn. Qed. @@ -1066,29 +1163,29 @@ Lemma Convn_cst (a : T) (n : nat) (d : {fdist 'I_n}) : <|>_d (fun=> a) = a. Proof. elim: n d; first by move=> d; move/fdistI0_False: (d). move=> n IHn d. -have [|] := eqVneq (d ord0) 1%coqR; first by move/(Convn_proj (fun=> a)). +have [|] := eqVneq (d ord0) 1%R; first by move/(Convn_proj (fun=> a)). by move=> d0n0; rewrite ConvnIE IHn convmm. Qed. Lemma Convn_idem (a : T) (n : nat) (d : {fdist 'I_n}) (g : 'I_n -> T) : - (forall i : 'I_n, (d i != 0)%coqR -> g i = a) -> <|>_d g = a. + (forall i : 'I_n, (d i != 0)%R -> g i = a) -> <|>_d g = a. Proof. -move=> Hg; apply: S1_inj. +move=> Hg; apply: (@S1_inj R). rewrite S1_Convn (eq_bigr (fun i => scalept (d i) (S1 a))). by rewrite -S1_Convn Convn_cst. move=> /= i _. -by have [-> //|/Hg ->//] := eqVneq (d i) 0%coqR; rewrite !scale0pt. +by have [-> //|/Hg ->//] := eqVneq (d i) 0%R; rewrite !scale0pt. Qed. Lemma Convn_weak n m (u : 'I_m -> 'I_n) (d : {fdist 'I_m}) (g : 'I_n -> T) : <|>_d (g \o u) = <|>_(fdistmap u d) g. Proof. -apply S1_inj. +apply (@S1_inj R). rewrite !S1_Convn (partition_big u (fun _=> true)) //=. apply eq_bigr => i _. rewrite fdistmapE /=. -have HF (a : 'I_m) : (0 <= d a)%coqR. by []. -rewrite (@scalept_sum _ _ _ (mkNNFun HF)) /=. +have HF (a : 'I_m) : (0 <= d a)%R. by []. +rewrite (@scalept_sum _ _ _ _ d) //=. by apply eq_bigr => a /eqP ->. Qed. @@ -1096,7 +1193,7 @@ Lemma ConvnDr n (p : {prob R}) (x : T) (g : 'I_n -> T) (d : {fdist 'I_n}) : x <|p|> <|>_d g = <|>_d (fun i => x <|p|> g i). Proof. elim: n p x g d => [? ? ? d|n IHn p x g d]; first by move/fdistI0_False: (d). -have [d01|d0n1] := eqVneq (d ord0) 1%coqR. +have [d01|d0n1] := eqVneq (d ord0) 1%R. by rewrite (Convn_proj g d01) (Convn_proj (fun i => x <|p|> g i) d01). by rewrite !ConvnIE !IHn; congr (<|>_ _ _); apply funext=> i; rewrite convDr. Qed. @@ -1113,7 +1210,7 @@ Lemma ConvnDlr n m (p : {prob R}) (f : 'I_n -> T) (d : {fdist 'I_n}) <|>_(fdist_add d e p) (fun i => match fintype.split i with inl i => f i | inr i => g i end). Proof. -apply: S1_inj; rewrite affine_conv/= 3!S1_Convn convptE. +apply: (@S1_inj R); rewrite affine_conv/= 3!S1_Convn convptE. do 2 rewrite big_morph_scalept ?scalept0//. rewrite big_split_ord/=. congr addpt; apply: congr_big => //= i _; rewrite scaleptA// fdist_addE. @@ -1127,13 +1224,14 @@ End convex_space_prop3. Section hull_def. Local Open Scope classical_set_scope. -Definition hull (T : convType) (X : set T) : set T := +Definition hull {R : realType} (T : convType R) (X : set T) : set T := [set p : T | exists n (g : 'I_n -> T) d, g @` setT `<=` X /\ p = <|>_d g]. End hull_def. Section hull_prop. Local Open Scope classical_set_scope. -Variable A : convType. +Context {R : realType}. +Variable A : convType R. Implicit Types X Y : set A. Implicit Types a : A. @@ -1174,7 +1272,7 @@ exfalso. move: H'; rewrite fdist_delE fdistD1E (eq_sym (lift _ _)) (negbTE (neq_lift _ _)). rewrite fdistI2E (eq_sym (lift _ _)) (negbTE (neq_lift _ _)) fdistI2E. rewrite eqxx mulrV ?eqxx //. -by move: H; rewrite fdistI2E eqxx onem_neq0. +by move: H; rewrite fdistI2E eqxx unitfE onem_neq0. Qed. Lemma hull_monotone X Y : X `<=` Y -> hull X `<=` hull Y. @@ -1185,8 +1283,14 @@ Qed. End hull_prop. +(* TODO: move *) +Lemma r_of_p0_oprob {R : realType} (p : {oprob R}) : + [r_of OProb.p p, 0%:pr] = 1%:pr. +Proof. by apply/r_of_p0/oprob_neq0. Qed. + Module ErealConvex. Section ereal_convex. +Context {R : realType}. Local Open Scope ereal_scope. Let conv_ereal (p : {prob R}) x y := (Prob.p p : R)%:E * x + (Prob.p p).~%:E * y. @@ -1228,21 +1332,22 @@ apply (prob_trichotomy' p); | by rewrite s_of_1q r_of_1q !mul1e !onem1 !mul0e !adde0 | rewrite {p}=> p]. apply (prob_trichotomy' q); - [ by rewrite s_of_p0 Reals_ext.r_of_p0_oprob onem1 onem0 mul0e !mul1e add0e adde0 + [ by rewrite s_of_p0 r_of_p0_oprob onem1 onem0 mul0e !mul1e add0e adde0 | by rewrite s_of_p1 r_of_p1 onem1 !mul1e mul0e !adde0 | rewrite {q}=> q]. +Ltac mulr_infty X := do ! (rewrite mulr_infty X mul1e). have sgp := oprob_sg1 p. have sgq := oprob_sg1 q. -have sgonemp := oprob_sg1 (Prob.p (OProb.p p)).~%:opr. -have sgonemq := oprob_sg1 (Prob.p (OProb.p q)).~%:opr. +have sgonemp := oprob_sg1 (oprob_to_real p).~%:opr. +have sgonemq := oprob_sg1 (oprob_to_real q).~%:opr. have sgrpq := oprob_sg1 [r_of OProb.p p, OProb.p q]%:opr. have sgspq := oprob_sg1 [s_of OProb.p p, OProb.p q]%:opr. have sgonemrpq := oprob_sg1 (Prob.p [r_of OProb.p p, OProb.p q]).~%:opr. have sgonemspq := oprob_sg1 (Prob.p [s_of OProb.p p, OProb.p q]).~%:opr. -Ltac mulr_infty X := do ! (rewrite mulr_infty X mul1e). set sg := (sgp,sgq,sgonemp,sgonemq,sgrpq,sgspq,sgonemrpq,sgonemspq). case: a=> [a | | ]; case: b=> [b | | ]; case: c=> [c | | ]; try by mulr_infty sg. +clear sgp sgq sgonemp sgonemq sgrpq sgspq sgonemrpq sgonemspq sg. rewrite muleDr // addeA. congr (_ + _)%E; last by rewrite s_of_pqE onemK EFinM muleA. rewrite muleDr //. @@ -1251,10 +1356,10 @@ congr (_ + _)%E. rewrite muleA -!EFinM. rewrite (pq_is_rs (OProb.p p) (OProb.p q)). rewrite mulrA. -by rewrite (mulrC (Prob.p [r_of OProb.p p, OProb.p q]).~). +by rewrite [X in (X * b)%:E]mulrC. Qed. -#[export] HB.instance Definition _ := @isConvexSpace.Build (\bar R) conv_ereal conv_ereal_conv1 conv_ereal_convmm conv_ereal_convC conv_ereal_convA. +#[export] HB.instance Definition _ := @isConvexSpace.Build _ (\bar R) conv_ereal conv_ereal_conv1 conv_ereal_convmm conv_ereal_convC conv_ereal_convA. Lemma conv_erealE p (a b : \bar R) : a <| p |> b = conv_ereal p a b. Proof. by []. Qed. @@ -1267,7 +1372,8 @@ HB.export ErealConvex. Section is_convex_set. Local Open Scope classical_set_scope. -Variable T : convType. +Context {R : realType}. +Variable T : convType R. Definition is_convex_set (D : set T) : bool := `[ D y -> D (x <| t |> y)>]. @@ -1289,12 +1395,12 @@ Proof. apply/idP/idP => H; apply/asboolP. elim => [g d|n IH g d]; first by move: (fdistI0_False d). case: n => [|n] in IH g d * => gX. - rewrite {IH} (@Convn_proj _ _ _ _ ord0) //. + rewrite {IH} (@Convn_proj _ _ _ _ _ ord0) //. exact/gX/classical_sets.imageP. by apply/eqP; rewrite fdist1E1 (fdist1I1 d). - have [d01|d01] := eqVneq (d ord0) 1%coqR. + have [d01|d01] := eqVneq (d ord0) 1%R. suff -> : <|>_d g = g ord0 by apply gX; exists ord0. - by rewrite (@Convn_proj _ _ _ _ ord0). + by rewrite (@Convn_proj _ _ _ _ _ ord0). set D : {fdist 'I_n.+1} := fdist_del d01. pose G (i : 'I_n.+1) : T := g (fdist_del_idx (@ord0 _) i). have /(IH _ D) {}IH : range G `<=` X. @@ -1336,12 +1442,14 @@ End is_convex_set. Record ConvexSet (A : convType) := { convset_set :> set A ; _ : is_convex_set convset_set }. HB.instance Definition _ A := [isSub of ConvexSet A for @convset_set A ]. *) -HB.mixin Record isConvexSet (A : convType) (X : set A) := { is_convex : is_convex_set X }. -HB.structure Definition ConvexSet A := { X of isConvexSet A X }. +HB.mixin Record isConvexSet {R : realType} (A : convType R) (X : set A) := + { is_convex : is_convex_set X }. +HB.structure Definition ConvexSet {R : realType} A := + { X of isConvexSet R A X }. Notation "{ 'convex_set' T }" := (ConvexSet.type T) : convex_scope. -Canonical cset_predType A := Eval hnf in - PredType (fun t : {convex_set A} => (fun x => x \in ConvexSet.sort t)). +Canonical cset_predType {R :realType} A := Eval hnf in + PredType (fun t : {convex_set A} => (fun x => x \in @ConvexSet.sort R _ t)). (* Module CSet. @@ -1374,10 +1482,12 @@ Canonical cset_choiceType := choice_of_Type (convex_set A). End cset_canonical. *) -HB.instance Definition _ A := @gen_eqMixin {convex_set A}. +HB.instance Definition _ {R : realType} (A : convType R) := + @gen_eqMixin {convex_set A}. Section CSet_interface. -Variable (A : convType). +Context {R : realType}. +Variable (A : convType R). Implicit Types X Y : {convex_set A}. Lemma convex_setP X : is_convex_set X. Proof. by case: X => X [[]] /=. Qed. @@ -1390,18 +1500,19 @@ End CSet_interface. Section CSet_prop. Local Open Scope classical_set_scope. -Variable A : convType. +Context {R : realType}. +Variable A : convType R. Implicit Types X Y : {convex_set A}. Implicit Types a : A. -Implicit Types x y : scaled A. +Implicit Types x y : @scaled R A. Lemma mem_convex_set a1 a2 p X : a1 \in X -> a2 \in X -> a1 <|p|> a2 \in X. Proof. -have /asboolP C := @is_convex A X. +have /asboolP C := @is_convex R A X. by rewrite !inE; apply: C. Qed. -HB.instance Definition _ := isConvexSet.Build A set0 (is_convex_set0 A). +HB.instance Definition _ := isConvexSet.Build R A set0 (is_convex_set0 A). Lemma cset0P X : (X == set0) = (X == set0 :> set _). Proof. @@ -1415,21 +1526,22 @@ rewrite cset0P; case: X => //= x Hx; split; last first. by case/set0P => /= d dx; exists d. Qed. -HB.instance Definition _ a := isConvexSet.Build A [set a] (is_convex_set1 a). +HB.instance Definition _ a := isConvexSet.Build R A [set a] (is_convex_set1 a). Lemma cset1_neq0 a : [set a] != set0 :> {convex_set A}. Proof. by apply/cset0PN; exists a. Qed. -HB.instance Definition _ x y := isConvexSet.Build _ (segment x y) (segment_is_convex x y). +HB.instance Definition _ x y := isConvexSet.Build R _ (segment x y) (segment_is_convex x y). End CSet_prop. (* Lemmas on hull and convex set *) Section hull_is_convex. -Variable A : convType. +Context {R : realType}. +Variable A : convType R. -Lemma hull_sub_convex (X : set A)(Y : {convex_set A}) : +Lemma hull_sub_convex (X : set A) (Y : {convex_set A}) : (X `<=` Y -> hull X `<=` Y)%classic. Proof. move=> XY x [n [g [d [gX ->]]]]. @@ -1453,7 +1565,7 @@ by rewrite fdist_convn_add; congr (_ <| _ |> _); apply eq_Convn => i //=; rewrite ffunE (split_lshift,split_rshift). Qed. -HB.instance Definition _ (Z : set A) := isConvexSet.Build _ (hull Z) (hull_is_convex Z). +HB.instance Definition _ (Z : set A) := isConvexSet.Build R _ (hull Z) (hull_is_convex Z). Lemma segment_hull (x y : A) : segment x y = hull [set x; y]. Proof. @@ -1462,7 +1574,7 @@ rewrite eqEsubset; split. apply subset_hull; [left | right]. (* BUG in HB: HB.pack only accepts types as subjects pose h : {convex_set A} := HB.pack _ (isConvexSet.Build _ _ (segment_is_convex x y)).*) -pose h : {convex_set A} := @ConvexSet.Pack _ _ (@ConvexSet.Class _ _ (isConvexSet.Build _ _ (segment_is_convex x y))). +pose h : {convex_set A} := @ConvexSet.Pack R _ _ (@ConvexSet.Class R _ _ (isConvexSet.Build R _ _ (segment_is_convex x y))). by have := @hull_sub_convex [set x; y] h; apply => z -[] ->; [exact: segmentL|exact: segmentR]. Qed. @@ -1471,14 +1583,15 @@ End hull_is_convex. Section hull_convex_set. Local Open Scope classical_set_scope. -Variable A : convType. +Context {R : realType}. +Variable A : convType R. Implicit Types X Y Z : set A. Lemma is_convex_hullE X : is_convex_set X = (hull X == X). Proof. apply/idP/idP => [conv|/eqP <-]; last exact: hull_is_convex. (* BUG in HB *) -pose X' : {convex_set A} := @ConvexSet.Pack _ _ (@ConvexSet.Class _ _ (isConvexSet.Build _ _ conv)). +pose X' : {convex_set A} := @ConvexSet.Pack R _ _ (@ConvexSet.Class R _ _ (isConvexSet.Build R _ _ conv)). exact/eqP/(hull_cset X'). Qed. @@ -1528,16 +1641,17 @@ End hull_convex_set. Section hull_setU. Local Open Scope classical_set_scope. Local Open Scope scaled_scope. -Variable T : convType. +Context {R : realType}. +Variable T : convType R. Implicit Types Z : set T. -Definition scaled_set Z := [set x | if x is p *: a then Z a else True]. +Definition scaled_set Z := [set x : @scaled R T | if x is p *: a then Z a else True]. Lemma scalept_scaled_set Z r x : x \in scaled_set Z -> scalept r x \in scaled_set Z. Proof. rewrite /scalept/=. -by case: Rlt_dec => //= Hr; [case: x | rewrite !in_setE]. +by case: pselect => //= Hr; [case: x | rewrite !in_setE]. Qed. Lemma scaled_set_extract Z x (x0 : x != Zero) : @@ -1572,16 +1686,16 @@ suff [a] : exists2 a, a \in scaled_set X & exists2 b, b \in scaled_set Y & have [-> _ [b bY]|a0 aX [b]] := eqVneq a Zero. rewrite add0pt => S1zy. exists dx; rewrite ?in_setE //; exists z; last by exists 0%:pr; rewrite conv0. - by rewrite -(point_S1 z); apply: scaled_set_extract; rewrite S1zy. + by rewrite -(@point_S1 R _ z); apply: scaled_set_extract; rewrite S1zy. have [-> _|b0 bY] := eqVneq b Zero. rewrite addpt0 => S1zx. exists z; last by exists dy; rewrite ?in_setE //; exists 1%:pr; rewrite conv1. - by rewrite -(point_S1 z); apply: scaled_set_extract; rewrite S1zx. + by rewrite -(@point_S1 R _ z); apply: scaled_set_extract; rewrite S1zx. rewrite addptE => -[_ zxy]. exists [point of a0]; first exact: (@scaled_set_extract _ a). exists [point of b0]; first exact: scaled_set_extract. by eexists; rewrite zxy. -move/(congr1 (@S1 T)): zg; rewrite S1_Convn. +move/(congr1 (@S1 R T)): zg; rewrite S1_Convn. rewrite (bigID (fun i => g i \in X)) /=. set b := \ssum_(i | _) _. set c := \ssum_(i | _) _. @@ -1646,6 +1760,7 @@ End split_prod. Module LmoduleConvex. Section lmodR_convex_space. +Context {R : realType}. Variable E : lmodType R. Implicit Type p q : {prob R}. Local Open Scope ring_scope. @@ -1658,8 +1773,7 @@ Proof. by rewrite /avg /= scale1r onem1 scale0r addr0. Qed. Let avgI p x : avg p x x = x. Proof. rewrite /avg -scalerDl. -have -> : (Prob.p p) + (Prob.p p).~ = Rplus (Prob.p p) (Prob.p p).~ by []. -by rewrite RplusE onemKC scale1r. +by rewrite onemKC scale1r. Qed. Let avgC p x y : avg p x y = avg (Prob.p p).~%:pr y x. @@ -1677,18 +1791,18 @@ rewrite scalerDr (scalerA _ _ d2). rewrite -/(Prob.p p).~ -/(Prob.p q).~ -/r.~ -/s.~. rewrite {2}/s (s_of_pqE p q) onemK; congr +%R. rewrite 2!scalerA; congr (_ *: _). -have ->: (Prob.p p).~ * Prob.p q = ((Prob.p p).~ * Prob.p q)%coqR by []. -by rewrite RmultE pq_is_rs -/r -/s mulrC. +by rewrite pq_is_rs -/r -/s mulrC. Qed. #[non_forgetful_inheritance] HB.instance Definition _ := - isConvexSpace.Build E avg1 avgI avgC avgA. + isConvexSpace.Build R E avg1 avgI avgC avgA. Lemma avgrE p (x y : E) : x <| p |> y = avg p x y. Proof. by []. Qed. End lmodR_convex_space. End LmoduleConvex. Section lmodR_convex_space_prop. +Context {R : realType}. Variable E : lmodType R. Implicit Type p q : {prob R}. Local Open Scope ring_scope. @@ -1716,29 +1830,29 @@ Proof. by move=> x ? ?; rewrite avgrE scalerDl -2!scalerA. Qed. (* Introduce morphisms to prove avgnE *) -Definition scaler x : E := if x is (p *: y)%scaled then (Rpos.v p) *: y else 0. +Definition scaler x : E := if x is (p *: y)%scaled then p%:num *: y else 0. -Lemma Scaled1rK : cancel (@S1 (_ E)) scaler. +Lemma Scaled1rK : cancel (@S1 R (_ E)) scaler. Proof. by move=> x /=; rewrite scale1r. Qed. Lemma scaler_addpt : {morph scaler : x y / addpt x y >-> x + y}. Proof. move=> [p x|] [q y|] /=; rewrite ?(add0r,addr0) //. -rewrite avgrE /divRposxxy /= RdivE onem_div; last exact: Rpos_neq0. -rewrite -!RmultE -!RinvE -!(mulRC (/ _)%coqR) scalerDr !scalerA !mulrA. -have ->: (p + q)%coqR * (/ (p + q))%coqR = 1 by apply mulRV; last by apply Rpos_neq0. -by rewrite !mul1r (addRC p) addrK. +rewrite avgrE /divrposxxy /= onem_div//. +rewrite -!(mulrC (p%:num + q%:num)^-1%R) scalerDr !scalerA !mulrA. +rewrite divff// !mul1r. +by rewrite addrAC subrr add0r. Qed. Lemma scalerZero : scaler Zero = 0. by []. Qed. -Lemma scaler_scalept r x : (0 <= r -> scaler (scalept r x) = r *: scaler x)%coqR. +Lemma scaler_scalept r x : (0 <= r -> scaler (scalept r x) = r *: scaler x)%R. Proof. case: x => [q y|r0]; last first. by rewrite scalept0// scalerZero !GRing.scaler0. -case=> r0. - by rewrite scalept_gt0 /= scalerA. -by rewrite -r0 scale0pt scale0r. +rewrite le_eqVlt => /predU1P[r0|r0]. + by rewrite -r0 scale0pt scale0r. +by rewrite scalept_gt0 /= scalerA. Qed. Definition big_scaler := big_morph scaler scaler_addpt scalerZero. @@ -1760,9 +1874,9 @@ Lemma avgnr_add n m (f : 'I_n -> E) (d : {fdist 'I_n}) (g : 'I_m -> E) Proof. rewrite -[<|>_e g]scale1r !avgnrE !/avgnr big_prod_ord. rewrite -(FDist.f1 d) scaler_suml -big_split; apply congr_big=>// i _. -transitivity (d i *: (1%coqR *: f i + \sum_(i0 < m) e i0 *: g i0)). +transitivity (d i *: (1%R *: f i + \sum_(i0 < m) e i0 *: g i0)). by rewrite scale1r scalerDr. -rewrite R1E -(FDist.f1 e) scaler_suml -big_split scaler_sumr; apply congr_big=>// j _. +rewrite -(FDist.f1 e) scaler_suml -big_split scaler_sumr; apply congr_big=>// j _. rewrite scalerDr -!scalerDr scalerA unsplit_prodK; congr (_ *: _). rewrite fdistmapE (big_pred1 (i, j)) /= ?fdist_prodE//. move=>[i' j'] /=; rewrite xpair_eqE inE /=. @@ -1818,6 +1932,7 @@ End freeN_combination. Section caratheodory. Import ssrnum vector. +Context {R : realType}. Variable E : vectType R. Local Open Scope ring_scope. Local Open Scope classical_set_scope. @@ -1854,7 +1969,7 @@ have [mu [muR muE [i mui]]] : exists mu : 'I_n.+1 -> R, - by exists (lift ord0 i) => /=; rewrite (_ : Ordinal _ = i)//; exact/val_inj. wlog: mu muR muE mui / mu i > 0. move=> H. - have [mui0|mui0] := ltP 0%coqR (mu i); first exact: (H mu). + have [mui0|mui0] := ltP 0%R (mu i); first exact: (H mu). apply (H (fun i => - mu i)). - by rewrite sumrN muR oppr0. - by under eq_bigr do rewrite scaleNr; rewrite sumrN muE oppr0. @@ -1938,12 +2053,13 @@ End caratheodory. Module LinearAffine. Section linear_affine. Open Scope ring_scope. +Context {R : realType}. Variables (E F : lmodType R) (f : {linear E -> F}). Import LmoduleConvex. Let linear_is_affine: affine f. Proof. by move=>p x y; rewrite linearD 2!linearZZ. Qed. -#[export] HB.instance Definition _ := isAffine.Build _ _ _ linear_is_affine. +#[export] HB.instance Definition _ := isAffine.Build R _ _ _ linear_is_affine. End linear_affine. End LinearAffine. @@ -1952,11 +2068,12 @@ HB.export LinearAffine. (* TOTHINK: Should we keep this section, only define R_convType, or something else ? *) Module RConvex. Section R_convex_space. +Context {R : realType}. Implicit Types p q : {prob R}. Import LmoduleConvex. Let avg p (a b : (R^o : lmodType R)) := a <| p |> b. -Let avgE p a b : avg p a b = (Prob.p p * a + (Prob.p p).~ * b)%coqR. +Let avgE p a b : avg p a b = (Prob.p p * a + (Prob.p p).~ * b)%R. Proof. by []. Qed. Let avg1 a b : avg 1%:pr a b = a. Proof. by rewrite /avg conv1. Qed. @@ -1971,50 +2088,54 @@ Proof. by rewrite /avg convA. Qed. #[export] (* TODO(rei): attribute needed? *) -(*#[non_forgetful_inheritance]*) HB.instance Definition _ := @isConvexSpace.Build R _ avg1 avgI avgC avgA. +(*#[non_forgetful_inheritance]*) HB.instance Definition _ := @isConvexSpace.Build R R^o avg avg1 avgI avgC avgA. -Lemma avgRE p (x y : R) : x <| p |> y = (Prob.p p * x + (Prob.p p).~ * y)%coqR. Proof. by []. Qed. +Lemma avgRE p (x y : R^o) : x <| p |> y = (Prob.p p * x + (Prob.p p).~ * y)%R. Proof. by []. Qed. -Lemma avgR_oppD p x y : (- x <| p |> - y = - (x <| p |> y))%coqR. -Proof. exact: (@avgr_oppD R^o). Qed. +Lemma avgR_oppD p (x y : R^o) : (- x <| p |> - y = - (x <| p |> y))%R. +Proof. exact: (@avgr_oppD _ R^o). Qed. -Lemma avgR_mulDr p : right_distributive Rmult (fun x y => x <| p |> y). +Lemma avgR_mulDr p : right_distributive (@GRing.mul R^o) (fun x y => x <| p |> y). Proof. exact: (@avgr_scalerDr R^o). Qed. -Lemma avgR_mulDl p : left_distributive Rmult (fun x y => x <| p |> y). +Lemma avgR_mulDl p : left_distributive (@GRing.mul R^o) (fun x y => x <| p |> y). Proof. exact: @avgr_scalerDl. Qed. (* Introduce morphisms to prove avgnE *) -Definition scaleR x : R := if x is (p *: y)%scaled then p * y else 0. +Definition scaleR x : R := if x is (p *: y)%scaled then p%:num * y else 0. -Lemma Scaled1RK : cancel (@S1 _) scaleR. -Proof. by move=> x /=; rewrite mul1R. Qed. +Lemma Scaled1RK : cancel (@S1 _ _) scaleR. +Proof. by move=> x /=; rewrite mul1r. Qed. -Lemma scaleR_addpt : {morph scaleR : x y / addpt x y >-> (x + y)%coqR}. +Lemma scaleR_addpt : + {morph scaleR : x y / @addpt _ _ (x : @scaled R R^o) y >-> (x + y)%R}. Proof. -move=> [p x|] [q y|] /=; rewrite ?(add0R,addR0) //. -rewrite avgRE /avg /divRposxxy /= RdivE onem_div /Rdiv; last exact: Rpos_neq0. -rewrite -!RmultE -!RinvE -!(mulRC (/ _)%coqR) mulRDr !mulRA mulRV; last exact: Rpos_neq0. -by rewrite !mul1R (addRC p) addrK. +move=> [p x|] [q y|] /=; rewrite ?(add0r,addr0) //. +rewrite avgRE /avg /divrposxxy /= onem_div//. +rewrite -!(mulrC ((p%:num + q%:num))^-1%R) mulrDr !mulrA mulfV//. +by rewrite !mul1r addrAC subrr add0r. Qed. -Lemma scaleR0 : scaleR Zero = R0. by []. Qed. +Lemma scaleR0 : scaleR Zero = 0%R. Proof. by []. Qed. -Lemma scaleR_scalept r x : (0 <= r -> scaleR (scalept r x) = r * scaleR x)%coqR. +Lemma scaleR_scalept r (x : @scaled R R^o) : + (0 <= r -> scaleR (scalept r x) = r * scaleR x)%R. Proof. -case: x => [q y|r0]; last by rewrite scalept0// mulR0. -case=> r0. by rewrite scalept_gt0 /= mulRA. -by rewrite -r0 scale0pt mul0R. +case: x => [q y|r0]; last by rewrite scalept0// mulr0. +rewrite le_eqVlt => /predU1P[r0|r0]. + by rewrite -r0 scale0pt mul0r. +by rewrite scalept_gt0 /= mulrA. Qed. Definition big_scaleR := big_morph scaleR scaleR_addpt scaleR0. -Definition avgnR n (g : 'I_n -> R) (e : {fdist 'I_n}) := (\sum_(i < n) e i * g i)%coqR. +Definition avgnR n (g : 'I_n -> R) (e : {fdist 'I_n}) := + (\sum_(i < n) e i * g i)%R. -Lemma avgnRE n (g : 'I_n -> R) e : <|>_e g = avgnR g e. +Lemma avgnRE n (g : 'I_n -> R^o) e : <|>_e g = avgnR g e. Proof. -rewrite -[LHS]Scaled1RK S1_Convn big_scaleR. +rewrite -[LHS]Scaled1RK (@S1_Convn R R^o) big_scaleR. by apply eq_bigr => i _; rewrite scaleR_scalept // Scaled1RK. Qed. @@ -2024,7 +2145,8 @@ HB.export RConvex. Module FunConvexSpace. Section fun_convex_space. -Variables (A : choiceType) (B : convType). +Context {R : realType}. +Variables (A : choiceType) (B : convType R). Definition funT := A -> B. Local Notation T := funT. HB.instance Definition _ := Choice.on T. @@ -2039,14 +2161,15 @@ Proof. rewrite funeqE => a; exact/convC. Qed. Let avgA p q (d0 d1 d2 : T) : avg p d0 (avg q d1 d2) = avg [s_of p, q] (avg [r_of p, q] d0 d1) d2. Proof. move=> *; rewrite funeqE => a; exact/convA. Qed. -#[export] HB.instance Definition _ := @isConvexSpace.Build T avg avg1 avgI avgC avgA. +#[export] HB.instance Definition _ := @isConvexSpace.Build R T avg avg1 avgI avgC avgA. End fun_convex_space. End FunConvexSpace. HB.export FunConvexSpace. Module DepfunConvexSpace. Section depfun_convex_space. -Variables (A : choiceType) (B : A -> convType). +Context {R : realType}. +Variables (A : choiceType) (B : A -> convType R). Let T := forall x : A, B x. Implicit Types p q : {prob R}. Let avg p (x y : T) := fun a : A => (x a <| p |> y a). @@ -2073,7 +2196,7 @@ apply FunctionalExtensionality.functional_extensionality_dep => a. exact/convA. Qed. -#[export] HB.instance Definition _ := isConvexSpace.Build (forall x : A, B x) avg1 avgI avgC avgA. +#[export] HB.instance Definition _ := isConvexSpace.Build R (forall x : A, B x) avg1 avgI avgC avgA. End depfun_convex_space. End DepfunConvexSpace. @@ -2081,7 +2204,8 @@ HB.export DepfunConvexSpace. Module PairConvexSpace. Section pair_convex_space. -Variables (A B : convType). +Context {R : realType}. +Variables (A B : convType R). Let T := (A * B)%type. Implicit Types p q : {prob R}. Let avg p (x y : T) := (x.1 <| p |> y.1, x.2 <| p |> y.2). @@ -2096,13 +2220,14 @@ Let avgA p q (d0 d1 d2 : T) : Proof. move => *; congr (pair _ _); by apply convA. Qed. #[export] HB.instance Definition _ := - isConvexSpace.Build (A * B)%type avg1 avgI avgC avgA. + isConvexSpace.Build R (A * B)%type avg1 avgI avgC avgA. End pair_convex_space. End PairConvexSpace. HB.export PairConvexSpace. Section fdist_convex_space. +Context {R : realType}. Variable A : finType. Implicit Types a b c : R.-fdist A. @@ -2130,28 +2255,28 @@ transitivity (Prob.p p * a a0 + (Prob.p p).~ * Prob.p q * b a0 + (Prob.p p).~ * by rewrite mulrDr !mulrA !addrA. transitivity (Prob.p r * Prob.p s * a a0 + (Prob.p r).~ * Prob.p s * b a0 + (Prob.p s).~ * c a0); last first. by rewrite 2!(mulrC _ (Prob.p s)) -2!mulrA -mulrDr. -rewrite -!RmultE. congr (_ + _ + _); - [by rewrite (p_is_rs p q) | | by rewrite s_of_pqE onemK]. -by rewrite !RmultE pq_is_rs. + [by rewrite (p_is_rs p q) | | by rewrite s_of_pqE onemK]. +by rewrite pq_is_rs. Qed. -HB.instance Definition _ := isConvexSpace.Build (R.-fdist A) conv1 convmm convC convA. +HB.instance Definition _ := isConvexSpace.Build R (R.-fdist A) conv1 convmm convC convA. End fdist_convex_space. Section scaled_convex_lemmas_depending_on_T_convType. Local Open Scope R_scope. Import RConvex. -Lemma scalept_conv (T : convType) (x y : R) (s : scaled T) (p : {prob R}): - 0 <= x -> 0 <= y -> +Context {R : realType}. +Lemma scalept_conv (T : convType R) (x y : R^o) (s : scaled T) (p : {prob R}): + (0 <= x)%R -> (0 <= y)%R -> scalept (x <|p|> y) s = scalept x s <|p|> scalept y s. Proof. -move=> x0 y0; rewrite scaleptDl; [|exact/mulR_ge0|exact/mulR_ge0]. +move=> x0 y0; rewrite scaleptDl; [|exact/mulr_ge0|exact/mulr_ge0]. by rewrite convptE !scaleptA. Qed. -Lemma big_scalept_conv_split (T : convType) (I : Type) (r : seq I) (P : pred I) +Lemma big_scalept_conv_split (T : convType R) (I : Type) (r : seq I) (P : pred I) (F G : I -> scaled T) (p : {prob R}) : \ssum_(i <- r | P i) (F i <|p|> G i) = (\ssum_(i <- r | P i) F i) <|p|> \ssum_(i <- r | P i) G i. @@ -2160,33 +2285,33 @@ rewrite convptE big_split /=. by do 2 rewrite [in RHS]big_morph_scalept ?scalept0//. Qed. -Lemma scalept_addRnng (T : convType) (x : scaled T) : - {morph (fun (r : Rnng) => scalept r x) : r s / addRnneg r s >-> addpt r s}. -Proof. by move=> -[] r /= /RleP Hr [] s /= /RleP Hs; exact: scaleptDl. Qed. +Lemma scalept_addRnng (T : convType R) (x : scaled T) : + {morph (fun (r : {nonneg R}%R) => scalept r%:num x) : r s / (r%:num + s%:num)%:nng%R >-> addpt r s}. +Proof. by move=> -[] r /= Hr [] s /= Hs; exact: scaleptDl. Qed. -Definition big_scaleptl (T : convType) (x : scaled T) := +Definition big_scaleptl (T : convType R) (x : scaled T) := @big_morph - (@scaled T) - Rnng - (fun r : Rnng => scalept r x) + (@scaled R T) + {nonneg R}%R + (fun r : {nonneg R}%R => scalept r%:num x) Zero - (@addpt [the realCone of scaled T]) - Rnng0 - addRnneg + (@addpt R [the realCone R of scaled T]) + 0%:nng%R + (fun x y => (x%:num + y%:num)%:nng%R) (@scalept_addRnng T x). -Lemma big_scaleptl' (T : convType) (x : scaled T) : - scalept R0 x = Zero -> +Lemma big_scaleptl' (T : convType R) (x : scaled T) : + scalept 0 x = Zero -> forall (I : Type) (r : seq I) (P : pred I) (F : I -> R), - (forall i : I, 0 <= F i) -> + (forall i : I, 0 <= F i)%R -> scalept (\sum_(i <- r | P i) F i) x = \ssum_(i <- r | P i) scalept (F i) x. Proof. move=> H I r P F H'. -transitivity (\ssum_(i <- r | P i) (fun r0 : Rnng => scalept r0 x) (mkRnng (H' i))); last reflexivity. +transitivity (\ssum_(i <- r | P i) (fun r0 : {nonneg R}%R => scalept r0%:num x) (NngNum (H' i))); last reflexivity. rewrite -big_scaleptl ?scalept0 //. congr scalept. -transitivity (\sum_(i <- r | P i) mkRnng (H' i)); first reflexivity. -apply (big_ind2 (fun x y => x = (Rnng.v y))) => //. +transitivity (\sum_(i <- r | P i) (NngNum (H' i))%:num)%R; first reflexivity. +apply (big_ind2 (fun x (y : {nonneg R}%R) => x = (y)%:num%R)) => //. by move=> x1 [v Hv] y1 y2 -> ->. Qed. @@ -2195,8 +2320,9 @@ End scaled_convex_lemmas_depending_on_T_convType. Module Convn_finType. Section def. Local Open Scope ring_scope. +Context {R : realType}. -Variables (A : convType) (T : finType) (d' : R.-fdist T) (f : T -> A). +Variables (A : convType R) (T : finType) (d' : R.-fdist T) (f : T -> A). Let n := #| T |. Definition t0 : T. @@ -2230,7 +2356,8 @@ End Convn_finType. Export Convn_finType.Exports. Section S1_Convn_finType. -Variables (A : convType) (T : finType) (d : R.-fdist T) (f : T -> A). +Context {R : realType}. +Variables (A : convType R) (T : finType) (d : R.-fdist T) (f : T -> A). Lemma S1_Convn_finType : S1 (<$>_d f) = \ssum_i scalept (d i) (S1 (f i)). Proof. @@ -2244,7 +2371,8 @@ Qed. End S1_Convn_finType. Section S1_proj_Convn_finType. -Variables (A B : convType) (prj : {affine A -> B}). +Context {R : realType}. +Variables (A B : convType R) (prj : {affine A -> B}). Variables (T : finType) (d : R.-fdist T) (f : T -> A). Lemma S1_proj_Convn_finType : @@ -2258,59 +2386,66 @@ End S1_proj_Convn_finType. : forall (A : choiceType) (B : convType), isConvexSpace0.axioms_ (A -> B) (HB_unnamed_mixin_131 A B) (HB_unnamed_mixin_130 A B)*) -HB.mixin Record isOrdered T of Choice T := { +(*HB.mixin Record isOrdered T of Choice T := { leconv : T -> T -> Prop ; leconvR : forall a, leconv a a; leconv_trans : forall b a c, leconv a b -> leconv b c -> leconv a c ; - eqconv_le : forall a b, a = b <-> leconv a b /\ leconv b a }. + eqconv_le : forall a b, a = b <-> leconv a b /\ leconv b a }.*) #[short(type=orderedConvType)] -HB.structure Definition OrderedConvexSpace := {T of isOrdered T & ConvexSpace T}. +HB.structure Definition OrderedConvexSpace d {R : realType} := {T of Order.isPOrder d T & ConvexSpace R T}. -Arguments leconv_trans {s b a c}. +(*Arguments leconv_trans {s b a c}. Notation "x <= y" := (leconv x y) : ordered_convex_scope. -Notation "x <= y <= z" := (leconv x y /\ leconv y z) : ordered_convex_scope. +Notation "x <= y <= z" := (leconv x y /\ leconv y z) : ordered_convex_scope.*) -Import RConvex. +(*Import RConvex. HB.instance Definition _ := - isOrdered.Build R Rle_refl leR_trans eqR_le. + isOrdered.Build R Rle_refl leR_trans eqR_le.*) Module FunLe. Section lefun. Local Open Scope ordered_convex_scope. -Variables (T : convType) (U : orderedConvType). +Context {R : realType}. +Variables (T : convType R) (d : Order.disp_t) (U : orderedConvType d R). -Definition lefun (f g : T -> U) := forall a, f a <= g a. +Definition lefun (f g : T -> U) := `[< forall a, (f a <= g a)%O >]. Lemma lefunR f : lefun f f. -Proof. move => *; exact: leconvR. Qed. +Proof. by move => *; apply/asboolP. Qed. Lemma lefun_trans g f h : lefun f g -> lefun g h -> lefun f h. -Proof. move => Hfg Hgh a; move : (Hfg a) (Hgh a); exact: leconv_trans. Qed. +Proof. +move=> /asboolP Hfg /asboolP Hgh. +apply/asboolP => a. +move : (Hfg a) (Hgh a); exact: le_trans. +Qed. -Lemma eqfun_le f g : f = g <-> lefun f g /\ lefun g f. +Lemma eqfun_le : antisymmetric lefun. Proof. -split; [move ->; by move: lefunR |]. -case=> Hfg Hgh; rewrite funeqE => a. -move : (Hfg a) (Hgh a) => Hfg' Hgh'; exact/eqconv_le. +move=> f g /andP[/asboolP fg /asboolP gf]. +by apply/funext => x; apply/eqP; rewrite eq_le fg gf. Qed. End lefun. End FunLe. Section fun_ordered_convex_space. -Variables (T : convType) (U : orderedConvType). +Context {R : realType}. +Variables (T : convType R) (d : Order.disp_t) (U : orderedConvType d R). Import FunLe. -HB.instance Definition _ := isOrdered.Build (T -> U) (@lefunR T U) (@lefun_trans T U) (@eqfun_le T U). +HB.instance Definition _ := Order.Le_isPOrder.Build d (T -> U) + (@lefunR R T d U) (@eqfun_le R T d U) (@lefun_trans R T d U). End fun_ordered_convex_space. Module OppositeOrderedConvexSpace. Section def. -Variable A : orderedConvType. +Context {R : realType} {d : Order.disp_t}. +Variable A : orderedConvType d R. CoInductive oppT := mkOpp : A -> oppT. @@ -2323,20 +2458,24 @@ End def. Section leopp. Local Open Scope ordered_convex_scope. -Variable A : orderedConvType. +Context {R : realType} {d : Order.disp_t}. +Variable A : orderedConvType d R. Notation T := (oppT A). Definition leopp (x y : T) := - match (x, y) with (mkOpp x', mkOpp y') => y' <= x' end. + match (x, y) with (mkOpp x', mkOpp y') => (y' <= x')%O end. Lemma leoppR x : leopp x x. -Proof. case x; exact: leconvR. Qed. +Proof. by case x => // s; apply/lexx. Qed. Lemma leopp_trans y x z : leopp x y -> leopp y z -> leopp x z. -Proof. by move: x y z => [x] [y] [z] ? yz; apply: (leconv_trans yz). Qed. +Proof. by move: x y z => [x] [y] [z] ? yz; apply: (le_trans yz). Qed. -Lemma eqopp_le x y : x = y <-> leopp x y /\ leopp y x. +Lemma eqopp_le : antisymmetric leopp. Proof. -by split; [move ->; move: leoppR |move: x y => [x'] [y'] => /eqconv_le ->]. +move=> [x] [y]; rewrite /leopp => /andP[xy yx]. +congr mkOpp. +apply/eqP. +by rewrite eq_le xy yx. Qed. End leopp. @@ -2344,7 +2483,8 @@ End leopp. Section convtype. Local Open Scope convex_scope. -Variable A : orderedConvType. +Context {R : realType} {d : Order.disp_t}. +Variable A : orderedConvType d R. Notation T := (oppT A). Implicit Types p q : {prob R}. @@ -2366,7 +2506,7 @@ Lemma avgA p q d0 d1 d2 : Proof. by case d0;case d1;case d2=>d2' d1' d0';rewrite/avg/unbox/=convA. Qed. #[export] -HB.instance Definition _ := isConvexSpace.Build T avg1 avgI avgC avgA. +HB.instance Definition _ := isConvexSpace.Build R T avg1 avgI avgC avgA. End convtype. End OppositeOrderedConvexSpace. @@ -2374,9 +2514,10 @@ HB.export OppositeOrderedConvexSpace. Section opposite_ordered_convex_space. Import OppositeOrderedConvexSpace. -Variable A : orderedConvType. +Context {R : realType} {d : Order.disp_t}. +Variable A : orderedConvType d R. -HB.instance Definition _ := isOrdered.Build (oppT A) (@leoppR A) (@leopp_trans A) (@eqopp_le A). +HB.instance Definition _ := Order.Le_isPOrder.Build d (@oppT R d A) (@leoppR R d A) (@eqopp_le R d A) (@leopp_trans R d A). End opposite_ordered_convex_space. @@ -2386,7 +2527,8 @@ Notation "'\opp{' a '}'" := (OppositeOrderedConvexSpace.mkOpp a) Section opposite_ordered_convex_space_prop. Local Open Scope ordered_convex_scope. Import OppositeOrderedConvexSpace. -Variable A : orderedConvType. +Context {R : realType} {d : Order.disp_t}. +Variable A : orderedConvType d R. Lemma conv_leoppD (a b : A) t : \opp{a} <|t|> \opp{b} = \opp{a <|t|> b}. Proof. by []. Qed. @@ -2394,7 +2536,7 @@ Proof. by []. Qed. Lemma unboxK (a : A) : unbox (\opp{a}) = a. Proof. reflexivity. Qed. -Lemma leoppP (a b : oppT A) : a <= b <-> unbox b <= unbox a. +Lemma leoppP (a b : oppT A) : (a <= b)%O <-> (unbox b <= unbox a)%O. Proof. by case a;case b=>*;rewrite !unboxK. Qed. End opposite_ordered_convex_space_prop. @@ -2402,35 +2544,37 @@ End opposite_ordered_convex_space_prop. Section convex_function_def. Local Open Scope ordered_convex_scope. -Variables (T : convType) (U : orderedConvType). +Context {R : realType} {d : Order.disp_t} . +Variables (T : convType R) (U : orderedConvType d R). Implicit Types f : T -> U. -Definition convex_function_at f a b p := f (a <| p |> b) <= f a <| p |> f b. +Definition convex_function_at f a b p := + (f (a <| p |> b) <= f a <| p |> f b)%O. (* NB(rei): move from 'I_n -> A to 'rV[A]_n? *) Definition convex_function_at_Convn f n (a : 'I_n -> T) (d : {fdist 'I_n}) := - f (<|>_d a) <= <|>_d (f \o a). + (f (<|>_d a) <= <|>_d (f \o a))%O. Definition strictly_convexf_at f := forall a b (t : {prob R}), - a <> b -> (0 < Prob.p t < 1)%coqR -> convex_function_at f a b t. + a <> b -> (0 < Prob.p t < 1)%R -> convex_function_at f a b t. Lemma convex_function_atxx f a t : convex_function_at f a a t. -Proof. rewrite /convex_function_at !convmm; exact/leconvR. Qed. +Proof. rewrite /convex_function_at !convmm; exact/lexx. Qed. End convex_function_def. -Definition convex_function (U : convType) (V : orderedConvType) (f : U -> V) := +Definition convex_function {R : realType} {d : Order.disp_t} (U : convType R) (V : orderedConvType d R) (f : U -> V) := forall a b (t : {prob R}), convex_function_at f a b t. (* see Additive in ssralg *) -HB.mixin Record isConvexFunction - (U : convType) (V : orderedConvType) (f : U -> V) := { +HB.mixin Record isConvexFunction {R : realType} {d : Order.disp_t} + (U : convType R) (V : orderedConvType d R) (f : U -> V) := { convex_functionP : convex_function f }. -HB.structure Definition ConvexFunction (U : convType) (V : orderedConvType) := - { f of isConvexFunction U V f }. +HB.structure Definition ConvexFunction {R : realType} {d : Order.disp_t} (U : convType R) (V : orderedConvType d R) := + { f of isConvexFunction R d U V f }. -Arguments convex_functionP {U V} s. +Arguments convex_functionP {R d U V} s. Notation "{ 'convex' T '->' R }" := (ConvexFunction.type T R) (at level 36, T, R at next level, @@ -2438,7 +2582,8 @@ Notation "{ 'convex' T '->' R }" := Section convex_function_prop'. Local Open Scope ordered_convex_scope. -Variable (T : convType) (U V : orderedConvType). +Context {R : realType} {d1 d2 : Order.disp_t}. +Variable (T : convType R) (U : orderedConvType d1 R) (V : orderedConvType d2 R). Lemma convex_function_sym (f : T -> U) a b : (forall t, convex_function_at f a b t) -> @@ -2449,16 +2594,16 @@ by rewrite /convex_function_at /= convC -probK (convC _ (f a)) -probK. Qed. Lemma convex_function_comp (f : {convex T -> U}) (g : {convex U -> V}) : - (forall a b t, f (a <|t|> b) <= f a <|t|> f b -> - g (f (a <|t|> b)) <= g (f a <|t|> f b)) -> + (forall a b t, (f (a <|t|> b) <= f a <|t|> f b)%O -> + (g (f (a <|t|> b)) <= g (f a <|t|> f b))%O) -> convex_function (g \o f). Proof. move=> fg a b t; have := convex_functionP g (f a) (f b) t. -by move=> Hg; apply/(leconv_trans _ Hg)/fg/convex_functionP. +by move=> Hg; apply/(le_trans _ Hg)/fg/convex_functionP. Qed. Lemma convex_function_comp' (f : {convex T -> U}) (g : {convex U -> V}) - (g_monotone : forall x y, x <= y -> g x <= g y) : + (g_monotone : forall x y, (x <= y)%O -> (g x <= g y)%O) : convex_function (g \o f). Proof. by apply convex_function_comp => // *; exact: g_monotone. Qed. @@ -2466,13 +2611,14 @@ End convex_function_prop'. Section convex_in_both. Local Open Scope ordered_convex_scope. -Variables (T U : convType) (V : orderedConvType) (f : T -> U -> V). +Context {R : realType} {d : Order.disp_t}. +Variables (T U : convType R) (V : orderedConvType d R) (f : T -> U -> V). Definition convex_in_both := convex_function (uncurry f). Lemma convex_in_bothP : convex_in_both <-> forall a0 a1 b0 b1 t, - f (a0 <| t |> a1) (b0 <| t |> b1) <= f a0 b0 <| t |> f a1 b1. + (f (a0 <| t |> a1) (b0 <| t |> b1) <= f a0 b0 <| t |> f a1 b1)%O. Proof. split => [H a0 a1 b0 b1 t | H]; first by move: (H (a0,b0) (a1,b1) t); rewrite /convex_function_at /uncurry. @@ -2485,7 +2631,8 @@ Section biconvex_function. Local Open Scope ordered_convex_scope. Section definition. -Variables (T U : convType) (V : orderedConvType) (f : T -> U -> V). +Context {R : realType} {d : Order.disp_t}. +Variables (T U : convType R) (V : orderedConvType d R) (f : T -> U -> V). Definition biconvex_function := (forall a, convex_function (f a)) /\ (forall b, convex_function (f^~ b)). (* @@ -2505,24 +2652,42 @@ Qed. *) End definition. +(* TODO: move *) +Lemma prob_invn {R : realType} (m : nat) : + (0 <= ((1 + m)%:R^-1 : R) <= 1)%mcR. +Proof. +apply/andP; split. + by rewrite invr_ge0. +by rewrite invf_le1// natrD lerDl. +Qed. + +Canonical probinvn {R : realType} (n : nat) := + Eval hnf in @Prob.mk _ ((1 + n)%:R^-1) (@prob_invn R n). + Section counterexample. Local Open Scope R_scope. Import RConvex. +Context {R : realType}. + +HB.instance Definition _ := Order.POrder.on R^o. +HB.instance Definition _ := OrderedConvexSpace.on R^o. + Example biconvex_is_not_convex_in_both : - exists f : R -> R -> R, @biconvex_function R R R f /\ ~ convex_in_both f. + exists f : R -> R -> R, @biconvex_function R _ R^o R^o R^o f /\ ~ @convex_in_both R _ R^o R^o R^o f. Proof. -exists Rmult; split. +exists GRing.mul; split. by split => [a b0 b1 t | b a0 a1 t]; rewrite /convex_function_at /=; rewrite avgRE; - [rewrite avgR_mulDr|rewrite avgR_mulDl]; apply/RleP; rewrite lexx. -move/convex_in_bothP/(_ (-1)%coqR 1%coqR 1%coqR (-1)%coqR (probinvn 1)). -rewrite /leconv /probinvn /= 3!avgRE /=. -set a := / (1 + 1)%:R. -rewrite !(mul1R,mulR1,mulRN1) -oppRD (RplusE a a.~) onemKC. -rewrite (_ : - a + a.~ = 0)%coqR; last first. - by rewrite /a/onem addRCA -oppRD -div1R eps2 addRN. -by rewrite mul0R leR_oppr oppR0 leRNgt; exact. + [rewrite avgR_mulDr|rewrite avgR_mulDl]; rewrite lexx. +move/convex_in_bothP/(_ (-1)%R 1%R 1%R (-1)%R). +move=> /(_ (probinvn 1)). +rewrite /probinvn /= 3!avgRE /=. +set a := (1 + 1)%:R^-1%R. +rewrite !(mul1r,mulr1,mulrN1) -opprD onemKC. +rewrite (_ : - a + a.~ = 0)%R; last first. + by rewrite /a/onem addrCA -opprD -div1r -splitr subrr. +by rewrite mul0r lerNr oppr0 Order.TotalTheory.leNgt ltr01. Qed. End counterexample. @@ -2530,13 +2695,14 @@ End biconvex_function. Section concave_function_def. Local Open Scope ordered_convex_scope. -Variables (A : convType) (B : orderedConvType). +Context {R : realType} {d : Order.disp_t}. +Variables (A : convType R) (B : orderedConvType d R). Implicit Types f : A -> B. -Definition concave_function_at f a b t := @convex_function_at A _ +Definition concave_function_at f a b t := @convex_function_at R d A _ (fun a => \opp{f a}) a b t. -Definition concave_function_at' f a b t := (f a <| t |> f b <= f (a <| t |> b)). +Definition concave_function_at' f a b t := (f a <| t |> f b <= f (a <| t |> b))%O. Definition strictly_concavef_at f := forall a b (t : {prob R}), - a <> b -> (0 < Prob.p t < 1)%coqR -> concave_function_at f a b t. + a <> b -> (0 < Prob.p t < 1)%R -> concave_function_at f a b t. Lemma concave_function_at'P f a b t : concave_function_at' f a b t <-> concave_function_at f a b t. Proof. @@ -2545,17 +2711,18 @@ by rewrite conv_leoppD leoppP. Qed. End concave_function_def. -Definition concave_function (U : convType) (V : orderedConvType) (f : U -> V) := +Definition concave_function {R : realType} {d : Order.disp_t} (U : convType R) (V : orderedConvType d R) (f : U -> V) := forall a b (t : {prob R}), concave_function_at f a b t. -HB.mixin Record isConcaveFunction - (U : convType) (V : orderedConvType) (f : U -> V) := { +HB.mixin Record isConcaveFunction {R : realType} {d : Order.disp_t} + (U : convType R) (V : orderedConvType d R) (f : U -> V) := { concave_functionP : concave_function f }. -HB.structure Definition ConcaveFunction (U : convType) (V : orderedConvType) := - { f of isConcaveFunction U V f }. +HB.structure Definition ConcaveFunction {R : realType} {d : Order.disp_t} + (U : convType R) (V : orderedConvType d R) := + { f of isConcaveFunction R d U V f }. -Arguments concave_functionP {U V} s. +Arguments concave_functionP {R d U V} s. Notation "{ 'concave' T '->' R }" := (ConvexFunction.type T R) (at level 36, T, R at next level, @@ -2563,74 +2730,80 @@ Notation "{ 'concave' T '->' R }" := Section concave_function_prop. Local Open Scope ordered_convex_scope. -Variable (T : convType) (V : orderedConvType). +Context {R : realType} {d : Order.disp_t}. +Variable (T : convType R) (V : orderedConvType d R). Lemma concave_function_atxx (f : T -> V) a t : concave_function_at f a a t. Proof. exact: convex_function_atxx. Qed. Section Rprop. -Implicit Types f : T -> R. +Implicit Types f : T -> R^o. Lemma R_convex_function_atN f a b t : - concave_function_at f a b t -> convex_function_at (fun x => - f x)%coqR a b t. -Proof. by rewrite /convex_function_at /leconv /= avgR_oppD leR_oppl oppRK. Qed. + concave_function_at f a b t -> convex_function_at (fun x => - f x)%R a b t. +Proof. by rewrite /convex_function_at /= avgR_oppD lerNl opprK. Qed. Lemma R_concave_function_atN f a b t : - convex_function_at f a b t -> concave_function_at (fun x => - f x)%coqR a b t. + convex_function_at f a b t -> concave_function_at (fun x => - f x)%R a b t. Proof. rewrite /concave_function_at /convex_function_at. -by rewrite /leconv/= /leopp/= avgR_oppD /leconv/= leR_oppl oppRK. +rewrite /=. +rewrite /Order.le/= /leopp/=. (* TODO: clean*) +rewrite avgR_oppD. +by rewrite lerNl opprK. Qed. Lemma R_convex_functionN f : - concave_function f -> convex_function (fun x => - f x)%coqR. + concave_function f -> convex_function (fun x => - f x)%R. Proof. by move=> H a b t; exact/R_convex_function_atN/H. Qed. Lemma R_concave_functionN f : - convex_function f -> concave_function (fun x => - f x)%coqR. + convex_function f -> concave_function (fun x => - f x)%R. Proof. by move=> H a b t; exact/R_concave_function_atN/H. Qed. Lemma RNconvex_function_at f a b t : - concave_function_at (fun x => - f x)%coqR a b t -> convex_function_at f a b t. -Proof. by move/(R_convex_function_atN); rewrite/convex_function_at !oppRK. Qed. + concave_function_at (fun x => - f x)%R a b t -> convex_function_at f a b t. +Proof. by move/(R_convex_function_atN); rewrite/convex_function_at !opprK. Qed. Lemma RNconcave_function_at f a b t : - convex_function_at (fun x => - f x)%coqR a b t -> concave_function_at f a b t. + convex_function_at (fun x => - f x)%R a b t -> concave_function_at f a b t. Proof. move/(R_concave_function_atN). -by rewrite/concave_function_at/convex_function_at !oppRK. +by rewrite/concave_function_at/convex_function_at !opprK. Qed. Lemma RNconvex_function f : - concave_function (fun x => - f x)%coqR -> convex_function f. + concave_function (fun x => - f x)%R -> convex_function f. Proof. move=> H a b t; exact/RNconvex_function_at/H. Qed. Lemma RNconcave_function f : - convex_function (fun x => - f x)%coqR -> concave_function f. + convex_function (fun x => - f x)%R -> concave_function f. Proof. move=> H a b t; exact/RNconcave_function_at/H. Qed. End Rprop. Section Rprop2. -Lemma R_convex_functionB f (g : T -> R) : +Lemma R_convex_functionB (f g : T -> R^o) : convex_function f -> concave_function g -> - convex_function (fun x => f x - g x)%coqR. + convex_function (fun x => f x - g x)%R. Proof. move=> Hf Hg p q t. -rewrite /convex_function_at /= avgRE 2!mulRBr addRAC addRA. -rewrite -addR_opp -addRA; apply: (leR_add _ _ _ _ (Hf _ _ _)). -by rewrite -2!mulRN addRC; exact: (R_convex_functionN Hg). +rewrite /convex_function_at /= avgRE 2!mulrBr addrAC addrA. +rewrite -addrA lerD//. + have := Hf p q t. + by rewrite /convex_function_at => ->. +by rewrite -2!mulrN addrC; exact: (R_convex_functionN Hg). Qed. -Lemma R_concave_functionB f (g : T -> R) : +Lemma R_concave_functionB (f g : T -> R^o) : concave_function f -> convex_function g -> - concave_function (fun x => f x - g x)%coqR. + concave_function (fun x => f x - g x)%R. Proof. move=> Hf Hg. -rewrite (_ : (fun _ => _) = (fun x => - (g x - f x)))%coqR; last first. - by apply/funext => x; rewrite oppRB. +rewrite (_ : (fun _ => _) = (fun x => - (g x - f x)))%R; last first. + by apply/funext => x; rewrite opprB. exact/R_concave_functionN/R_convex_functionB. Qed. @@ -2639,23 +2812,25 @@ End Rprop2. End concave_function_prop. Section affine_function_prop. -Variables (T : convType) (U : orderedConvType). +Context {R : realType} {d : Order.disp_t}. +Variables (T : convType R) (U : orderedConvType d R). Lemma affine_functionP (f : T -> U) : affine f <-> convex_function f /\ concave_function f. Proof. -split => [H | [H1 H2] p q t]; last first. - by rewrite eqconv_le; split; [exact/H1|exact/H2]. +split => [H | [H1 H2] t p q]; last first. + by apply/eqP; rewrite eq_le; apply/andP; split; [exact/H1|exact/H2]. split => p q t. -- by rewrite /convex_function_at H; exact/leconvR. -- by rewrite /concave_function_at/convex_function_at H; exact/leconvR. +- by rewrite /convex_function_at H. +- by rewrite /concave_function_at/convex_function_at H. Qed. End affine_function_prop. Section affine_function_image. Local Open Scope classical_set_scope. -Variables T U : convType. +Context {R : realType}. +Variables T U : convType R. Proposition image_preserves_convex_hull (f : {affine T -> U}) (Z : set T) : f @` (hull Z) = hull (f @` Z). @@ -2740,6 +2915,7 @@ End linear_function_image0. Section linear_function_image. Local Open Scope classical_set_scope. Local Open Scope ring_scope. +Context {R : realType}. Variables (T U : lmodType R). Import LmoduleConvex. (* TODO: find how to speak about multilinear maps. *) @@ -2755,9 +2931,9 @@ set xx := [set a + b | a in hull A & b in hull B]. by move: (hull_is_convex A)=>/asboolP; apply. exists (bx <|p|> by')=>//. by move: (hull_is_convex B)=>/asboolP; apply. - pose xx' : {convex_set T} := @ConvexSet.Pack T xx (@ConvexSet.Class _ _ (isConvexSet.Build _ _ conv)). - apply: (@hull_sub_convex _ _ xx'). - by apply/image2_subset; exact (@subset_hull _ _). + pose xx' : {convex_set T} := @ConvexSet.Pack R T xx (@ConvexSet.Class R _ _ (isConvexSet.Build R _ _ conv)). + apply: (@hull_sub_convex R _ _ xx'). + by apply/image2_subset; exact (@subset_hull R _ _). move=>x [a [na [ga [da [gaA ->]]]]] [b [nb [gb [db [gbB ->]]]]] <-. rewrite avgnr_add. exists (na * nb)%nat, @@ -2785,8 +2961,9 @@ Qed. End linear_function_image. Section R_affine_function_prop. -Variables (T : convType) (f : T -> R). -Lemma R_affine_functionN : affine f -> affine (fun x => - f x)%coqR. +Context {R : realType}. +Variables (T : convType R) (f : T -> R^o). +Lemma R_affine_functionN : affine f -> affine (fun x => - f x)%R. Proof. move/affine_functionP => [H1 H2]; rewrite affine_functionP. split => //; [exact/R_convex_functionN|exact/R_concave_functionN]. @@ -2794,7 +2971,8 @@ Qed. End R_affine_function_prop. Section convex_function_in_def. -Variables (T : convType) (U : orderedConvType) (D : {convex_set T}) (f : T -> U). +Context {R : realType} {d : Order.disp_t}. +Variables (T : convType R) (U : orderedConvType d R) (D : {convex_set T}) (f : T -> U). Definition convex_function_in := forall a b p, a \in D -> b \in D -> convex_function_at f a b p. @@ -2827,84 +3005,91 @@ TODO: see convex_type.v *) Section convex_set_R. +Context {R : realType}. -Definition Rpos_interval : set R := (fun x => 0 < x)%coqR. +Definition Rpos_interval : set R^o := (fun x => 0 < x)%R. Lemma Rpos_convex : is_convex_set Rpos_interval. Proof. apply/asboolP => x y t Hx Hy. have [->|Ht0] := eqVneq t 0%:pr; first by rewrite conv0. -apply addR_gt0wl; first by apply mulR_gt0 => //; exact/RltP/prob_gt0. -apply mulR_ge0 => //; exact: ltRW. +rewrite /Rpos_interval. +apply: ltr_wpDr. + apply: mulr_ge0 => //. + exact/ltW. +apply: mulr_gt0 => //. +by apply/prob_gt0 => /=. Qed. (*#[local]*) -HB.instance Definition _ := isConvexSet.Build R Rpos_interval Rpos_convex. +HB.instance Definition _ := isConvexSet.Build _ R^o Rpos_interval Rpos_convex. -Definition Rnonneg_interval : set R := (fun x => 0 <= x)%coqR. +Definition Rnonneg_interval : set R^o := (fun x => 0 <= x)%R. Lemma Rnonneg_convex : is_convex_set Rnonneg_interval. -Proof. apply/asboolP=> x y t Hx Hy; apply addR_ge0; exact/mulR_ge0. Qed. +Proof. apply/asboolP=> x y t Hx Hy; apply addr_ge0; exact/mulr_ge0. Qed. (*#[local]*) -HB.instance Definition _ := isConvexSet.Build R Rnonneg_interval Rnonneg_convex. - -Lemma open_interval_convex a b (Hab : (a < b)%coqR) : - is_convex_set (fun x => a < x < b)%coqR. -Proof. -apply/asboolP => x y t [xa xb] [ya yb]. -have [->|t0] := eqVneq t 0%:pr; first by rewrite conv0. -have [->|t1] := eqVneq t 1%:pr; first by rewrite conv1. -apply conj. -- rewrite -[X in (X < Prob.p t * x + (Prob.p t).~ * y)%coqR]mul1r -(onemKC (Prob.p t)). - rewrite (mulrDl _ _ a) -RplusE. - apply ltR_add; rewrite ltR_pmul2l //; [exact/RltP/prob_gt0 | exact/RltP/onem_gt0/prob_lt1]. +HB.instance Definition _ := isConvexSet.Build R R^o Rnonneg_interval Rnonneg_convex. + +Lemma open_interval_convex (a b : R^o) (Hab : (a < b)%R) : + is_convex_set (fun x => a < x < b)%R. +Proof. +apply/asboolP => x y t /andP[xa xb] /andP[ya yb]. +have [->/=|t0] := eqVneq t 0%:pr. + by rewrite conv0 ya. +have [->|t1] := eqVneq t 1%:pr. + by rewrite conv1 xa. +apply/andP; split. +- rewrite -[X in (X < Prob.p t * x + (Prob.p t).~ * y)%R]mul1r -(onemKC (Prob.p t)). + rewrite (mulrDl _ _ a). + by rewrite ltrD// ltr_pM2l//; [exact/prob_gt0 | exact/onem_gt0/prob_lt1]. - (*rewrite -[X in (_ + _ < X)%coqR]mul1R -(onemKC t) mulRDl.*) -rewrite -[X in (_ + _ < X)%coqR]mul1r. +rewrite -[X in (_ + _ < X)%R]mul1r. rewrite -(onemKC (Prob.p t)). -rewrite mulrDl. - apply ltR_add; rewrite ltR_pmul2l //; [exact/RltP/prob_gt0 | exact/RltP/onem_gt0/prob_lt1]. +by rewrite mulrDl ltrD// ltr_pM2l//; [exact/prob_gt0 | exact/onem_gt0/prob_lt1]. Qed. -Definition uniti : set R := (fun x => 0 < x < 1)%coqR. +Definition uniti : set R^o := (fun x => 0 < x < 1)%R. Lemma open_unit_interval_convex : is_convex_set uniti. Proof. exact: open_interval_convex. Qed. -HB.instance Definition _ := isConvexSet.Build R uniti open_unit_interval_convex. +HB.instance Definition _ := isConvexSet.Build R R^o uniti open_unit_interval_convex. End convex_set_R. Section convex_function_R. +Context {R : realType}. -Implicit Types f : R -> R. +Implicit Types f : R^o -> R^o. Lemma concave_function_atN f x y t : concave_function_at f x y t -> - forall k, (0 <= k)%coqR -> concave_function_at (fun x => f x * k)%coqR x y t. + forall k, (0 <= k)%R -> concave_function_at (fun x => f x * k)%R x y t. Proof. move=> H k k0; rewrite /concave_function_at /convex_function_at. rewrite conv_leoppD leoppP avgRE. -rewrite /leconv /= -avgR_mulDl. -exact: leR_wpmul2r. +rewrite /= -avgR_mulDl. +exact: ler_wpM2r. Qed. Lemma convexf_at_onem x y (t : {prob R}) f : (0 < x -> 0 < y -> x < y -> - convex_function_at f x y t -> convex_function_at f y x (Prob.p t).~%:pr)%coqR. + convex_function_at f x y t -> convex_function_at f y x (Prob.p t).~%:pr)%R. Proof. move=> x0 y0 xy H; rewrite /convex_function_at. -rewrite [in X in leconv _ X]avgRE /= onemK addRC. +rewrite [in X in (_ <= X)%R]avgRE /= onemK addrC. rewrite /convex_function_at !avgRE in H. -rewrite avgRE /= onemK addRC. -by apply: (leR_trans H); rewrite addRC; apply/RleP; rewrite lexx. +rewrite avgRE /= onemK addrC. +by apply: (le_trans H); rewrite addrC lexx. Qed. Lemma concavef_at_onem x y (t : {prob R}) f : (0 < x -> 0 < y -> x < y -> - concave_function_at f x y t -> concave_function_at f y x (Prob.p t).~%:pr)%coqR. + concave_function_at f x y t -> concave_function_at f y x (Prob.p t).~%:pr)%R. Proof. move=>x0 y0 xy; rewrite/concave_function_at/convex_function_at. rewrite !conv_leoppD !leoppP/=. rewrite !avgRE /= onemK. -by rewrite addRC [in X in leconv _ X -> _]addRC. +by rewrite addrC [in X in (_ <= X)%R -> _]addrC. Qed. End convex_function_R. @@ -2922,152 +3107,184 @@ Now this is an equivalent condition to the convexity of f. *) (* ref: http://www.math.wisc.edu/~nagel/convexity.pdf *) + +From mathcomp Require Import topology normedtype derive. +Import Order.TTheory GRing.Theory Num.Def Num.Theory. +Import numFieldTopology.Exports. + Section twice_derivable_convex. +Context {R : realType}. +Local Open Scope ring_scope. +Local Open Scope classical_set_scope. + +Variables (f : R^o -> R^o) (a b : R^o). +Let I := fun x0 : R => (a <= x0 <= b)%R. -Variables (f : R -> R) (a b : R). -Let I := fun x0 => (a <= x0 <= b)%coqR. -Hypothesis HDf : pderivable f I. -Variable Df : R -> R. -Hypothesis DfE : forall x (Hx : I x), Df x = derive_pt f x (HDf Hx). -Hypothesis HDDf : pderivable Df I. -Variable DDf : R -> R. -Hypothesis DDfE : forall x (Hx : I x), DDf x = derive_pt Df x (HDDf Hx). -Hypothesis DDf_ge0 : forall x, I x -> (0 <= DDf x)%coqR. +Hypothesis HDf : forall x, I x -> derivable f x 1. -Definition L (x : R) := (f a + (x - a) / (b - a) * (f b - f a))%coqR. +Let Df : R^o -> R^o := 'D_1 f. +Let DDf : R^o -> R^o := 'D_1 Df. -Hypothesis ab : (a < b)%coqR. +Hypothesis HDDf : forall x, I x -> derivable Df x 1. -Lemma LE x : L x = ((b - x) / (b - a) * f a + (x - a) / (b - a) * f b)%coqR. +Hypothesis DDf_ge0 : forall x, a < x < b -> 0 <= DDf x. + +Definition L (x : R) := (f a + (x - a) / (b - a) * (f b - f a))%R. + +Hypothesis ab : (a < b)%R. + +Lemma LE x : L x = ((b - x) / (b - a) * f a + (x - a) / (b - a) * f b)%R. Proof. -rewrite /L mulRBr [in LHS]addRA addRAC; congr (_ + _)%coqR. -rewrite addR_opp -{1}(mul1R (f a)) -mulRBl; congr (_ * _)%coqR. -rewrite -(mulRV (b - a)); last by rewrite subR_eq0'; exact/gtR_eqF. -by rewrite -mulRBl -addR_opp oppRB addRA subRK addR_opp. +rewrite /L mulrBr [in LHS]addrA addrAC; congr (_ + _)%R. +rewrite -{1}(mul1r (f a)) -mulrBl; congr (_ * _)%R. +rewrite -(@mulfV _ (b - a)%R); last first. + by rewrite subr_eq0 gt_eqF//. +by rewrite -mulrBl opprB addrA subrK. Qed. -Lemma convexf_ptP : (forall x, a <= x <= b -> 0 <= L x - f x)%coqR -> - forall t : {prob R}, convex_function_at f a b t. +Let convexf_ptP : (forall x, a <= x <= b -> 0 <= L x - f x) -> + forall t, f (a <| t |> b) <= f a <| t |> f b. Proof. move=> H t; rewrite /convex_function_at. -set x := (Prob.p t * a + (Prob.p t).~ * b)%coqR. -have : (a <= x <= b)%coqR. - rewrite /x; split. - - apply (@leR_trans (Prob.p t * a + (Prob.p t).~ * a)). - rewrite -mulRDl addRCA addR_opp subRR addR0 mul1R. - by apply/RleP; rewrite lexx. +set x := (Prob.p t * a + (Prob.p t).~ * b)%R. +have : (a <= x <= b)%R. + rewrite /x; apply/andP; split. + - apply (@le_trans _ _ (Prob.p t * a + (Prob.p t).~ * a)). + by rewrite -mulrDl addrCA subrr addr0 mul1r lexx. have [->|t1] := eqVneq t 1%:pr. - by rewrite mul1R onem1 2!mul0R; exact/RleP. - rewrite leR_add2l; apply leR_wpmul2l => //; exact/ltRW. - - apply (@leR_trans (Prob.p t * b + (Prob.p t).~ * b)); last first. - rewrite -mulRDl addRCA addR_opp subRR addR0 mul1R. - by apply/RleP; rewrite lexx. - rewrite leR_add2r; apply leR_wpmul2l => //; exact/ltRW. -move/H; rewrite subR_ge0 => /leR_trans; apply. + by rewrite mul1r onem1 2!mul0r. + rewrite lerD2l; apply ler_wpM2l => //; exact/ltW. + - apply (@le_trans _ _ (Prob.p t * b + (Prob.p t).~ * b)); last first. + by rewrite -mulrDl addrCA subrr addr0 mul1r lexx. + by rewrite lerD2r; apply: ler_wpM2l => //; exact/ltW. +move/H; rewrite subr_ge0 => /le_trans; apply. rewrite LE //. -have -> : ((b - x) / (b - a) = Prob.p t)%coqR. - rewrite /x -addR_opp oppRD addRCA mulRBl mul1R oppRB (addRCA b). - rewrite addR_opp subRR addR0 -mulRN addRC -mulRDr addR_opp. - rewrite /Rdiv -mulRA mulRV ?mulR1 // subR_eq0'; exact/gtR_eqF. -have -> : ((x - a) / (b - a) = (Prob.p t).~)%coqR. - rewrite /x -addR_opp addRAC -{1}(oppRK a) mulRN -mulNR -{2}(mul1R (- a)%coqR). - rewrite -mulRDl (addRC _ R1) addR_opp -mulRDr addRC addR_opp. - rewrite /Rdiv -mulRA mulRV ?mulR1 // subR_eq0'; exact/gtR_eqF. -by apply/RleP; rewrite lexx. +have -> : ((b - x) / (b - a) = Prob.p t)%R. + rewrite /x opprD addrCA mulrBl mul1r opprB (addrCA b). + rewrite subrr addr0 -mulrN addrC -mulrDr. + by rewrite -mulrA mulfV ?mulr1 // subr_eq0 gt_eqF//. +have -> : ((x - a) / (b - a) = (Prob.p t).~)%R. + rewrite /x addrAC -{1}(opprK a) mulrN -mulNr -{2}(mul1r (- a)%R). + rewrite -mulrDl (addrC _ 1%R) -mulrDr addrC. + rewrite -mulrA (addrC _ b) mulfV ?mulr1 ?subr_eq0 ?gt_eqF//. + by rewrite addrC. +by rewrite lexx. Qed. +From mathcomp Require Import interval. + Lemma second_derivative_convexf_pt : forall t : {prob R}, convex_function_at f a b t. Proof. -have note1 : forall x, R1 = ((x - a) / (b - a) + (b - x) / (b - a))%coqR. - move=> x; rewrite -mulRDl addRC addRA subRK addR_opp mulRV // subR_eq0'. - exact/gtR_eqF. -have step1 : forall x, f x = ((x - a) / (b - a) * f x + (b - x) / (b - a) * f x)%coqR. - by move=> x; rewrite -mulRDl -note1 mul1R. +have note1 : forall x, 1%R = ((x - a) / (b - a) + (b - x) / (b - a))%R. + by move=> x; rewrite -mulrDl addrC addrA subrK mulfV // subr_eq0 gt_eqF. +have step1 : forall x, f x = ((x - a) / (b - a) * f x + (b - x) / (b - a) * f x)%R. + by move=> x; rewrite -mulrDl -note1 mul1r. apply convexf_ptP => // x axb. rewrite /L. -case: axb. - rewrite leR_eqVlt => -[-> _|]. - by rewrite /L subRR div0R mul0R addR0 subRR. +case/andP: axb. + rewrite le_eqVlt => /predU1P[-> _|]. + by rewrite /L subrr mul0r mul0r addr0 subrr. move=> ax. -rewrite leR_eqVlt => -[->|xb]. - rewrite /L /Rdiv mulRV ?mul1R; last by rewrite subR_eq0'; exact/gtR_eqF. - by rewrite addRC subRK subRR. +rewrite le_eqVlt => -/predU1P[->|xb]. + rewrite /L mulfV ?mul1r; last by rewrite subr_eq0 gt_eqF. + by rewrite addrCA subrr addr0 subrr. have {step1}step2 : (L x - f x = (x - a) * (b - x) / (b - a) * ((f b - f x) / (b - x)) - - (b - x) * (x - a) / (b - a) * ((f x - f a) / (x - a)))%coqR. + (b - x) * (x - a) / (b - a) * ((f x - f a) / (x - a)))%R. rewrite {1}step1 {step1}. - rewrite -addR_opp oppRD addRA addRC addRA. + rewrite opprD addrA addrC addrA. rewrite LE //. - rewrite {1}/Rdiv -(mulRN _ (f x)) -/(Rdiv _ _). - rewrite addRA -mulRDr (addRC _ (f a)) (addR_opp (f a)). - rewrite -mulRN -addRA -mulRDr (addR_opp (f b)). - rewrite addRC. - rewrite -(oppRK (f a - f x)) mulRN addR_opp oppRB. - congr (_ + _)%coqR. - - rewrite {1}/Rdiv -!mulRA; congr (_ * _)%coqR; rewrite mulRCA; congr (_ * _)%coqR. - rewrite mulRCA mulRV ?mulR1 // subR_eq0'; exact/gtR_eqF. - - rewrite -!mulNR -!mulRA; congr (_ * _)%coqR; rewrite mulRCA; congr (_ * _)%coqR. - rewrite mulRCA mulRV ?mulR1 // subR_eq0'; exact/gtR_eqF. -have [c2 [Ic2 Hc2]] : exists c2, (x < c2 < b /\ (f b - f x) / (b - x) = Df c2)%coqR. - have H : pderivable f (fun x0 => x <= x0 <= b)%coqR. - move=> z [z1 z2]; apply HDf; split => //. - apply (@leR_trans x) => //; exact: ltRW. - case: (@MVT_cor1_pderivable x b f H xb) => c2 [Ic2 [H1 H2]]. - exists c2; split => //. - rewrite H1 /Rdiv -mulRA mulRV ?mulR1; last first. - by rewrite subR_eq0'; exact/gtR_eqF. - rewrite DfE; last by move=> ?; exact: proof_derive_irrelevance. - split. - apply (@leR_trans x); [exact/ltRW | by case: Ic2 H1]. - by case: H2 => _ /ltRW. -have [c1 [Ic1 Hc1]] : exists c1, (a < c1 < x /\ (f x - f a) / (x - a) = Df c1)%coqR. - have H : pderivable f (fun x0 => a <= x0 <= x)%coqR. - move=> z [z1 z2]; apply HDf; split => //. - apply (@leR_trans x) => //; exact: ltRW. - case: (@MVT_cor1_pderivable a x f H ax) => c1 [Ic1 [H1 H2]]. + rewrite -(mulrN _ (f x)). + rewrite addrA -mulrDr (addrC _ (f a)). + rewrite -mulrN -addrA -mulrDr. + rewrite addrC. + rewrite -(opprK (f a - f x)) mulrN opprB. + congr (_ + _)%R. + - rewrite -!mulrA; congr (_ * _)%R; rewrite mulrCA; congr (_ * _)%R. + by rewrite mulrCA mulfV ?mulr1 // subr_eq0 gt_eqF. + - rewrite -!mulNr -!mulrA; congr (_ * _)%R; rewrite mulrCA; congr (_ * _)%R. + by rewrite mulrCA mulfV ?mulr1 // subr_eq0 gt_eqF. +have [c2 [Ic2 Hc2]] : exists c2, (x < c2 < b /\ (f b - f x) / (b - x) = Df c2)%R. + have H : forall x0, (x <= x0 <= b)%R -> derivable f x0 1. + move=> z /andP[z1 z2]; apply: HDf; apply/andP; split => //. + by apply (@le_trans _ _ x) => //; exact: ltW. + have {}H : forall x0 : R^o, x0 \in `]x, b[%R -> is_derive x0 1 f (Df x0). + move=> x0; rewrite in_itv/= => /andP[xx0 x0b]. + apply: DeriveDef => //. + apply: HDf => //. + by rewrite /I (ltW x0b) andbT ltW// (lt_trans ax). + have cf : {within `[x, b], continuous f}. + apply: derivable_within_continuous => y. + rewrite in_itv/= => /andP[ay yb]. + by apply: HDf; rewrite /I yb andbT (le_trans _ ay)// ltW. + have [c2 Ic2 H1] := MVT xb H cf. + exists c2; split. + rewrite in_itv/= in Ic2. + case/andP: Ic2 => ac2 ->. + by rewrite andbT (le_lt_trans _ ac2). + rewrite H1 -mulrA mulfV ?mulr1//. + by rewrite subr_eq0 gt_eqF. +have [c1 [Ic1 Hc1]] : exists c1, (a < c1 < x /\ (f x - f a) / (x - a) = Df c1)%R. + have H : forall x0, (a <= x0 <= x)%R -> derivable f x0 1. + move=> z /andP[z1 z2]; apply HDf; apply/andP; split => //. + by apply (@le_trans _ _ x) => //; exact: ltW. + have {}H : forall x0 : R^o, x0 \in `]a, x[%R -> is_derive x0 1 f (Df x0). + move=> x0; rewrite in_itv/= => /andP[xx0 x0b]. + apply: DeriveDef => //. + apply: HDf => //. + by rewrite /I (ltW xx0)/= (le_trans (ltW x0b))// ltW. + have cf : {within `[a, x], continuous f}. + apply: derivable_within_continuous => y. + rewrite in_itv/= => /andP[ay yb]. + by apply: HDf; rewrite /I ay/= (le_trans yb)// ltW. + have [c1 Ic1 H1] := MVT ax H cf. exists c1; split => //. - rewrite H1 /Rdiv -mulRA mulRV ?mulR1; last first. - by rewrite subR_eq0'; exact/gtR_eqF. - rewrite DfE; last by move=> ?; exact: proof_derive_irrelevance. - split. - - by case: H2 => /ltRW. - - apply (@leR_trans x). - by case: H2 => _ /ltRW. - apply (@leR_trans c2); apply/ltRW; by case: Ic2. -have c1c2 : (c1 < c2)%coqR by apply (@ltR_trans x); [case: Ic1 | case: Ic2]. + rewrite H1 -mulrA mulfV ?mulr1//. + by rewrite subr_eq0 gt_eqF. +have c1c2 : (c1 < c2)%R by apply (@lt_trans _ _ x); [case/andP: Ic1 | case/andP: Ic2]. have {step2 Hc1 Hc2}step3 : (L x - f x = - (b - x) * (x - a) * (c2 - c1) / (b - a) * ((Df c2 - Df c1) / (c2 - c1)))%coqR. - rewrite {}step2 Hc2 Hc1 (mulRC (x - a)%coqR) -mulRBr {1}/Rdiv -!mulRA. - congr (_ * (_ * _))%coqR; rewrite mulRCA; congr (_ * _)%coqR. - rewrite mulRCA mulRV ?mulR1 // subR_eq0'; by move/gtR_eqF : c1c2. -have [d [Id H]] : exists d, (c1 < d < c2 /\ (Df c2 - Df c1) / (c2 - c1) = DDf d)%coqR. - have H : pderivable Df (fun x0 => c1 <= x0 <= c2)%coqR. - move=> z [z1 z2]; apply HDDf; split => //. - - apply (@leR_trans c1) => //; by case: Ic1 => /ltRW. - - apply (@leR_trans c2) => //; by case: Ic2 => _ /ltRW. - case: (@MVT_cor1_pderivable c1 c2 Df H c1c2) => d [Id [H1 H2]]. - exists d; split => //. - rewrite H1 /Rdiv -mulRA mulRV ?mulR1; last first. - by rewrite subR_eq0'; exact/gtR_eqF. - rewrite DDfE; last by move=> ?; exact: proof_derive_irrelevance. - split. - - apply (@leR_trans c1); last by case: Id H1. - by apply/ltRW; case: Ic1. - - apply (@leR_trans c2); last by case: Ic2 => _ /ltRW. - by case: H2 => _ /ltRW. + (b - x) * (x - a) * (c2 - c1) / (b - a) * ((Df c2 - Df c1) / (c2 - c1)))%R. + rewrite {}step2 Hc2 Hc1 (mulrC (x - a)%R) -mulrBr -!mulrA. + congr (_ * (_ * _))%R; rewrite mulrCA; congr (_ * _)%R. + by rewrite mulrCA mulfV ?mulr1 // subr_eq0 gt_eqF. +have [d [Id H]] : exists d, (c1 < d < c2 /\ (Df c2 - Df c1) / (c2 - c1) = DDf d)%R. + have H : forall x0, (c1 <= x0 <= c2)%R -> derivable Df x0 1. + move=> z /andP[z1 z2]; apply: HDDf; apply/andP; split => //. + - by apply (@le_trans _ _ c1) => //; by case/andP: Ic1 => /ltW. + - by apply (@le_trans _ _ c2) => //; by case/andP: Ic2 => _ /ltW. + case/andP : Ic1 => ac1 c1x. + case/andP : Ic2 => xc2 c2bx. + have {}H : forall x0 : R^o, x0 \in `]c1, c2[%R -> is_derive x0 1 Df (DDf x0). + move=> x0; rewrite in_itv/= => /andP[c1x0 x0c2]. + apply: DeriveDef => //. + apply: HDDf => //. + rewrite /I. + rewrite (le_trans (ltW ac1) (ltW _))//=. + by rewrite (le_trans (ltW x0c2) (ltW _))//=. + have cf : {within `[c1, c2], continuous Df}. + apply: derivable_within_continuous => y. + rewrite in_itv/= => /andP[c1y yc2]. + apply: HDDf; rewrite /I. + rewrite (le_trans (ltW ac1) _)//=. + by rewrite (le_trans yc2)//= ltW. + have [d dc1c2 H1] := MVT (lt_trans c1x xc2) H cf. + exists d => //; split => //. + rewrite H1 -mulrA divff// ?mulr1//. + by rewrite subr_eq0 gt_eqF. rewrite {}step3 {}H. -apply/mulR_ge0; last first. - apply: DDf_ge0; split. - apply (@leR_trans c1). - apply/ltRW; by case: Ic1. - by case: Id => /ltRW. - apply (@leR_trans c2). - by case: Id => _ /ltRW. - apply/ltRW; by case: Ic2. -apply/mulR_ge0; last by apply/invR_ge0; rewrite subR_gt0. -apply/mulR_ge0; last first. - by rewrite subR_ge0; case: Id => Id1 Id2; apply (@leR_trans d); exact/ltRW. -by apply/mulR_ge0; rewrite subR_ge0; exact/ltRW. +apply/mulr_ge0; last first. + apply: DDf_ge0; apply/andP; split. + apply: (@lt_trans _ _ c1). + by case/andP: Ic1. + by case/andP: Id. + apply (@lt_trans _ _ c2). + by case/andP: Id. + by case/andP: Ic2. +apply/mulr_ge0; last first. + by rewrite invr_ge0// subr_ge0 ltW. +apply/mulr_ge0; last first. + by rewrite subr_ge0; case/andP: Id => Id1 Id2; apply (@le_trans _ _ d); exact/ltW. +by apply/mulr_ge0; rewrite subr_ge0; exact/ltW. Qed. End twice_derivable_convex. diff --git a/probability/convex_equiv.v b/probability/convex_equiv.v index 8663b5fd..a4c389b7 100644 --- a/probability/convex_equiv.v +++ b/probability/convex_equiv.v @@ -3,10 +3,8 @@ From HB Require Import structures. From mathcomp Require Import all_ssreflect ssralg ssrnum fingroup perm matrix. From mathcomp Require Import mathcomp_extra boolp classical_sets. -Require Import Reals. From mathcomp Require Import Rstruct reals. -Require Import ssrR Reals_ext realType_ext Ranalysis_ext ssr_ext ssralg_ext. -Require Import fdist jfdist_cond fsdist convex. +Require Import ssr_ext ssralg_ext realType_ext fdist jfdist_cond fsdist convex. (******************************************************************************) (* Equivalence of Convexity Definitions *) @@ -108,19 +106,19 @@ Parameter axbary : ax_bary T. Parameter axproj : ax_proj T. End NaryConvSpace. -Module Type ConvSpace. Axiom T : convType. End ConvSpace. +Module Type ConvSpace. Axiom T : convType Rdefinitions.R. End ConvSpace. (* First prove mutual definability using ax_barycenter / ax_proj *) Module BinToNary(C : ConvSpace) <: NaryConvSpace. Import NaryConvexSpace. -HB.instance Definition _ := @isNaryConv.Build C.T (@Convn C.T conv). +HB.instance Definition _ := @isNaryConv.Build C.T (@Convn Rdefinitions.R C.T conv). (* NB: is that ok? *) Definition T : naryConvType := C.T. -Definition axbary := @Convn_fdist_convn C.T. -Definition axproj := @Convn_fdist1 C.T. +Definition axbary := @Convn_fdist_convn Rdefinitions.R C.T. +Definition axproj := @Convn_fdist1 Rdefinitions.R C.T. End BinToNary. Module NaryToBin(A : NaryConvSpace). @@ -213,7 +211,7 @@ case: j => -[|[|[]]] //= Hj. by rewrite fdistI2E eqxx !(mulr0,addr0) mulr1 mulrC -p_is_rs. - rewrite (big_pred1 ord0) // (big_pred1 (Ordinal (ltnSn 1))) //. rewrite !fdistI2E !eqxx !(mulr0,addr0,add0r)/=. - rewrite {2}/onem mulrDr mulr1 mulrN [in RHS]GRing.mulrC. + rewrite {2}/onem mulrDr mulr1 mulrN [in RHS]mulrC. rewrite -p_is_rs s_of_pqE onemM !onemK /onem mulrBl mul1r. by rewrite -!addrA (addrC (Prob.p p)) !addrA subrK. - rewrite (big_pred1 (Ordinal (ltnSn 1))) //. @@ -230,7 +228,7 @@ Qed. Lemma binconvmm p a : binconv p a a = a. Proof. by apply axidem => i; case: ifP. Qed. -HB.instance Definition _ := @isConvexSpace.Build A.T binconv +HB.instance Definition _ := @isConvexSpace.Build Rdefinitions.R A.T binconv binconv1 binconvmm binconvC binconvA. End NaryToBin. @@ -260,17 +258,15 @@ rewrite /(_ <| _ |> _)/= /binconv. set d' := fdistmap _ _. rewrite -(axproj ord0) convn_if axbary. congr (<&>_ _ _); apply fdist_ext => i. - rewrite fdist_convnE !big_ord_recl big_ord0 addr0 /= !fdistI2E /=. rewrite fdist1E /d' fdistmapE /=. - have [->|] := eqVneq i ord0; first by rewrite big1 // mulr0 mulr1 addr0. case: (unliftP ord0 i) => //= [j|] -> // Hj. rewrite (big_pred1 j) //=. rewrite fdist_delE fdistD1E /= /onem. -rewrite mulr0 add0r mulrA (mulrC (1 - d ord0)%R) mulrK //. -apply/eqP => /(congr1 (Rplus (d ord0))). -rewrite addRCA addRN !addR0 => b'. +rewrite mulr0 add0r mulrA (mulrC (1 - d ord0)%mcR) mulrK //. +apply/eqP=> /(congr1 (+%R (d ord0))). +rewrite addrCA addrN !addr0 => b'. by elim b; rewrite -b' eqxx. Qed. @@ -296,16 +292,14 @@ Module EA := Equiv2(A). Import A B. #[local] -Definition equiv_convn n (d : {fdist 'I_n}) (g : 'I_n -> A.T) : - <&>_d g = <|>_d g. +Definition equiv_convn n (d : {fdist 'I_n}) (g : 'I_n -> A.T) : <&>_d g = <|>_d g. Proof. by []. Qed. -#[local] Definition T' := NaryConv_sort__canonical__convex_ConvexSpace. Lemma equiv_conv p (a b : C.T) : a <| p |> b = a <& p &> b. Proof. -change (a <& p &> b) with (@conv T' p a b). +change (a <& p &> b) with (@conv Rdefinitions.R T' p a b). pose g := fun (x : 'I_2) => if x == ord0 then a else b. change a with (g ord0). change b with (g (lift ord0 ord0)). @@ -422,14 +416,14 @@ have trivIK i j x : x \in fdist_supp (e i) -> x \in fdist_supp (e j) -> i = j. have [|] := eqVneq i j => [// | ij] xi xj. move/setP/(_ x): (HP _ _ ij); by rewrite inE xi xj inE. have neqj j a k : - a \in fdist_supp (e (h j)) -> k != (h j) -> (d k * e k a = 0)%R. + a \in fdist_supp (e (h j)) -> k != (h j) -> (d k * e k a = 0)%mcR. move=> Haj kj. case/boolP: (a \in fdist_supp (e k)) => [ak|]. by rewrite (trivIK _ _ _ Haj ak) eqxx in kj. rewrite inE negbK => /eqP ->. - by rewrite mulR0. -have Hmap' i : fdistmap h' d i = (\sum_j d (h i) * e (h i) j)%R. - rewrite -big_distrr fdistE /= FDist.f1 /= mulR1. + by rewrite mulr0. +have Hmap' i : fdistmap h' d i = (\sum_j d (h i) * e (h i) j)%mcR. + rewrite -big_distrr fdistE /= FDist.f1 /= mulr1. rewrite (bigD1 (h i)) /=; last by rewrite /h /h' !inE enum_valK_in eqxx. rewrite big1 /= ?addr0 // => j /andP[] /eqP <-. case /boolP: (j \in fdist_supp d) => Hj. @@ -440,23 +434,23 @@ have Hmap i : fdistmap h' d i. rewrite fdistE big_mkcond /=. under eq_bigr do rewrite fdistE. - rewrite (eq_bigr (fun j => d (h i) * e (h i) j)%R). + rewrite (eq_bigr (fun j => d (h i) * e (h i) j)%mcR). by rewrite Hmap'. move=> /= a _; rewrite !inE; case: (f a) => j /= /orP[/forallP /= |] Ha. - have Ha0 k : (d k * e k a = 0)%R. + have Ha0 k : (d k * e k a = 0)%mcR. case/boolP: (k \in fdist_supp d) => [Hk|]. move: (Ha (h' k)). - by rewrite inE negbK /h/h' enum_rankK_in // => /eqP ->; rewrite mulR0. - by rewrite inE negbK => /eqP -> ; rewrite mul0R. + by rewrite inE negbK /h/h' enum_rankK_in // => /eqP ->; rewrite mulr0. + by rewrite inE negbK => /eqP -> ; rewrite mul0r. case: ifPn => [/eqP|] _. by rewrite Ha0 big1. by rewrite Ha0. case: ifPn => [/eqP/esym ->{i}|ji]. - by rewrite (bigD1 (h j)) //= big1 ?addr0 // => *; rewrite -RmultE (neqj j). + by rewrite (bigD1 (h j)) //= big1 ?addr0 // => *; rewrite (neqj j). by rewrite (neqj j) //; apply: contra ji => /eqP/enum_val_inj ->. congr (<&>_ _ _); first by apply fdist_ext => /= i; rewrite Hmap. apply funext => i /=. -have HF : fdistmap h' d i != 0%R. +have HF : fdistmap h' d i != 0%mcR. rewrite fdistE /=. apply/eqP => /psumr_eq0P H. have: h i \in fdist_supp d by apply enum_valP. @@ -467,8 +461,8 @@ rewrite (@axidem (<&>_(e (h i)) g)); last first. case/boolP: (j \in fdist_supp d) => [Hj|]. case: (@eqP _ i) => [-> |]. by rewrite /h /h' (enum_rankK_in _ Hj). - by rewrite /Rdiv mulR0 mul0R eqxx. - by rewrite inE negbK => /eqP ->; rewrite mul0R div0R eqxx. + by rewrite mulr0 mul0r eqxx. + by rewrite inE negbK => /eqP ->; rewrite !mul0r eqxx. congr (<&>_ _ _); apply fdist_ext => j. rewrite FDistPart.dE; last first. rewrite !fdistE /=. @@ -477,9 +471,9 @@ rewrite FDistPart.dE; last first. rewrite (bigD1 (h i)) //=. rewrite -big_distrr big_mkcond /=. rewrite (eq_bigr (e (h i))). - rewrite FDist.f1 mulr1; apply paddR_neq0 => //. - by apply/RleP/sumr_ge0 => *; apply/sumr_ge0 => *; rewrite mulr_ge0. - by left; move: (enum_valP i); rewrite inE. + rewrite FDist.f1 mulr1 paddr_eq0 //. + by have:= enum_valP i=> /[!inE] /negPf ->. + by apply/sumr_ge0 => *; apply/sumr_ge0 => *; rewrite mulr_ge0. move=> /= k _; rewrite 2!inE; case: ifP => //. case: (f k) => /= x /orP[/forallP/(_ i)|Hkx Hx]. by rewrite inE negbK => /eqP ->. @@ -493,7 +487,7 @@ rewrite fdistE. case: (f j) => /= k /orP[Hn|jk]. move/forallP/(_ i): (Hn). rewrite inE negbK => /eqP ->. - rewrite big1 /Rdiv ?mul0R //. + rewrite big1 ?mul0r //. move=> a _. move/forallP/(_ (h' a)): Hn. case/boolP: (a \in fdist_supp d). @@ -501,17 +495,16 @@ case: (f j) => /= k /orP[Hn|jk]. move/(enum_rankK_in _) ->. by rewrite inE negbK => /eqP ->; rewrite mulr0. by rewrite inE negbK => /eqP ->; rewrite mul0r. -rewrite (bigD1 (h k)) //= big1 ?addR0; last first. +rewrite (bigD1 (h k)) //= big1 ?addr0; last first. by move=> a Ha; apply (neqj k). case/boolP: (j \in fdist_supp (e (h i))) => ji. have /enum_val_inj H := trivIK _ _ _ jk ji. subst k => {jk}. - move: HF; rewrite eqxx mulR1 Hmap'. - rewrite -big_distrr /= FDist.f1 mulR1 => HF. - rewrite addr0 -RmultE. - by rewrite /Rdiv mulRAC mulRV // mul1R. + move: HF; rewrite eqxx mulr1 Hmap'. + rewrite -big_distrr /= FDist.f1 mulr1 => HF. + by rewrite mulrAC mulfV // mul1r. case: eqP ji => [->|ik]; first by rewrite jk. -by rewrite inE negbK => /eqP ->; rewrite mulR0 div0R. +by rewrite inE negbK => /eqP ->; rewrite mulr0 mul0r. Qed. Lemma axinjmap : ax_inj_map T. @@ -590,17 +583,17 @@ have [->|Hj] := eqVneq j p.2; last first. rewrite (big_pred1 p.1) /=; last first. move=> i; rewrite !inE -(enum_valK k) (can_eq enum_rankK). by rewrite (surjective_pairing (enum_val k)) xpair_eqE eqxx andbT. -have [Hp|Hp] := eqVneq (\sum_(i < n) d i * e i p.2)%R 0%R. - rewrite Hp mul0r -RmultE. - by move/psumr_eq0P : Hp => ->//= i _; rewrite RmultE mulr_ge0. -rewrite [RHS]mulRC !fdistE jfdist_condE !fdistE /=; last first. +have [Hp|Hp] := eqVneq (\sum_(i < n) d i * e i p.2)%mcR 0%mcR. + rewrite Hp mul0r. + by move/psumr_eq0P : Hp => ->//= i _; rewrite mulr_ge0. +rewrite [RHS]mulrC !fdistE jfdist_condE !fdistE /=; last first. by under eq_bigr do rewrite fdistXE fdist_prodE. rewrite /jcPr /proba.Pr (big_pred1 p); last first. by move=> i; rewrite !inE -xpair_eqE -!surjective_pairing. rewrite (big_pred1 p.2); last by move=> i; rewrite !inE. rewrite eqxx mulr1 fdist_sndE /= fdist_prodE. under eq_bigr do rewrite fdist_prodE /=. -by rewrite -mulRA mulVR ?mulR1. +by rewrite -!mulrA mulVf ?mulr1. Qed. End BeaulieuToStandard. diff --git a/probability/convex_stone.v b/probability/convex_stone.v index e7711cfc..e89f8934 100644 --- a/probability/convex_stone.v +++ b/probability/convex_stone.v @@ -1,11 +1,10 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum matrix fingroup perm. +From mathcomp Require Import lra ring. From mathcomp Require boolp. -Require Import Reals Lra. From mathcomp Require Import mathcomp_extra Rstruct reals. -Require Import ssrR Reals_ext realType_ext Ranalysis_ext ssr_ext. -Require Import ssralg_ext logb fdist convex. +Require Import ssr_ext ssralg_ext realType_ext fdist convex. (****************************************************************************) (* Direct formalization of the Lemma 2 from M. H. Stone. Postulates for the *) @@ -351,7 +350,8 @@ Qed. End Sn. Section convex_space_prop. -Variables A : convType. +Context {R : realType}. +Variables A : convType R. Implicit Types a b : A. Lemma conv0 a b : a <| 0%:pr |> b = b. Proof. @@ -359,22 +359,22 @@ by rewrite convC (_ : _%:pr = 1%:pr) ?conv1 //=; apply val_inj; exact: onem0. Qed. Lemma convA0 (p q r s : {prob R}) a b c : - Prob.p p = (Prob.p r * Prob.p s)%coqR :> R -> - ((Prob.p s).~ = (Prob.p p).~ * (Prob.p q).~)%coqR -> + Prob.p p = (Prob.p r * Prob.p s)%R :> R -> + ((Prob.p s).~ = (Prob.p p).~ * (Prob.p q).~)%R -> a <| p |> (b <| q |> c) = (a <| r |> b) <| s |> c. Proof. move=> H1 H2. have [r0|r0] := eqVneq r 0%:pr. rewrite r0 conv0 (_ : p = 0%:pr) ?conv0; last first. - by apply/val_inj; rewrite /= H1 r0 mul0R. - congr (_ <| _ |> _); move: H2; rewrite H1 r0 mul0R onem0 mul1R. + by apply/val_inj; rewrite /= H1 r0 mul0r. + congr (_ <| _ |> _); move: H2; rewrite H1 r0 mul0r onem0 mul1r. move/(congr1 (@onem _)); rewrite !onemK => ?; exact/val_inj. have [s0|s0] := eqVneq s 0%:pr. rewrite s0 conv0 (_ : p = 0%:pr) ?conv0; last first. - by apply/val_inj; rewrite /= H1 s0 mulR0. + by apply/val_inj; rewrite /= H1 s0 mulr0. rewrite (_ : q = 0%:pr) ?conv0 //. - move: H1; rewrite s0 mulR0 => p0. - move: H2; rewrite p0 onem0 mul1R => /(congr1 (@onem _)); rewrite !onemK => sq. + move: H1; rewrite s0 mulr0 => p0. + move: H2; rewrite p0 onem0 mul1r => /(congr1 (@onem _)); rewrite !onemK => sq. by rewrite -s0; exact/val_inj. rewrite convA; congr ((_ <| _ |> _) <| _ |> _). apply val_inj; rewrite /= s_of_pqE. @@ -399,21 +399,20 @@ have [->|q0] := eqVneq q 0%:pr; first by rewrite !conv0. have [->|p1] := eqVneq p 1%:pr; first by rewrite !conv1. have [->|q1] := eqVneq q 1%:pr; first by rewrite !conv1. set r := [p_of q, p]. -have r1 : (r != 1%:pr)%coqR. +have r1 : (r != 1%:pr)%R. by rewrite p_of_neq1//; apply/andP; split; rewrite -?prob_gt0 -?prob_lt1. rewrite -(convA' x1 y1) //. rewrite (convC _ y1). set s := [q_of q, p]. set t := (Prob.p (Prob.p s).~%:pr * Prob.p q)%:pr. -have t1 : (Prob.p t < 1)%coqR. - apply/RltP. rewrite -prob_lt1; apply/eqP => t1; subst t. - have {q1} : (Prob.p q < 1)%coqR by apply/RltP; rewrite -prob_lt1. - move/RltP. rewrite R1E. - move/(congr1 (@Prob.p _)) : t1 => /= <-. move/RltP. - rewrite -ltR_pdivr_mulr; last by apply/RltP; rewrite -prob_gt0. - rewrite divRR // /onem ltR_subr_addl ltRNge; apply. - by rewrite -{1}[in (1%R <= _)%coqR](add0R 1%R) leR_add2r. -rewrite -(convA' x2); last by rewrite prob_lt1 p_of_rsC /= p_of_rsE; apply/RltP. +have t1 : (Prob.p t < 1)%R. + rewrite -prob_lt1; apply/eqP => t1; subst t. + have {q1} : (Prob.p q < 1)%R by rewrite -prob_lt1. + move/(congr1 (@Prob.p _)) : t1 => /= <-. + rewrite -ltr_pdivrMr; last by rewrite -prob_gt0. + rewrite divff// /onem ltrBrDl Order.TotalTheory.ltNge => /negP; apply. + by rewrite -{1}[in (1%R <= _)%R](add0r 1%R) lerD2r. +rewrite -(convA' x2); last by rewrite prob_lt1 p_of_rsC /= p_of_rsE. rewrite -(convA' x1) //; last by rewrite p_of_rsC. rewrite (convC _ y2 y1) /=. congr (_ <| _ |> _); first by rewrite p_of_rsC. @@ -421,20 +420,18 @@ congr (_ <| _ |> _). (* TODO: lemma? *) apply val_inj => /=. rewrite /s /onem /= !(p_of_rsE,q_of_rsE) /= !(p_of_rsE,q_of_rsE) /= /onem. - rewrite -!RminusE -R1E -!RmultE -!RinvE. field. - rewrite subR_eq0 mulRC; apply/nesym/eqP. - by rewrite RmultE -p_of_rsE. + rewrite subr_eq0 mulrC eq_sym. + by rewrite -p_of_rsE. congr (_ <| _ |> _). apply val_inj => /=. rewrite -[in RHS](onemK (Prob.p p)); congr onem. rewrite q_of_rsE {1}p_of_rsE /= q_of_rsE p_of_rsE /= /onem. -rewrite -!RminusE -!R1E -!RmultE -!RinvE. field. -split. - rewrite subR_eq0; apply/nesym/eqP; by rewrite RmultE -p_of_rsE. -rewrite mulRBl mul1R subRBA subRK mulRDr mulR1 mulRN addR_opp subRBA subRK. -rewrite subR_eq0 => /esym; exact/eqP. +apply/andP; split. + by rewrite subr_eq0 eq_sym -p_of_rsE. +rewrite mulrBl mul1r opprB addrA subrK mulrDr mulr1 mulrN opprB addrA subrK. +by rewrite subr_eq0 eq_sym. Qed. Lemma distribute (x y z : A) (p q : {prob R}) : @@ -447,7 +444,7 @@ elim: n j g => [[] [] //|n IH j g /=]. case: Bool.bool_dec => [/eqP|/Bool.eq_true_not_negb b01]. rewrite fdist1E; case j0 : (_ == _) => /=. by move=> _; rewrite (eqP j0). - by move/eqP; rewrite eq_sym R1E oner_eq0. + by move/eqP; rewrite eq_sym oner_eq0. rewrite (_ : probfdist _ _ = 0%:pr) ?conv0; last first. apply val_inj => /=; move: b01; rewrite !fdist1E => j0. by case j0' : (_ == _) => //; rewrite j0' eqxx in j0. @@ -459,10 +456,10 @@ rewrite (_ : fdist_del b01 = fdist1 j'); last first. apply/fdist_ext => /= k. rewrite fdist_delE fdistD1E /= !fdist1E /= (negbTE j0) subr0 divr1. congr (GRing.natmul _ (nat_of_bool _)). - move R : (k == _) => [|]. + move Hk : (k == _) => [|]. - apply/eqP/val_inj; rewrite /= /bump leq0n add1n. - by move/eqP : R => -> /=; rewrite prednK // lt0n. - - apply: contraFF R => /eqP. + by move/eqP : Hk => -> /=; rewrite prednK // lt0n. + - apply: contraFF Hk => /eqP. move/(congr1 val) => /=; rewrite /bump leq0n add1n => kj. by apply/eqP/val_inj; rewrite /= -kj. rewrite IH /fdist_del_idx ltn0; congr g. @@ -475,7 +472,7 @@ rewrite /=; case: Bool.bool_dec => // /Bool.eq_true_not_negb H; exfalso; move/eq by apply/eqP; rewrite fdist1E1 (fdist1I1 e). Qed. -Lemma convnE n (g : 'I_n.+1 -> A) (d : {fdist 'I_n.+1}) (i1 : d ord0 != 1%coqR) : +Lemma convnE n (g : 'I_n.+1 -> A) (d : R.-fdist 'I_n.+1) (i1 : d ord0 != 1%R) : <|>_d g = g ord0 <| probfdist d ord0 |> <|>_(fdist_del i1) (fun x => g (fdist_del_idx ord0 x)). Proof. @@ -484,10 +481,10 @@ exfalso; by rewrite (eqP H) eqxx in i1. by rewrite (boolp.Prop_irrelevance H i1). Qed. -Lemma convn2E (g : 'I_2 -> A) (d : {fdist 'I_2}) : +Lemma convn2E (g : 'I_2 -> A) (d : R.-fdist 'I_2) : <|>_d g = g ord0 <| probfdist d ord0 |> g (Ordinal (erefl (1 < 2))). Proof. -have [/eqP |i1] := eqVneq (d ord0) 1%coqR. +have [/eqP |i1] := eqVneq (d ord0) 1%R. rewrite fdist1E1 => /eqP ->; rewrite Convn_fdist1. rewrite (_ : probfdist _ _ = 1%:pr) ?conv1 //. by apply val_inj; rewrite /= fdist1xx. @@ -499,7 +496,7 @@ Qed. Open Scope ring_scope. -Lemma convn3E (g : 'I_3 -> A) (d : {fdist 'I_3}) (p : {prob R}) : +Lemma convn3E (g : 'I_3 -> A) (d : R.-fdist 'I_3) (p : {prob R}) : d ord0 != 1%R -> (d (lift ord0 ord0) / (1 - d ord0)) = Prob.p p -> <|>_d g = g ord0 <| probfdist d ord0 |> (g (Ordinal (erefl (1 < 3)%nat)) <| p |> g (Ordinal (erefl (2 < 3)%nat))). @@ -520,14 +517,14 @@ rewrite convn2E /fdist_del_idx ltnn /=; congr (g _ <| _ |> g _). - exact/val_inj. Qed. -Lemma convn_proj n (g : 'I_n -> A) (d : {fdist 'I_n}) i : - d i = R1 -> <|>_d g = g i. +Lemma convn_proj n (g : 'I_n -> A) (d : R.-fdist 'I_n) i : + d i = 1 -> <|>_d g = g i. Proof. elim: n g d i => [d d0|n IH g d i di1]; first by move: (fdistI0_False d0). have [i0|i0] := eqVneq i ord0. move/eqP : di1; rewrite i0 fdist1E1 => /eqP ->. by rewrite Convn_fdist1. -have d00 : d ord0 = R0 by move/eqP/fdist1P : di1 => -> //; rewrite eq_sym. +have d00 : d ord0 = 0 by move/eqP/fdist1P : di1 => -> //; rewrite eq_sym. rewrite convnE; first by rewrite d00; apply/eqP; lra. move=> d01. rewrite (_ : probfdist _ _ = 0%:pr); last exact/val_inj. @@ -546,14 +543,14 @@ Qed. (* goal: Conv_perm *) -Lemma Convn_perm_1 n (d : {fdist 'I_n}) (g : 'I_n -> A) : +Lemma Convn_perm_1 n (d : R.-fdist 'I_n) (g : 'I_n -> A) : <|>_d g = <|>_(fdistI_perm d 1%g) (g \o (1%g : 'S_n)). Proof. rewrite fdistI_perm1; congr (Convn _ d _). by rewrite boolp.funeqE => i /=; rewrite perm1. Qed. -Lemma Convn_permI1 (d : {fdist 'I_1}) (g : 'I_1 -> A) (s : 'S_1) : +Lemma Convn_permI1 (d : R.-fdist 'I_1) (g : 'I_1 -> A) (s : 'S_1) : <|>_d g = <|>_(fdistI_perm d s) (g \o s). Proof. have s1 : s = 1%g. @@ -561,7 +558,7 @@ have s1 : s = 1%g. by rewrite s1 -Convn_perm_1. Qed. -Lemma Convn_permI2 (d : {fdist 'I_2}) (g : 'I_2 -> A) (s : 'S_2) : +Lemma Convn_permI2 (d : R.-fdist 'I_2) (g : 'I_2 -> A) (s : 'S_2) : <|>_d g = <|>_(fdistI_perm d s) (g \o s). Proof. have [->|Hs] := S2.generators s. @@ -582,10 +579,10 @@ move: (FDist.ge0 d ord0); rewrite le0r => /orP -[/eqP /esym d00|d00]. rewrite permE /= (negbTE i0). by case: ifPn => //; case: i i0 => -[|[|]]. by rewrite H2 Convn_fdist1 /=; congr g; rewrite Hs permE /=. -have [d10|d10] := eqVneq (d (lift ord0 ord0)) 0%coqR. +have [d10|d10] := eqVneq (d (lift ord0 ord0)) 0. have d01 : d ord0 = 1. rewrite -(FDist.f1 d) !big_ord_recl big_ord0 addr0. - by rewrite addrC -subR_eq subRR d10. + by rewrite addrC d10 add0r. have -> : d = fdist1 ord0 by apply/eqP; rewrite -fdist1E1; exact/eqP. by rewrite Convn_fdist1 {1}Hs fdistI_tperm Convn_fdist1 /= Hs permE. rewrite convn2E. @@ -595,7 +592,7 @@ rewrite fdistI_permE permE /= /onem -(FDist.f1 d) !big_ord_recl big_ord0. by rewrite addr0 (addrC (d ord0)) addrK; congr (d _); exact/val_inj. Qed. -Lemma Convn_permI3_p01 (d : {fdist 'I_3}) (g : 'I_3 -> A) : +Lemma Convn_permI3_p01 (d : R.-fdist 'I_3) (g : 'I_3 -> A) : <|>_d g = <|>_(fdistI_perm d S3.p01) (g \o S3.p01). Proof. have : (d ord0 + d (lift ord0 ord0) = 0 \/ d (lift ord0 ord0) + d ord_max = 0 \/ @@ -646,12 +643,12 @@ have [|p1] := eqVneq p 1%:pr. rewrite (@convn3E _ _ 1%:pr) ?conv1; last first. rewrite !fdistI_permE /S3.p01 /= !permE /=. rewrite (_ : Ordinal _ = lift ord0 ord0); last exact/val_inj. - by rewrite H opprB addrC subrK divrr. + by rewrite H opprB addrC subrK divff//. rewrite /S3.p01 /= fdistI_permE permE /=. rewrite (_ : Ordinal _ = lift ord0 ord0); last exact/val_inj. apply: contra d00 => /eqP d001. - move: H; rewrite d001 => /esym. - by rewrite subR_eq addRC -subR_eq subRR => <-. + move: H; rewrite d001 => /eqP. + by rewrite addrC -subr_eq subrr -eqr_oppLR oppr0 eq_sym. rewrite /= /S3.p01 !permE /= convC. congr (g _ <| _ |> g _). apply/val_inj; rewrite /= fdistI_permE permE /=. @@ -659,21 +656,22 @@ have [|p1] := eqVneq p 1%:pr. rewrite (@convn3E _ _ p) //; last exact/eqP. rewrite convA. rewrite (convC _ (g ord0)). -have ? : 1 - d ord0 != 0 by rewrite subr_eq0; exact/eqP/nesym. +have oned0 : 1 - d ord0 != 0 by rewrite subr_eq0; exact/eqP/nesym. have H : Prob.p [p_of (Prob.p [r_of probfdist d ord0, p]).~%:pr, [s_of probfdist d ord0, p]] != Prob.p 1%:pr :> R. - apply p_of_neq1. + apply: p_of_neq1. rewrite s_of_pqE /=. - rewrite onemM !onemK. + rewrite (onemM (d ord0).~). + rewrite !onemK. rewrite -addrA -opprB. - rewrite -!RmultE. - rewrite -[X in (_ < _ - (_ - X) < _)%mcR]mul1R. - rewrite -mulrBl -mulNr opprB mulrCA mulrV // mulr1. + rewrite -[X in (_ < _ - (_ - X) < _)%R]mul1r. + rewrite -mulrBl -mulNr opprB mulrCA mulfV // mulr1. apply/andP; split => //. rewrite lt_neqAle; apply/andP; split. apply: contra p1 => p1. apply/eqP/val_inj => /=. - move: p1; rewrite eq_sym addrC -subR_eq' => /eqP <-. - by rewrite RminusE divff. + move: p1; rewrite eq_sym addrC. + rewrite -subr_eq => /eqP H; rewrite H divff//. + by rewrite -H. by rewrite -(FDist.f1 d) !big_ord_recl /= big_ord0 addr0 addrA lerDl. rewrite -convA'; last by []. have [/eqP ds01|ds01] := eqVneq (d (S3.p01 ord0)) 1. @@ -706,37 +704,30 @@ congr (_ <| _ |> _). rewrite fdistI_permE permE /= p_of_rsE /= r_of_pqE /=. rewrite s_of_pqE /= /onem. rewrite (_ : Ordinal _ = lift ord0 ord0); last exact/val_inj. - rewrite -R1E -!RminusE -!RdivE// -!RmultE. set tmp1 := d _. set tmp2 := d _. field. - split; first by rewrite subR_eq0; exact/nesym. - rewrite -addR_opp oppRB -addR_opp oppRB addRC addRA subRK. - by apply/eqP; rewrite gtR_eqF // addRC; apply/RltP. + rewrite oned0/= opprB opprB addrC addrA subrK. + by rewrite gt_eqF// addrC. - by rewrite /= /S3.p01 permE /=; congr g; exact/val_inj. - congr (_ <| _ |> _). + apply val_inj => /=. rewrite q_of_rsE /= !fdistI_permE p_of_rsE /= r_of_pqE /= s_of_pqE. rewrite /= /onem !permE /=. rewrite (_ : Ordinal _ = lift ord0 ord0); last exact/val_inj. - rewrite -[RHS]RdivE. - rewrite -R1E -!RminusE -!RdivE // -!RmultE. set tmp1 := d _. set tmp2 := d _. field. - split. - rewrite subR_eq0. - apply/nesym/eqP. - apply: contra ds01. - rewrite /S3.p01 permE /= (_ : Ordinal _ = lift ord0 ord0) //; exact/val_inj. - split; first by rewrite subR_eq0; exact/nesym. - rewrite -addR_opp oppRB -addR_opp oppRB addRC addRA subRK. - by apply/eqP; rewrite gt_eqF // addRC. + apply/andP; split. + rewrite subr_eq0 eq_sym. + apply: contra ds01. + rewrite /S3.p01 permE /= (_ : Ordinal _ = lift ord0 ord0) //; exact/val_inj. + by rewrite oned0/= !opprB addrC addrA subrK gt_eqF// addrC. + by congr g; apply val_inj => /=; rewrite /S3.p01 permE. + by rewrite /= /S3.p01 permE. Qed. -Lemma Convn_permI3_p02 (d : {fdist 'I_3}) (g : 'I_3 -> A) : +Lemma Convn_permI3_p02 (d : R.-fdist 'I_3) (g : 'I_3 -> A) : <|>_d g = <|>_(fdistI_perm d S3.p02) (g \o S3.p02). Proof. (* TODO(rei): redundant part with Convn_perm3_p02 *) @@ -758,7 +749,7 @@ move=> [ H | [ H | [H1 H2] ] ]. rewrite (_ : lift ord0 (lift _ _) = ord_max) ?H //; exact/val_inj. rewrite fdist1E1 in d1. by rewrite (eqP d1) Convn_fdist1 fdistI_perm_fdist1 Convn_fdist1 /= permKV. -have d01 : d ord0 <> 1%coqR. +have d01 : d ord0 <> 1%R. move=> /eqP d01. move: H2. move/fdist1P : (d01) => -> //. @@ -777,7 +768,7 @@ have @p : {prob R}. rewrite (@convn3E _ _ p) //; last exact/eqP. rewrite convC. rewrite (convC _ _ (g (Ordinal (erefl (2 < 3)%nat)))). -have [/eqP dmax1|dmax1] := eqVneq (d ord_max) 1%coqR. +have [/eqP dmax1|dmax1] := eqVneq (d ord_max) 1%R. move/fdist1P in dmax1. by move: H1; rewrite dmax1 // dmax1 // addr0 ltxx. have [d00|d00] := eqVneq (d ord0) 0. @@ -790,7 +781,7 @@ have [d00|d00] := eqVneq (d ord0) 0. rewrite (_ : Ordinal _ = ord_max) //; last exact/val_inj. rewrite -[in LHS](FDist.f1 d) !big_ord_recl big_ord0 addr0 d00 add0r. rewrite (_ : lift _ (lift _ _) = ord_max); last exact/val_inj. - rewrite addrK divrr //. + rewrite addrK divff //. apply/eqP => d10. by move: H1; rewrite d00 d10 addr0 ltxx. rewrite /= /S3.p02 !permE /= conv1. @@ -825,7 +816,7 @@ congr (g _ <| _ |> (_ <| _ |> _)). rewrite !fdistI_permE p_of_rsE /= permE /=. rewrite (_ : Ordinal _ = ord_max); last exact/val_inj. rewrite {1}/onem. - rewrite mulrBl mul1r -mulrA mulVr ?mulr1//. + rewrite mulrBl mul1r -mulrA mulVf ?mulr1//. rewrite /onem -addrA -opprB opprK; apply/eqP; rewrite subr_eq; apply/eqP. rewrite -(FDist.f1 d) !big_ord_recl big_ord0 addr0. rewrite (_ : lift _ (lift _ _) = ord_max); last exact/val_inj. @@ -834,35 +825,24 @@ apply val_inj => /=. rewrite !fdistI_permE !permE /= q_of_rsE /= p_of_rsE /=. rewrite (_ : Ordinal _ = ord_max); last exact/val_inj. rewrite onemK. -rewrite -!RdivE //. -rewrite -!RminusE. -rewrite {1 2}/Rdiv. -rewrite -2!mulRA. -rewrite [in RHS]/Rdiv. -congr (_ * _)%coqR. -rewrite mulRA mulVR; last first. - rewrite subR_eq0' eq_sym; exact/eqP. -rewrite mul1R. -congr Rinv. -rewrite onemM !onemK. -rewrite -RminusE -!RplusE -!RmultE. -rewrite addRC. -rewrite -{1}(mulR1 (d (lift ord0 ord0) / _))%coqR. -rewrite -subRBA. -rewrite -mulRBr. -rewrite -addR_opp. -rewrite -mulRN. -rewrite oppRB. -rewrite /Rdiv. -rewrite -mulRA. -rewrite mulVR ?mulR1; last first. - rewrite subR_eq0' eq_sym; exact/eqP. -apply/esym; rewrite subR_eq -(FDist.f1 d) !big_ord_recl big_ord0 addr0. +rewrite -2!mulrA. +congr (_ * _)%R. +rewrite mulrA mulVf//. +rewrite mul1r. +congr (_^-1)%R. +rewrite (onemM _ (d ord0).~) !onemK. +rewrite (addrC _ (d ord0)). +rewrite -{1}(mulr1 (d (lift ord0 ord0) / _))%R. +rewrite -addrA. +rewrite -mulrBr. +rewrite -mulrA. +rewrite mulVf ?mulr1//. +apply/esym/eqP; rewrite subr_eq -(FDist.f1 d) !big_ord_recl big_ord0 addr0. rewrite (_ : lift _ (lift _ _) = ord_max); last exact/val_inj. by rewrite addrA. Qed. -Lemma Convn_permI3 (d : {fdist 'I_3}) (g : 'I_3 -> A) (s : 'S_3) : +Lemma Convn_permI3 (d : R.-fdist 'I_3) (g : 'I_3 -> A) (s : 'S_3) : <|>_d g = <|>_(fdistI_perm d s) (g \o s). Proof. move: s d g. @@ -875,9 +855,9 @@ exact: Convn_permI3_p01. exact: Convn_perm_1. Qed. -Lemma Convn_perm_projection n (d : {fdist 'I_n.+2}) - (g : 'I_n.+2 -> A) (s : 'S_n.+2) (H : s ord0 = ord0) (dmax1 : d ord0 != 1%coqR) - (m : nat) (nm : (n.+1 < m)%nat) (IH : forall n : nat, (n < m)%nat -> forall (d : {fdist 'I_n}) (g : 'I_n -> A) (s : 'S_n), +Lemma Convn_perm_projection n (d : R.-fdist 'I_n.+2) + (g : 'I_n.+2 -> A) (s : 'S_n.+2) (H : s ord0 = ord0) (dmax1 : d ord0 != 1%R) + (m : nat) (nm : (n.+1 < m)%nat) (IH : forall n : nat, (n < m)%nat -> forall (d : R.-fdist 'I_n) (g : 'I_n -> A) (s : 'S_n), <|>_d g = <|>_(fdistI_perm d s) (g \o s)) : <|>_d g = <|>_(fdistI_perm d s) (g \o s). Proof. @@ -932,27 +912,27 @@ rewrite -[X in _ != X]H. by apply/eqP => /(@perm_inj _ s). Qed. -Lemma Convn_perm_tperm (n : nat) (d : {fdist 'I_n.+3}) - (g : 'I_n.+3 -> A) (s : 'S_n.+3) (H : s = tperm ord0 (lift ord0 ord0)) (dmax1 : d ord0 != 1%coqR) +Lemma Convn_perm_tperm (n : nat) (d : R.-fdist 'I_n.+3) + (g : 'I_n.+3 -> A) (s : 'S_n.+3) (H : s = tperm ord0 (lift ord0 ord0)) (dmax1 : d ord0 != 1%R) (m : nat) (nm : (n.+3 < m.+1)%nat) (IH : forall n : nat, (n < m)%nat -> - forall (d : {fdist 'I_n}) (g : 'I_n -> A) (s : 'S_n), + forall (d : R.-fdist 'I_n) (g : 'I_n -> A) (s : 'S_n), <|>_d g = <|>_(fdistI_perm d s) (g \o s)) : <|>_d g = <|>_(fdistI_perm d s) (g \o s). Proof. have [K|K] := eqVneq (d (lift ord0 ord0)) (1 - d ord0). - case/boolP : (d (lift ord0 ord0) == 1%coqR :> R) => [|d11]. + case/boolP : (d (lift ord0 ord0) == 1%R :> R) => [|d11]. by rewrite fdist1E1 => /eqP ->; rewrite fdistI_perm_fdist1 !Convn_fdist1 /= permKV. rewrite convnE. rewrite [in RHS]convnE. by rewrite fdistI_permE H permE. move=> K'. rewrite (_ : <|>_ _ _ = g (lift ord0 ord0)); last first. - have /eqP : (fdist_del dmax1) ord0 = 1%coqR. + have /eqP : (fdist_del dmax1) ord0 = 1%R. by rewrite fdist_delE fdistD1E /= K divrr // unitfE subr_eq0 eq_sym. rewrite fdist1E1 => /eqP ->. by rewrite Convn_fdist1. rewrite (_ : <|>_ _ _ = g ord0); last first. - have /eqP : (fdist_del K') ord0 = 1%coqR. + have /eqP : (fdist_del K') ord0 = 1%R. rewrite fdist_delE fdistD1E /= !fdistI_permE H !permE /=. rewrite K opprB (addrC (d _) (-1)) addrA subrr add0r divrr // unitfE. apply /eqP => d00. @@ -960,13 +940,13 @@ have [K|K] := eqVneq (d (lift ord0 ord0)) (1 - d ord0). by rewrite fdist1E1 => /eqP ->; rewrite Convn_fdist1 /= H !permE /=. rewrite convC /= H permE /=; congr (_ <| _ |> _). by apply val_inj => /=; rewrite fdistI_permE /= permE /= K. -have [/eqP |K1] := eqVneq (d (lift ord0 ord0)) 1%coqR. +have [/eqP |K1] := eqVneq (d (lift ord0 ord0)) 1%R. by rewrite fdist1E1 => /eqP ->; rewrite fdistI_perm_fdist1 !Convn_fdist1 /= permKV. (* TODO: isolate this construction? *) -pose D' : {ffun 'I_3 -> R} := [ffun x => [eta (fun=>R0) with +pose D' : {ffun 'I_3 -> R} := [ffun x => [eta (fun=>0) with ord0 |-> d ord0, lift ord0 ord0 |-> d (lift ord0 ord0), - ord_max |-> (\sum_(i < n.+3 | (2 <= i)%nat) d i)%coqR] x]. + ord_max |-> (\sum_(i < n.+3 | (2 <= i)%nat) d i)%R] x]. have D'0 : (forall i, 0 <= D' i). move=> i; rewrite /D' ffunE /=; case: ifPn => _ //. by case: ifPn => _ //; case: ifPn => _; [exact: sumr_ge0 | exact/lexx]. @@ -974,7 +954,7 @@ have D'1 : (\sum_(i < 3) (D' i) = 1). rewrite !big_ord_recr big_ord0 /= add0r. rewrite /D' !ffunE /= -(FDist.f1 d). apply/esym. - rewrite 2!big_ord_recl addrA; congr (_ + _)%coqR. + rewrite 2!big_ord_recl addrA; congr (_ + _)%R. apply/esym. set h : 'I_n.+1 -> 'I_n.+3 := fun i => lift ord0 (lift ord0 i). set h' : 'I_n.+3 -> 'I_n.+1 := fun i => inord (i.-2). @@ -991,7 +971,7 @@ have D'1 : (\sum_(i < 3) (D' i) = 1). rewrite /h' /h. by apply/eqP/val_inj => /=; rewrite inordK. set D := FDist.make D'0 D'1. -have H1 : (fdist_del dmax1) ord0 != 1%coqR. +have H1 : (fdist_del dmax1) ord0 != 1%R. rewrite fdist_delE fdistD1E (eq_sym (lift _ _)) (negbTE (neq_lift _ _)). apply/eqP. move/divr1_eq. exact/eqP. @@ -1065,7 +1045,7 @@ congr (Convn _ _). by rewrite boolp.funeqE => j; rewrite /= permE H permE. Qed. -Lemma Convn_perm (n : nat) (d : {fdist 'I_n}) (g : 'I_n -> A) (s : 'S_n) : +Lemma Convn_perm (n : nat) (d : R.-fdist 'I_n) (g : 'I_n -> A) (s : 'S_n) : <|>_d g = <|>_(fdistI_perm d s) (g \o s). Proof. move: d g s. @@ -1077,22 +1057,22 @@ destruct n as [|n]; first exact: Convn_permI3. move: m IH nm d g. apply (@Sn.suff_generators _ (fun s => forall m : nat, (forall n0, (n0 < m)%nat -> - forall (d : {fdist 'I_n0}) (g : 'I_n0 -> A) (s0 : 'S_n0), + forall (d : R.-fdist 'I_n0) (g : 'I_n0 -> A) (s0 : 'S_n0), <|>_d g = <|>_(fdistI_perm d s0) (g \o s0)) -> (n.+4 < m.+1)%nat -> - forall (d : {fdist 'I_n.+4}) (g : 'I_n.+4 -> A), + forall (d : R.-fdist 'I_n.+4) (g : 'I_n.+4 -> A), <|>_d g = <|>_(fdistI_perm d s) (g \o s))). - move=> s1 s2 H1 H2 m IH nm d g. rewrite (H1 m) // (H2 m) // fdistI_permM; congr (Convn _ _). by rewrite boolp.funeqE => i; rewrite /= permM. - move=> m IH nm d g. - have [/eqP|dmax1] := eqVneq (d ord0) 1%coqR. + have [/eqP|dmax1] := eqVneq (d ord0) 1. rewrite fdist1E1 => /eqP ->. by rewrite Convn_fdist1 fdistI_perm_fdist1 Convn_fdist1 /= permKV. by apply Convn_perm_tperm with m. - move=> {}s H. move=> m IH nm d g. - have [/eqP|dmax1] := eqVneq (d ord0) 1%coqR. + have [/eqP|dmax1] := eqVneq (d ord0) 1. rewrite fdist1E1 => /eqP ->. by rewrite Convn_fdist1 fdistI_perm_fdist1 Convn_fdist1 /= permKV. by apply Convn_perm_projection with m. @@ -1101,12 +1081,13 @@ Qed. End convex_space_prop. Section affine_function_prop0. -Lemma affine_function_Sum (A B : convType) (f : {affine A -> B}) (n : nat) - (g : 'I_n -> A) (e : {fdist 'I_n}) : +Context {R : realType}. +Lemma affine_function_Sum (A B : convType R) (f : {affine A -> B}) (n : nat) + (g : 'I_n -> A) (e : R.-fdist 'I_n) : f (<|>_e g) = <|>_e (f \o g). Proof. elim: n g e => [g e|n IH g e]; first by move: (fdistI0_False e). -have [/eqP|e10] := eqVneq (e ord0) 1%coqR. +have [/eqP|e10] := eqVneq (e ord0) 1%R. by rewrite fdist1E1 => /eqP ->; rewrite 2!Convn_fdist1. by rewrite 2!convnE affine_conv IH. Qed. @@ -1124,7 +1105,7 @@ case: Bool.bool_dec => [/eqP|/Bool.eq_true_not_negb] H. rewrite fdist_convnE big_ord_recl H mul1r big1 ?addr0 //= => j _. by move/eqP/fdist1P : H => -> //; rewrite ?mul0r. apply/fdist_ext => a. -rewrite fdist_convE fdist_convnE /= big_ord_recl; congr (_ + _)%coqR. +rewrite fdist_convE fdist_convnE /= big_ord_recl; congr (_ + _)%R. rewrite IH fdist_convnE big_distrr /=; apply eq_bigr => i _. rewrite fdist_delE fdistD1E eq_sym (negbTE (neq_lift _ _)). rewrite mulrAC mulrC -!mulrA; congr (_ * _)%mcR. diff --git a/probability/divergence.v b/probability/divergence.v index 1b184598..9dcfbd1b 100644 --- a/probability/divergence.v +++ b/probability/divergence.v @@ -1,9 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg all_algebra reals. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrR realType_ext Reals_ext ln_facts logb fdist proba. +From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp Require Import Rstruct reals sequences exp. +Require Import realType_ext realType_ln fdist proba. (******************************************************************************) (* Divergence (or the Kullback-Leibler distance or relative entropy) *) @@ -25,50 +24,76 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. +Local Open Scope ring_scope. Local Open Scope fdist_scope. +Import Order.POrderTheory GRing.Theory Num.Theory. + (* TODO: rename, move? *) Section log_facts. +Context {R : realType}. Lemma div_diff_ub x y : 0 <= x -> (y = 0 -> x = 0) -> 0 <= y -> - x * (log (y / x)) <= (y - x) * log (exp 1). + x * (log (y / x)) <= (y - x) * log (expR 1) :> R. Proof. -move=> x0 yx /leR_eqVlt[/esym|] y0. -- by move: (yx y0) => ->; rewrite y0 subRR 2!mul0R. -- case/leR_eqVlt : x0 => [/esym ->|x0]. - + rewrite mul0R subR0; apply mulR_ge0; [exact: ltRW | exact: log_exp1_Rle_0]. +move=> x0 yx; rewrite le_eqVlt => /predU1P[/esym|] y0. +- by rewrite y0 yx// subrr 2!mul0r. +- move: x0; rewrite le_eqVlt => /predU1P[/esym ->|x0]. + + rewrite mul0r subr0 mulr_ge0//; [exact: ltW | ]. + by rewrite log_exp1_Rle_0. + rewrite (_ : y - x = x * (y / x - 1)); last first. - by rewrite mulRDr mulRCA mulRV ?mulR1 ?mulRN1 //; exact/gtR_eqF. - rewrite -mulRA; apply (leR_wpmul2l (ltRW x0)). - by apply/log_id_cmp/mulR_gt0 => //; exact/invR_gt0. + by rewrite mulrDr mulrCA mulfV ?gt_eqF// mulr1 mulrN1. + rewrite -mulrA; apply (ler_wpM2l (ltW x0)). + by rewrite log_id_cmp// divr_gt0. +Qed. + +Lemma log_id_eq x : 0 < x -> log x = (x - 1) * log (expR 1) -> x = 1 :> R. +Proof. +move=> Hx'; rewrite logexp1E. +move=> /(congr1 (fun x => x * ln 2)). +rewrite -!mulrA mulVf// ?gt_eqF ?ln2_gt0//. +by rewrite !mulr1; exact: ln_id_eq. Qed. Lemma log_id_diff x y : 0 <= x -> (y = 0 -> x = 0) -> 0 <= y -> - x * (log (y / x)) = (y - x) * log (exp 1) -> x = y. + x * (log (y / x)) = (y - x) * log (expR 1) -> x = y :> R. Proof. -move=> Hx Hxy /leR_eqVlt[/esym|] y0 Hxy2; first by rewrite y0 Hxy. -case/leR_eqVlt : Hx => [/esym|] x0. -- move/esym : Hxy2; rewrite x0 mul0R subR0 mulR_eq0 => -[] //. - by rewrite logexp1E => /invR_eq0/eqP; rewrite (negbTE ln2_neq0). -- apply/esym; rewrite -(@eqR_mul2l (/ x)) //; last exact/nesym/eqP/ltR_eqF/invR_gt0. - rewrite mulVR //; last exact/gtR_eqF. - apply log_id_eq; first by apply mulR_gt0 => //; exact: invR_gt0. - rewrite -(@eqR_mul2l x); last exact/eqP/gtR_eqF. - rewrite {1}(mulRC _ y) Hxy2 mulRA mulRBr; congr (_ * _). - field; exact/eqP/gtR_eqF. +move=> Hx Hxy; rewrite le_eqVlt => /predU1P[/esym|] y0 Hxy2; first by rewrite y0 Hxy. +move: Hx; rewrite le_eqVlt => /predU1P[/esym|] x0. +- move/esym : Hxy2; rewrite x0 mul0r subr0 => /eqP. + rewrite mulf_eq0 => /predU1P[//|/eqP]. + rewrite logexp1E => /eqP. + by rewrite gt_eqF// invr_gt0// ln2_gt0. +- apply/esym/divr1_eq. + apply: log_id_eq; first by rewrite divr_gt0. + move: Hxy2. + move/(congr1 (fun z => x^-1 * z)). + rewrite mulrA mulVf ?gt_eqF// mul1r => ->. + by rewrite mulrA mulrBr mulVf ?gt_eqF// (mulrC _ y). Qed. End log_facts. Section divergence_def. +Context {R : realType}. +Variables (A : finType) (P Q : R.-fdist A). -Variables (A : finType) (P Q : {fdist A}). - -Definition div := \sum_(a in A) P a * log (P a / Q a). +Definition div : R^o := \sum_(a in A) P a * log (P a / Q a). End divergence_def. +(* TODO: rename, move *) +Lemma leR_sumR_eq {R : realType} (A : finType) (f g : A -> R) (P : pred A) : + (forall a, P a -> f a <= g a) -> + \sum_(a | P a) g a = \sum_(a | P a) f a -> + (forall a, P a -> g a = f a). +Proof. +move=> H1 H2 i Hi; apply/eqP; rewrite -subr_eq0; apply/eqP. +move: i Hi; apply: psumr_eq0P. + by move=> i Pi; rewrite Num.Theory.subr_ge0 H1. +by rewrite big_split/= sumrN; apply/eqP; rewrite subr_eq0 H2. +Qed. + Notation "'D(' P '||' Q ')' " := (div P Q) : divergence_scope. Local Open Scope divergence_scope. @@ -76,51 +101,52 @@ Local Open Scope reals_ext_scope. Local Open Scope fdist_scope. Section divergence_prop. - -Variables (A : finType) (P Q : {fdist A}). +Context {R : realType}. +Variables (A : finType) (P Q : R.-fdist A). Hypothesis P_dom_by_Q : P `<< Q. Lemma div_ge0 : 0 <= D(P || Q). Proof. rewrite /div [X in _ <= X](_ : _ = - \sum_(a | a \in A) P a * (log (Q a / P a))); last first. - rewrite big_morph_oppR; apply eq_bigr => a _; rewrite -mulRN. - case/boolP : (P a == 0) => [/eqP ->|H0]; first by rewrite !mul0R. + rewrite -sumrN; apply: eq_bigr => a _; rewrite -mulrN. + case/boolP : (P a == 0) => [/eqP ->|H0]; first by rewrite !mul0r. congr (_ * _). have Qa0 := dominatesEN P_dom_by_Q H0. - by rewrite -logV ?Rinv_div//; apply divR_gt0; apply /RltP; rewrite -fdist_gt0. -rewrite leR_oppr oppR0. -apply (@leR_trans ((\sum_(a | a \in A) (Q a - P a)) * log (exp 1))). - rewrite (big_morph _ (morph_mulRDl _) (mul0R _)). - apply leR_sumR => a _; apply div_diff_ub => //. - by move/dominatesP : P_dom_by_Q; exact. -rewrite -{1}(mul0R (log (exp 1))); apply (leR_wpmul2r log_exp1_Rle_0). -by rewrite big_split /= -big_morph_oppR !FDist.f1 addR_opp subRR. + by rewrite -logV ?invf_div// divr_gt0//; apply/fdist_gt0. +rewrite lerNr oppr0. +apply (@le_trans _ _ ((\sum_(a | a \in A) (Q a - P a)) * log (expR 1))). + rewrite big_distrl/=. + apply: ler_sum => a _; apply: div_diff_ub => //. + - by move/dominatesP : P_dom_by_Q; exact. +rewrite -[leRHS](mul0r (log (expR 1))) ler_wpM2r// ?log_exp1_Rle_0//. +by rewrite big_split /= sumrN !FDist.f1 subrr. Qed. Lemma divPP : D(Q || Q) = 0. Proof. rewrite /div; apply big1 => a _. -case/boolP : (Q a == 0) => [/eqP ->|H0]; first by rewrite mul0R. -by rewrite divRR // /log /Log ln_1 div0R mulR0. +case/boolP : (Q a == 0) => [/eqP ->|H0]; first by rewrite mul0r. +by rewrite divff // log1 mulr0. Qed. Lemma div0P : D(P || Q) = 0 <-> P = Q. Proof. split => [HPQ | ->]; last by rewrite divPP. apply/fdist_ext => a. -apply log_id_diff => //; first by move/dominatesP : P_dom_by_Q; exact. -apply/esym; move: a (erefl true); apply leR_sumR_eq. -- move=> a' _; apply div_diff_ub => //; move/dominatesP : P_dom_by_Q; exact. -- transitivity 0; last first. - rewrite -{1}oppR0 -{1}HPQ big_morph_oppR. - apply eq_bigr => a _; rewrite -mulRN. - case/boolP : (P a == 0) => [/eqP ->| H0]; first by rewrite !mul0R. - congr (_ * _). - have Qa0 := dominatesEN P_dom_by_Q H0. - by rewrite -logV ?Rinv_div//; apply divR_gt0; apply /RltP; rewrite -fdist_gt0. - rewrite -(big_morph _ (morph_mulRDl _) (mul0R _)) big_split /=. - by rewrite -big_morph_oppR !FDist.f1 addR_opp subRR mul0R. +apply log_id_diff => //. +- by move/dominatesP : P_dom_by_Q; exact. +- apply/esym; move: a (erefl true); apply leR_sumR_eq. + + move=> a' _; apply div_diff_ub => //. + * by move/dominatesP : P_dom_by_Q; exact. + + apply: (@trans_eq _ _ 0%R); last first. + rewrite -{1}oppr0 -{1}HPQ -sumrN. + apply eq_bigr => a _; rewrite -mulrN. + case/boolP : (P a == 0) => [/eqP ->| H0]; first by rewrite !mul0r. + congr (_ * _). + have Qa0 := dominatesEN P_dom_by_Q H0. + by rewrite -logV ?invf_div// divr_gt0// -fdist_gt0. + by rewrite -big_distrl/= big_split/= sumrN !FDist.f1 subrr mul0r. Qed. End divergence_prop. diff --git a/probability/fdist.v b/probability/fdist.v index 135cd716..2bfcfcea 100644 --- a/probability/fdist.v +++ b/probability/fdist.v @@ -5,7 +5,7 @@ From mathcomp Require Import all_ssreflect ssralg fingroup perm matrix. From mathcomp Require Import all_algebra vector reals normedtype. From mathcomp Require Import mathcomp_extra boolp. From mathcomp Require Import Rstruct. -Require Import ssrR logb realType_ext ssr_ext ssralg_ext bigop_ext. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext. (******************************************************************************) (* Finite distributions *) @@ -14,7 +14,7 @@ Require Import ssrR logb realType_ext ssr_ext ssralg_ext bigop_ext. (* *) (* f @^-1 y == preimage of the point y via the function f where the *) (* type of x is an eqType *) -(* R.-fdist A} == the type of distributions over a finType A *) +(* R.-fdist A == the type of distributions over a finType A *) (* fdist_supp d := [set a | d a != 0] *) (* fdist1 == point-supported distribution *) (* fdistbind == of type fdist A -> (A -> fdist B) -> fdist B *) @@ -72,7 +72,7 @@ Require Import ssrR logb realType_ext ssr_ext ssralg_ext bigop_ext. Reserved Notation "{ 'fdist' T }" (at level 0, format "{ 'fdist' T }"). Reserved Notation "R '.-fdist' T" (at level 2, format "R '.-fdist' T"). Reserved Notation "'`U' C0 " (at level 10, C0 at next level). -Reserved Notation "P `^ n" (at level 5). +Reserved Notation "P `^ n" (at level 11). Reserved Notation "P `X W" (at level 6). Reserved Notation "P1 `x P2" (at level 6). Reserved Notation "x <| p |> y" (format "x <| p |> y", at level 49). @@ -139,8 +139,8 @@ Coercion FDist.f : fdist >-> finfun_of. HB.instance Definition _ R A := [isSub for @FDist.f R A]. HB.instance Definition _ R A := [Choice of fdist R A by <:]. -#[global] Hint Extern 0 (is_true (0 <= _)%R) => solve [exact: FDist.ge0] : core. -#[global] Hint Extern 0 (is_true (_ <= 1)%R) => solve [exact: FDist.le1] : core. +#[global] Hint Extern 0 (is_true (0 <= _)%mcR) => solve [exact: FDist.ge0] : core. +#[global] Hint Extern 0 (is_true (_ <= 1)%mcR) => solve [exact: FDist.le1] : core. Notation "R '.-fdist' T" := (fdist R T%type) : fdist_scope. Notation "{ 'fdist' T }" := (fdist Rdefinitions.R T%type) : fdist_scope. @@ -1139,13 +1139,13 @@ Variable R : realType. Variables (C : finType) (P : fdist R C) (k : nat) (s : {set 'rV[C]_k}). Lemma wolfowitz a b A B : 0 < A -> 0 < B -> - a <= \sum_(x in s) P `^ k x <= b -> - (forall x : 'rV_k, x \in s -> A <= P `^ k x <= B) -> + a <= \sum_(x in s) (P `^ k) x <= b -> + (forall x : 'rV_k, x \in s -> A <= (P `^ k) x <= B) -> a / B <= (#| s |)%:R <= b / A. Proof. move=> A0 B0 /andP [Ha Hb] H. have eq_le_ : forall x y, (x = y) -> (x <= y)%O. by move=> ? ? ? ? ->. -have HB : \sum_(x in s) P `^ _ x <= #|s|%:R * B. +have HB : \sum_(x in s) (P `^ _) x <= #|s|%:R * B. apply (@le_trans _ _ (\sum_(x in s) [fun _ => B] x)). by apply: ler_sum => /= i iA; move: (H i iA) => /andP []. rewrite -big_filter /= big_const_seq /= iter_addr /=. @@ -1154,7 +1154,7 @@ have HB : \sum_(x in s) P `^ _ x <= #|s|%:R * B. apply eq_le_. have [/= l el [ul ls] [pl sl]] := big_enumP _. by rewrite count_predT sl; congr (_%:R)%R. -have HA : (#|s|)%:R * A <= \sum_(x in s) P `^ _ x. +have HA : (#|s|)%:R * A <= \sum_(x in s) (P `^ _) x. apply (@le_trans _ _ (\sum_(x in s) [fun _ => A] x)); last first. by apply: ler_sum => i Hi /=; case/andP: (H i Hi). rewrite -big_filter /= big_const_seq /= iter_addr /=. @@ -1271,11 +1271,11 @@ move=> P; apply/fdist_ext => v. by rewrite fdist_rV_of_prodE fdist_prod_of_rVE row_mx_rbehead. Qed. -Lemma fdist_rV0 (x : 'rV[A]_0) (P: fdist R A) : P `^ 0 x = 1. +Lemma fdist_rV0 (x : 'rV[A]_0) (P: fdist R A) : (P `^ 0) x = 1. Proof. by rewrite fdist_rVE big_ord0. Qed. Lemma fdist_rVS n (x : 'rV[A]_n.+1) (P : fdist R A) : - P `^ n.+1 x = P (x ``_ ord0) * P `^ n (rbehead x). + (P `^ n.+1) x = P (x ``_ ord0) * (P `^ n) (rbehead x). Proof. rewrite 2!fdist_rVE big_ord_recl; congr (_ * _). by apply eq_bigr => i _; rewrite /rbehead mxE. @@ -1285,10 +1285,10 @@ Lemma fdist_rV1 (a : 'rV[A]_1) (P : fdist R A) : (P `^ 1) a = P (a ``_ ord0). Proof. by rewrite fdist_rVS fdist_rV0 mulr1. Qed. Lemma fdist_prod_of_fdist_rV n (P : fdist R A) : - fdist_prod_of_rV (P `^ n.+1) = P `x P `^ n. + fdist_prod_of_rV (P `^ n.+1) = P `x (P `^ n). Proof. apply/fdist_ext => /= -[a b]. -rewrite fdist_prod_of_rVE /= fdist_rVS fdist_prodE; congr (P _ * P `^ n _) => /=. +rewrite fdist_prod_of_rVE /= fdist_rVS fdist_prodE; congr (P _ * (P `^ n) _) => /=. by rewrite row_mx_row_ord0. by rewrite rbehead_row_mx. Qed. @@ -1698,7 +1698,7 @@ Local Open Scope ring_scope. Lemma rsum_rmul_rV_pmf_tnth (R : realType) A n k (P : fdist R A) : \sum_(t : 'rV[ 'rV[A]_n]_k) \prod_(m < k) (P `^ n) t ``_ m = 1. Proof. -transitivity (\sum_(j : {ffun 'I_k -> 'rV[A]_n}) \prod_(m : 'I_k) P `^ _ (j m)). +transitivity (\sum_(j : {ffun 'I_k -> 'rV[A]_n}) \prod_(m : 'I_k) (P `^ _) (j m)). rewrite (reindex_onto (fun p : 'rV_k => [ffun i => p ``_ i]) (fun x : {ffun 'I_k -> 'rV_n} => \row_(i < k) x i)) //=; last first. by move=> f _; apply/ffunP => /= k0; rewrite ffunE mxE. diff --git a/probability/fsdist.v b/probability/fsdist.v index 0839f539..26c400da 100644 --- a/probability/fsdist.v +++ b/probability/fsdist.v @@ -3,11 +3,10 @@ From HB Require Import structures. From mathcomp Require Import all_ssreflect ssralg ssrnum. From mathcomp Require Import finmap. -Require Import Reals. From mathcomp Require Import mathcomp_extra. -From mathcomp Require Import classical_sets boolp cardinality Rstruct reals. -From mathcomp Require Import ereal topology esum measure probability. -Require Import ssrR realType_ext Reals_ext ssr_ext ssralg_ext. +From mathcomp Require Import classical_sets boolp cardinality reals Rstruct. +From mathcomp Require ereal topology esum measure probability. +Require Import realType_ext (*Reals_ext*) ssr_ext ssralg_ext. Require Import bigop_ext fdist convex. (******************************************************************************) @@ -46,23 +45,17 @@ Require Import bigop_ext fdist convex. (******************************************************************************) Reserved Notation "{ 'dist' T }" (at level 0, format "{ 'dist' T }"). +Reserved Notation "R '.-dist' T" (at level 2, format "R '.-dist' T"). Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. Local Open Scope fset_scope. Local Open Scope fdist_scope. +Local Open Scope ring_scope. -Import Order.POrderTheory Num.Theory. - -Lemma fdist_Rgt0 (A : finType) (d : R.-fdist A) a : - (d a != 0) <-> (0 < d a)%coqR. -Proof. by rewrite fdist_gt0; split=> /RltP. Qed. -Lemma fdist_Rge0 (A : finType) (d : R.-fdist A) a : - 0 <= d a. -Proof. by apply/RleP; rewrite FDist.ge0. Qed. +Import Order.POrderTheory GRing.Theory Num.Theory. (* NB: PR to finmap in progress *) Lemma bigfcup_imfset (T I : choiceType) (P : {fset I}) (f : I -> T) : @@ -92,26 +85,24 @@ Arguments fbig_pred1_inj [R] [idx] [op] [A] [C] [h] [k]. Module FSDist. Section fsdist. +Variable R : realType. Variable A : choiceType. Record t := mk { f :> {fsfun A -> R with 0} ; - _ : all (fun x => (0 < f x)%mcR) (finsupp f) && + _ : all (fun x => 0 < f x) (finsupp f) && \sum_(a <- finsupp f) f a == 1}. Lemma ge0 (d : t) a : 0 <= d a. Proof. case: d => /= [f /andP[/allP f0 _]]. -have [/f0/RltP/ltRW|/fsfun_dflt->] := boolP (a \in finsupp f); first exact. -by apply/RleP; rewrite lexx. +have [/f0/ltW//|/fsfun_dflt->] := boolP (a \in finsupp f). +exact: lexx. Qed. -Lemma ge0' (d : t) a : (0 <= d a)%mcR. -Proof. by apply/RleP/ge0. Qed. - Lemma gt0 (d : t) a : a \in finsupp d -> 0 < d a. Proof. -by rewrite mem_finsupp => da; apply/RltP; rewrite lt0r da; exact/RleP/ge0. +by rewrite mem_finsupp => da; rewrite lt0r da; exact/ge0. Qed. Lemma f1 (d : t) : \sum_(a <- finsupp d) d a = 1. @@ -120,20 +111,17 @@ Proof. by case: d => f /= /andP[_ /eqP]. Qed. Lemma le1 (d : t) a : d a <= 1. Proof. have [ad|?] := boolP (a \in finsupp d); last by rewrite fsfun_dflt. -rewrite -(f1 d) (big_fsetD1 _ ad)/=; apply/leR_addl. -by apply/RleP/sumr_ge0 => ? _; exact/RleP/ge0. +rewrite -(f1 d) (big_fsetD1 _ ad)/=; rewrite lerDl. +by apply/sumr_ge0 => ? _; exact/ge0. Qed. -Lemma le1' (d : t) a : (d a <= 1)%mcR. -Proof. by apply/RleP/le1. Qed. - Obligation Tactic := idtac. Program Definition make (f : {fsfun A -> R with 0}) (H0 : forall a, a \in finsupp f -> 0 < f a) (H1 : \sum_(a <- finsupp f) f a = 1) : t := @mk f _. Next Obligation. -by move=> f H0 ->; rewrite eqxx andbT; apply/allP => a /H0/RltP. +by move=> f H0 ->; rewrite eqxx andbT; apply/allP => a /H0. Qed. End fsdist. @@ -142,34 +130,40 @@ Notation fsdist := FSDist.t. Coercion FSDist.f : FSDist.t >-> fsfun. Global Hint Resolve FSDist.ge0 : core. +Hint Extern 0 (is_true (0 <= _)) => solve [exact: FSDist.ge0] : core. +Hint Extern 0 (is_true (_ <= 1)) => solve [exact: FSDist.le1] : core. Section FSDist_canonical. +Context {R : realType}. Variable A : choiceType. -HB.instance Definition _ := [isSub for @FSDist.f A]. -HB.instance Definition _ := [Equality of fsdist A by <:]. -HB.instance Definition _ := [Choice of fsdist A by <:]. +HB.instance Definition _ := [isSub for @FSDist.f R A]. +HB.instance Definition _ := [Equality of fsdist R A by <:]. +HB.instance Definition _ := [Choice of fsdist R A by <:]. End FSDist_canonical. (*Definition FSDist_to_Type (A : choiceType) := fun phT : phant (Choice.sort A) => fsdist A. Local Notation "{ 'dist' T }" := (FSDist_to_Type (Phant T)).*) -Local Notation "{ 'dist' T }" := (fsdist T). +Notation "R '.-dist' T" := (fsdist R T%type). +Local Notation "{ 'dist' T }" := (fsdist Rdefinitions.R T%type). Section fsdist_prop. +Context {R : realType}. Variable A : choiceType. -Lemma fsdist_ext (d d' : {dist A}) : (forall x, d x = d' x) -> d = d'. +Lemma fsdist_ext (d d' : R.-dist A) : (forall x, d x = d' x) -> d = d'. Proof. by move=> ?; exact/val_inj/fsfunP. Qed. -Lemma fsdist_supp_neq0 (d : {dist A}) : finsupp d != fset0. +Lemma fsdist_supp_neq0 (d : R.-dist A) : finsupp d != fset0. Proof. apply/eqP => d0. -by move: (FSDist.f1 d); rewrite d0 big_nil => /esym; exact: R1_neq_R0. +by move: (FSDist.f1 d); rewrite d0 big_nil => /esym; exact/eqP/oner_neq0. Qed. End fsdist_prop. Section fsdist1. +Context {R : realType}. Variables (A : choiceType) (a : A). Let D := [fset a]. @@ -179,7 +173,7 @@ Let f : {fsfun A -> R with 0} := [fsfun b in D => 1 | 0]. Let suppf : finsupp f = D. Proof. apply/fsetP => b; rewrite mem_finsupp /f fsfunE inE. -by case: ifPn => ba; [exact/gtR_eqF | by rewrite eqxx]. +by case: ifPn=> ba; rewrite ?oner_neq0 ?eqxx. Qed. Let f0 b : b \in finsupp f -> 0 < f b. @@ -188,7 +182,8 @@ Proof. by rewrite mem_finsupp fsfunE inE; case: ifPn => //; rewrite eqxx. Qed. Let f1 : \sum_(b <- finsupp f) f b = 1. Proof. by rewrite suppf big_seq_fset1 /f fsfunE inE eqxx. Qed. -Definition fsdist1 : {dist A} := locked (FSDist.make f0 f1). +(* TODO simpl never *) +Definition fsdist1 : R.-dist A := locked (FSDist.make f0 f1). Lemma fsdist1E a0 : fsdist1 a0 = if a0 \in D then 1 else 0. Proof. by rewrite /fsdist1; unlock; rewrite fsfunE. Qed. @@ -206,15 +201,16 @@ Proof. by move=> a0a; rewrite fsdist1E /D inE (negbTE a0a). Qed. End fsdist1. -Lemma fsdist1_inj (C : choiceType) : injective (@fsdist1 C). +Lemma fsdist1_inj {R : realType} (C : choiceType) : injective (@fsdist1 R C). Proof. move=> a b /eqP ab; apply/eqP; apply: contraTT ab => ab. -apply/eqP => /(congr1 (fun x : FSDist.t _ => x a)). -rewrite !fsdist1E !inE eqxx (negbTE ab); exact: R1_neq_R0. +apply/eqP => /(congr1 (fun x : FSDist.t R _ => x a)). +by rewrite !fsdist1E !inE eqxx (negbTE ab); exact/eqP/oner_neq0. Qed. Section fsdistbind. -Variables (A B : choiceType) (p : {dist A}) (g : A -> {dist B}). +Context {R : realType}. +Variables (A B : choiceType) (p : R.-dist A) (g : A -> R.-dist B). Let D := \bigcup_(d <- g @` finsupp p) finsupp d. @@ -223,9 +219,9 @@ Let f : {fsfun B -> R with 0} := Let f0 b : b \in finsupp f -> 0 < f b. Proof. -rewrite mem_finsupp fsfunE; case: ifPn => [_ /eqP/nesym ?|]; last by rewrite eqxx. -rewrite ltR_neqAle; split => //; apply/RleP/sumr_ge0 => a _. -by rewrite mulr_ge0//; exact/RleP. +rewrite mem_finsupp fsfunE; case: ifPn => [_ H|]; last by rewrite eqxx. +rewrite lt_neqAle [X in ~~ X && _]eq_sym H /= sumr_ge0 // => *. +exact:mulr_ge0. Qed. Let f1 : \sum_(b <- finsupp f) f b = 1. @@ -234,11 +230,11 @@ rewrite {2}/f. under eq_bigr do rewrite fsfunE. rewrite -big_mkcond /= exchange_big /=. rewrite -[RHS](FSDist.f1 p); apply eq_bigr => a _. -have [->|pa0] := eqVneq (p a) 0%coqR. - by rewrite big1 // => *; rewrite mul0R. -rewrite -big_distrr /= (_ : \sum_(_ <- _ | _) _ = 1) ?mulR1 //. +have [->|pa0] := eqVneq (p a) 0. + by rewrite big1 // => *; rewrite mul0r. +rewrite -big_distrr /= (_ : \sum_(_ <- _ | _) _ = 1) ?mulr1 //. rewrite (bigID (mem (finsupp (g a)))) /=. -rewrite [X in (_ + X)%coqR = _]big1 ?addR0; last first. +rewrite [X in _ + X = _]big1 ?addr0; last first. by move=> b /andP[_]; rewrite memNfinsupp => /eqP. rewrite (eq_bigl (fun i => i \in finsupp (g a))); last first. move=> b; rewrite andb_idl // mem_finsupp => gab0. @@ -252,14 +248,13 @@ rewrite mem_filter 2!mem_finsupp gab0 /= /f fsfunE ifT; last first. apply/bigfcupP; exists (g a); rewrite ?mem_finsupp // andbT. by apply/imfsetP; exists a => //; rewrite mem_finsupp. apply: contra gab0; rewrite psumr_eq0; last first. - by move=> a0 _; rewrite RmultE mulr_ge0//; exact/RleP. + by move=> a0 _; rewrite mulr_ge0//. move=> /allP H. -suff : p a * g a b = 0. - by rewrite mulR_eq0 => -[/eqP|->//]; rewrite (negbTE pa0). -by apply/eqP/H; rewrite mem_finsupp. +suff : p a * g a b == 0 by rewrite mulrI_eq0 //; apply/lregP. +by apply/H; rewrite mem_finsupp. Qed. -Definition fsdistbind : {dist B} := locked (FSDist.make f0 f1). +Definition fsdistbind : R.-dist B := locked (FSDist.make f0 f1). Lemma fsdistbindEcond x : fsdistbind x = if x \in D then \sum_(a <- finsupp p) p a * (g a) x else 0. @@ -270,18 +265,18 @@ Proof. rewrite fsdistbindEcond. case: ifPn => // aD. apply/eqP; move: aD; apply: contraLR. -rewrite eq_sym negbK sumR_neq0; last by move=> ?; exact: mulR_ge0. -case => i [] suppi pg0. +rewrite eq_sym negbK psumr_neq0; last by move=> *; exact: mulr_ge0. +case/hasP => i suppi /= pg0. apply/bigfcupP; exists (g i). - by rewrite in_imfset. -- by rewrite mem_finsupp; apply/gtR_eqF/(pmulR_rgt0' pg0). +- by rewrite mem_finsupp gt_eqF // (wpmulr_rgt0 _ pg0). Qed. Lemma fsdistbindEwiden S x : finsupp p `<=` S -> fsdistbind x = \sum_(a <- S) p a * (g a) x. Proof. move=> suppS; rewrite fsdistbindE (big_fset_incl _ suppS) //. -by move=> a2 Ha2; rewrite memNfinsupp => /eqP ->; rewrite mul0R. +by move=> a2 Ha2; rewrite memNfinsupp => /eqP ->; rewrite mul0r. Qed. Lemma supp_fsdistbind : finsupp fsdistbind = D. @@ -290,14 +285,9 @@ apply/fsetP => b; rewrite mem_finsupp; apply/idP/idP => [|]. by rewrite fsdistbindEcond; case: ifPn => //; rewrite eqxx. case/bigfcupP => dB. rewrite andbT => /imfsetP[a] /= ap ->{dB} bga. -rewrite fsdistbindE. -apply/eqP => H. -have : p a * g a b <> 0. - by rewrite mulR_eq0 => -[]; apply/eqP; rewrite -mem_finsupp. -apply. -move/eqP : H; rewrite psumr_eq0; last first. - by move=> a0 _; rewrite RmultE mulr_ge0//; exact/RleP. -by move=> /allP H; exact/eqP/H. +rewrite fsdistbindE psumr_neq0; last by move=> *; exact/mulr_ge0. +apply/hasP; exists a=> //=. +by rewrite mulr_gt0 // FSDist.gt0. Qed. End fsdistbind. @@ -308,50 +298,53 @@ Reserved Notation "m >>= f" (at level 49). Notation "m >>= f" := (fsdistbind m f) : fsdist_scope. Local Open Scope fsdist_scope. -Lemma fsdist1bind (A B : choiceType) (a : A) (f : A -> {dist B}) : +Section fsdist_lemmas. +Context {R : realType}. + +Lemma fsdist1bind (A B : choiceType) (a : A) (f : A -> R.-dist B) : fsdist1 a >>= f = f a. Proof. apply/val_inj/val_inj => /=; congr fmap_of_fsfun; apply/fsfunP => b. -by rewrite fsdistbindE supp_fsdist1 big_seq_fset1 fsdist1xx mul1R. +by rewrite fsdistbindE supp_fsdist1 big_seq_fset1 fsdist1xx mul1r. Qed. -Lemma fsdistbind1 (A : choiceType) (p : {dist A}) : p >>= @fsdist1 A = p. +Lemma fsdistbind1 (A : choiceType) (p : R.-dist A) : p >>= @fsdist1 R A = p. Proof. apply/val_inj/val_inj => /=; congr fmap_of_fsfun; apply/fsfunP => b. rewrite fsdistbindEcond; case: ifPn => [|H]. case/bigfcupP => /= d; rewrite andbT. case/imfsetP => /= a ap ->{d}. rewrite supp_fsdist1 inE => /eqP ->{b}. - rewrite (big_fsetD1 a) //= fsdist1xx mulR1 big1_fset ?addR0 // => a0. - by rewrite !inE => /andP[aa0] a0p _; rewrite fsdist10 ?mulR0// eq_sym. -have [->//|pb0] := eqVneq (p b) 0%coqR. + rewrite (big_fsetD1 a) //= fsdist1xx mulr1 big1_fset ?addr0 // => a0. + by rewrite !inE => /andP[aa0] a0p _; rewrite fsdist10 ?mulr0// eq_sym. +have [->//|pb0] := eqVneq (p b) 0. case/bigfcupP : H. exists (fsdist1 b); last by rewrite supp_fsdist1 inE. by rewrite andbT; apply/imfsetP; exists b => //=; rewrite mem_finsupp. Qed. -Lemma fsdistbindA (A B C : choiceType) (m : {dist A}) (f : A -> {dist B}) - (g : B -> {dist C}) : +Lemma fsdistbindA (A B C : choiceType) (m : R.-dist A) (f : A -> R.-dist B) + (g : B -> R.-dist C) : (m >>= f) >>= g = m >>= (fun x => f x >>= g). Proof. apply/val_inj/val_inj => /=; congr fmap_of_fsfun; apply/fsfunP => c. rewrite !fsdistbindE. under eq_bigr do rewrite fsdistbindE big_distrl. under [in RHS]eq_bigr do - (rewrite fsdistbindE big_distrr /=; under eq_bigr do rewrite mulRA). + (rewrite fsdistbindE big_distrr /=; under eq_bigr do rewrite mulrA). rewrite exchange_big /= !big_seq; apply: eq_bigr => a a_m. rewrite supp_fsdistbind; apply/esym/big_fset_incl => [| b]. apply/fsubsetP => ? ?; apply/bigfcupP => /=. by exists (f a) => //; rewrite andbT in_imfset. case/bigfcupP => ?; rewrite andbT; case/imfsetP => ? /= ? -> ?. rewrite mem_finsupp negbK => /eqP ->. -by rewrite mulR0 mul0R. +by rewrite mulr0 mul0r. Qed. -Definition fsdistmap (A B : choiceType) (f : A -> B) (d : {dist A}) : {dist B} := +Definition fsdistmap (A B : choiceType) (f : A -> B) (d : R.-dist A) : R.-dist B := d >>= (fun a => fsdist1 (f a)). -Lemma fsdistmap_id (A : choiceType) : fsdistmap (@id A) = @id {dist A}. +Lemma fsdistmap_id (A : choiceType) : fsdistmap (@id A) = @id (R.-dist A). Proof. by rewrite boolp.funeqE => a; rewrite /fsdistmap fsdistbind1. Qed. Lemma fsdistmap_comp (A B C : choiceType) (g : B -> C) (h : A -> B) : @@ -361,13 +354,13 @@ rewrite boolp.funeqE => d; rewrite /fsdistmap /= fsdistbindA; congr (_ >>= _). by rewrite boolp.funeqE => a; rewrite fsdist1bind. Qed. -Definition fsdistmapE (A B : choiceType) (f : A -> B) (d : {dist A}) b : +Definition fsdistmapE (A B : choiceType) (f : A -> B) (d : R.-dist A) b : fsdistmap f d b = \sum_(a <- finsupp d | f a == b) d a. Proof. rewrite {1}/fsdistmap [in LHS]fsdistbindE (bigID (fun a => f a == b)) /=. -rewrite [X in (_ + X)%R = _](_ : _ = 0) ?addR0; last first. - by rewrite big1 // => a fab; rewrite fsdist10 ?mulR0// eq_sym. -by apply eq_bigr => a /eqP ->; rewrite fsdist1xx mulR1. +rewrite [X in (_ + X)%R = _](_ : _ = 0) ?addr0; last first. + by rewrite big1 // => a fab; rewrite fsdist10 ?mulr0// eq_sym. +by apply eq_bigr => a /eqP ->; rewrite fsdist1xx mulr1. Qed. Lemma supp_fsdistmap (A B : choiceType) (f : A -> B) d : @@ -386,8 +379,8 @@ Lemma fsdistmap1 (A B : choiceType) (f : A -> B) x : fsdistmap f (fsdist1 x) = fsdist1 (f x). Proof. by rewrite /fsdistmap fsdist1bind. Qed. -Lemma fsdist1map (C : choiceType) (d : {dist C}) (c : C) : - fsdistmap (@fsdist1 C) d (fsdist1 c) = d c. +Lemma fsdist1map (C : choiceType) (d : R.-dist C) (c : C) : + fsdistmap (@fsdist1 R C) d (fsdist1 c) = d c. Proof. rewrite fsdistmapE. case/boolP: (c \in finsupp d)=> ifd. @@ -399,39 +392,41 @@ rewrite big_seq_cond big_pred0; last first. by rewrite fsfun_dflt. Qed. -Local Open Scope reals_ext_scope. -Lemma fsdist_suppD1 (C : choiceType) (d : {dist C}) (x : C) : +Lemma fsdist_suppD1 (C : choiceType) (d : R.-dist C) (x : C) : \sum_(i <- finsupp d `\ x) d i = (d x).~. Proof. -rewrite -subR_eq0. -rewrite RminusE subr_onem -RplusE -RoppE -R1E addR_opp -RplusE. +apply/eqP; rewrite -subr_eq0 subr_onem. case/boolP: (x \in finsupp d)=> xfd. - by rewrite addRC -big_fsetD1 //= FSDist.f1 subRR. -by rewrite fsfun_dflt // mem_fsetD1 // FSDist.f1 addR0 subRR. + by rewrite [X in X - 1]addrC -big_fsetD1 //= FSDist.f1 subrr. +by rewrite fsfun_dflt // mem_fsetD1 // FSDist.f1 addr0 subrr. Qed. -Local Close Scope reals_ext_scope. -Definition FSDist_prob (C : choiceType) (d : {dist C}) (x : C) : {prob R} := - Eval hnf in Prob.mk_ (andb_true_intro (conj (FSDist.ge0' d x) (FSDist.le1' d x))). +(*TODO Local Close Scope reals_ext_scope.*) + +Definition FSDist_prob (C : choiceType) (d : R.-dist C) (x : C) : {prob R} := + Eval hnf in Prob.mk_ (andb_true_intro (conj (FSDist.ge0 d x) (FSDist.le1 d x))). Canonical FSDist_prob. -Definition fsdistjoin A (D : {dist {dist A}}) : {dist A} := +Definition fsdistjoin A (D : R.-dist (R.-dist A)) : R.-dist A := D >>= ssrfun.id. -Lemma fsdistjoinE A (D : {dist {dist A}}) x : +Lemma fsdistjoinE A (D : R.-dist (R.-dist A)) x : fsdistjoin D x = \sum_(d <- finsupp D) D d * d x. Proof. by rewrite /fsdistjoin fsdistbindE. Qed. -Lemma fsdistjoin1 (A : choiceType) (D : {dist {dist A}}) : +Lemma fsdistjoin1 (A : choiceType) (D : R.-dist (R.-dist A)) : fsdistjoin (fsdist1 D) = D. Proof. apply/fsdist_ext => d. -by rewrite fsdistjoinE supp_fsdist1 big_imfset // big_seq1 fsdist1xx mul1R. +by rewrite fsdistjoinE supp_fsdist1 big_imfset // big_seq1 fsdist1xx mul1r. Qed. +End fsdist_lemmas. + Module FSDist_crop0. Section def. -Variables (A : choiceType) (P : {dist A}). +Context {R : realType}. +Variables (A : choiceType) (P : R.-dist A). Definition D := [fset a : finsupp P | true]. Definition f' : {ffun finsupp P -> R} := [ffun a => P (fsval a)]. Definition f : {fsfun finsupp P -> R with 0} := [fsfun x in D => f' x | 0]. @@ -452,14 +447,15 @@ rewrite (reindex h) /=. by exists (@fsval _ _) => //= -[a] *; exact: val_inj. Qed. -Definition d : {dist finsupp P} := FSDist.make f0 f1. +Definition d : R.-dist (finsupp P) := FSDist.make f0 f1. End def. End FSDist_crop0. Module FSDist_lift_supp. Section def. -Variables (A B : choiceType) (r : A -> B) (P : {dist B}) +Context {R : realType}. +Variables (A B : choiceType) (r : A -> B) (P : R.-dist B) (s : B -> A) (H : cancel s r). Definition D := [fset s b | b in finsupp P]. @@ -492,7 +488,7 @@ apply/eqP; case: ifPn => //; apply: contraNT => Pi0. by apply/imfsetP => /=; exists i => //; rewrite mem_finsupp eq_sym. Qed. -Definition d : {dist A} := locked (FSDist.make f0 f1). +Definition d : R.-dist A := locked (FSDist.make f0 f1). Lemma dE a : d a = if a \in [fset s b | b in finsupp P] then P (r a) else 0. Proof. by rewrite /d; unlock => /=; rewrite fsfunE. Qed. @@ -502,6 +498,7 @@ End FSDist_lift_supp. Module FSDist_of_fdist. Section def. +Context {R : realType}. Variable (A : finType) (P : R.-fdist A). Let D := [fset a0 : A | P a0 != 0]. @@ -510,13 +507,13 @@ Definition f : {fsfun A -> R with 0} := [fsfun a in D => P a | 0]. Let f0 a : a \in finsupp f -> 0 < f a. Proof. rewrite fsfunE mem_finsupp /f fsfunE. -case: ifPn => [_|]; by [rewrite fdist_Rgt0 | rewrite eqxx]. +case: ifPn => [_|]; by [rewrite fdist_gt0 | rewrite eqxx]. Qed. Let f1 : \sum_(a <- finsupp f) f a = 1. Proof. rewrite -[RHS](FDist.f1 P) [in RHS](bigID (mem (finsupp f))) /=. -rewrite [in X in _ = (_ + X)%coqR]big1 ?addR0; last first. +rewrite [in X in _ = (_ + X)]big1 ?addr0; last first. move=> a; rewrite memNfinsupp fsfunE !inE /=. by case: ifPn => [_ /eqP //|]; rewrite negbK => /eqP. rewrite (@eq_fbigr _ _ _ _ _ _ _ P) /=; last first. @@ -525,13 +522,14 @@ rewrite (@eq_fbigr _ _ _ _ _ _ _ P) /=; last first. exact/big_uniq/fset_uniq. Qed. -Definition d : {dist A} := FSDist.make f0 f1. +Definition d : R.-dist A := FSDist.make f0 f1. End def. End FSDist_of_fdist. Module fdist_of_FSDist. Section def. -Variable (A : choiceType) (P : {dist A}). +Context {R : realType}. +Variable (A : choiceType) (P : R.-dist A). Definition D := finsupp P : finType. Definition f := [ffun d : D => P (fsval d)]. Lemma f0 b : 0 <= f b. Proof. by rewrite ffunE. Qed. @@ -539,10 +537,8 @@ Lemma f1 : \sum_(b in D) f b = 1. Proof. rewrite -(FSDist.f1 P) big_seq_fsetE /=; apply eq_bigr => a; by rewrite ffunE. Qed. -Lemma f0' b : (0 <= f b)%O. (* TODO: we shouldn't see %O *) -Proof. exact/RleP/f0. Qed. -Definition d : R.-fdist D := locked (FDist.make f0' f1). +Definition d : R.-fdist D := locked (FDist.make f0 f1). End def. Module Exports. Notation fdist_of_fs := d. @@ -551,7 +547,8 @@ End fdist_of_FSDist. Export fdist_of_FSDist.Exports. Section fdist_of_FSDist_lemmas. -Variable (A : choiceType) (d : {dist A}). +Context {R : realType}. +Variable (A : choiceType) (d : R.-dist A). Lemma fdist_of_fsE i : fdist_of_fs d i = d (fsval i). Proof. by rewrite /fdist_of_fs; unlock; rewrite ffunE. Qed. @@ -563,22 +560,21 @@ End fdist_of_FSDist_lemmas. Module fdist_of_finFSDist. Section def. -Variable (A : finType) (P : {dist A}). +Context {R : realType}. +Variable (A : finType) (P : R.-dist A). Definition f := [ffun d : A => P d]. Lemma f0 b : 0 <= f b. Proof. by rewrite ffunE. Qed. -Lemma f0' b : (0 <= f b)%O. Proof. exact/RleP/f0. Qed. - Lemma f1 : \sum_(b in A) f b = 1. Proof. rewrite -(FSDist.f1 P) (bigID (fun x => x \in finsupp P)) /=. -rewrite [X in (_ + X = _)%coqR](_ : _ = 0) ?addR0. +rewrite [X in (_ + X = _)](_ : _ = 0) ?addr0. by rewrite big_uniq /= ?fset_uniq //; apply eq_bigr => i _; rewrite ffunE. by rewrite big1 // => a; rewrite mem_finsupp negbK ffunE => /eqP. Qed. -Definition d : R.-fdist A := locked (FDist.make f0' f1). +Definition d : R.-fdist A := locked (FDist.make f0 f1). Lemma dE a : d a = P a. Proof. by rewrite /d; unlock; rewrite ffunE. Qed. @@ -591,8 +587,9 @@ End fdist_of_finFSDist. Export fdist_of_finFSDist.Exports. Section fsdist_conv_def. -Variables (A : choiceType) (p : {prob R}) (d1 d2 : {dist A}). -Local Open Scope reals_ext_scope. +Context {R : realType}. +Variables (A : choiceType) (p : {prob R}) (d1 d2 : R.-dist A). +(*Local Open Scope reals_ext_scope.*) Local Open Scope convex_scope. Let D : {fset A} := @@ -600,7 +597,7 @@ Let D : {fset A} := else if p == 1%:pr then finsupp d1 else finsupp d1 `|` finsupp d2. -Let f := [fsfun a in D => d1 a <| p |> d2 a | 0]. +Let f := [fsfun a in D => (d1 a : R^o) <| p |> d2 a | 0]. Let supp : finsupp f = D. Proof. @@ -608,26 +605,26 @@ apply/fsetP => a; rewrite /f /D. case: ifPn; [|case: ifPn]; rewrite !mem_finsupp fsfunE ?inE !mem_finsupp avgRE. - move/eqP => -> /=. - rewrite onem0 mul1R mul0R add0R. + rewrite onem0 mul1r mul0r add0r. by case: ifP => //; rewrite eqxx. - move/eqP => -> /=. - rewrite onem1 mul1R mul0R addR0. + rewrite onem1 mul1r mul0r addr0. by case: ifP => //; rewrite eqxx. - move => /[swap] /prob_gt0 p0 /onem_neq0 /prob_gt0 /= p1. case:ifPn; last by rewrite eqxx. - by move => /orP[dj0|ej0]; apply/gtR_eqF; - [apply/addR_gt0wl; last exact/mulR_ge0; - apply/mulR_gt0 => //; apply/ltR_neqAle; split => //; apply/nesym/eqP => //; rewrite gt_eqF | - apply/addR_gt0wr; first exact/mulR_ge0; - apply/mulR_gt0 => //; apply/ltR_neqAle; split => //; apply/nesym/eqP => //; rewrite gt_eqF]. + move => /orP[dj0|ej0]; rewrite gt_eqF //. + apply/ltr_pwDl; last exact/mulr_ge0. + by rewrite mulr_gt0 // lt_neqAle eq_sym dj0 /=. + apply/ltr_pwDr; last exact/mulr_ge0. + by rewrite mulr_gt0 // lt_neqAle eq_sym ej0 /=. Qed. Let f0 a : a \in finsupp f -> 0 < f a. Proof. move => /[dup]; rewrite {1}supp => aD. -rewrite /f ltR_neqAle mem_finsupp eq_sym => /eqP ?; split => //. +rewrite /f lt_neqAle mem_finsupp eq_sym => -> /=. rewrite /f fsfunE avgRE aD. -by apply/RleP; rewrite RplusE !RmultE addr_ge0// mulr_ge0//. +by rewrite !addr_ge0. Qed. Let f1 : \sum_(a <- finsupp f) f a = 1. @@ -635,20 +632,20 @@ Proof. under eq_big_seq => b /[!supp] bD do rewrite /f fsfunE bD. rewrite supp; under eq_bigr do rewrite avgRE. rewrite /D; case: ifPn; [|case: ifPn]. -- by move/eqP ->; under eq_bigr do rewrite onem0 mul0R mul1R add0R; rewrite FSDist.f1. -- by move/eqP ->; under eq_bigr do rewrite onem1 mul0R mul1R addR0; rewrite FSDist.f1. +- by move/eqP ->; under eq_bigr do rewrite onem0 mul0r mul1r add0r; rewrite FSDist.f1. +- by move/eqP ->; under eq_bigr do rewrite onem1 mul0r mul1r addr0; rewrite FSDist.f1. - move=> /prob_lt1 p1 /prob_gt0 p0. rewrite big_split /=. rewrite -(big_fset_incl _ (fsubsetUl (finsupp d1) (finsupp d2))); last first. - by move=> a _; rewrite mem_finsupp negbK => /eqP ->; rewrite mulR0. + by move=> a _; rewrite mem_finsupp negbK => /eqP ->; rewrite mulr0. rewrite -(big_fset_incl _ (fsubsetUr (finsupp d1) (finsupp d2))); last first. - by move=> a _; rewrite mem_finsupp negbK => /eqP ->; rewrite mulR0. -by rewrite -!big_distrr !FSDist.f1 /= !RmultE !GRing.mulr1 RplusE onemKC. + by move=> a _; rewrite mem_finsupp negbK => /eqP ->; rewrite mulr0. +by rewrite -!big_distrr !FSDist.f1 /= !mulr1 onemKC. Qed. -Definition fsdist_conv : {dist A} := locked (FSDist.make f0 f1). +Definition fsdist_conv : R.-dist A := locked (FSDist.make f0 f1). -Lemma fsdist_convE a : fsdist_conv a = d1 a <| p |> d2 a. +Lemma fsdist_convE a : fsdist_conv a = (d1 a : R^o) <| p |> d2 a. Proof. rewrite /fsdist_conv -lock fsfunE. case: ifPn => //. @@ -665,9 +662,10 @@ Proof. by rewrite /fsdist_conv -lock supp. Qed. End fsdist_conv_def. Section fsdist_convType. +Context {R : realType}. Variables (A : choiceType). -Implicit Types (p q : {prob R}) (a b c : {dist A}). -Local Open Scope reals_ext_scope. +Implicit Types (p q : {prob R}) (a b c : R.-dist A). +(*Local Open Scope reals_ext_scope.*) Local Notation "x <| p |> y" := (fsdist_conv p x y) : fsdist_scope. @@ -677,7 +675,7 @@ Proof. by apply/fsdist_ext => ?; rewrite fsdist_convE conv0. Qed. Let conv1 a b : a <| 1%:pr |> b = a. Proof. by apply/fsdist_ext => ?; rewrite fsdist_convE conv1. Qed. -Let convmm p : idempotent (fun x y => x <| p |> y : {dist A}). +Let convmm p : idempotent_op (fun x y => x <| p |> y : R.-dist A). Proof. by move=> d; apply/fsdist_ext => ?; rewrite fsdist_convE convmm. Qed. Let convC p a b : a <| p |> b = b <| (Prob.p p).~%:pr |> a. @@ -688,15 +686,16 @@ Let convA p q a b c : Proof. by apply/fsdist_ext=> ?; rewrite !fsdist_convE convA. Qed. HB.instance Definition _ := - @isConvexSpace.Build (FSDist.t _) (@fsdist_conv A) + @isConvexSpace.Build _ (FSDist.t _ _) (@fsdist_conv R A) conv1 convmm convC convA. End fsdist_convType. Section fsdist_conv_prop. +Context {R : realType}. Variables (A : choiceType). -Implicit Types (p : {prob R}) (a b c : {dist A}). -Local Open Scope reals_ext_scope. +Implicit Types (p : {prob R}) (a b c : R.-dist A). +(*Local Open Scope reals_ext_scope.*) Local Open Scope convex_scope. Lemma finsupp_conv_subr a b p : @@ -715,7 +714,7 @@ apply: contra p1 => /eqP/(congr1 val) /= /onem_eq0 p1. exact/eqP/val_inj. Qed. -Lemma fsdist_conv_bind_left_distr (B : choiceType) p a b (f : A -> {dist B}) : +Lemma fsdist_conv_bind_left_distr (B : choiceType) p a b (f : A -> R.-dist B) : (a <| p |> b) >>= f = (a >>= f) <| p |> (b >>= f). Proof. apply/fsdist_ext => b0 /=; rewrite fsdistbindE fsdist_convE. @@ -723,7 +722,8 @@ have [->|p0] := eqVneq p 0%:pr. by rewrite 2!conv0 fsdistbindE. have [->|p1] := eqVneq p 1%:pr. by rewrite 2!conv1 fsdistbindE. -under eq_bigr do rewrite fsdist_convE avgR_mulDl avgRE. +under eq_bigr do rewrite fsdist_convE avgRE mulrDl -!mulrA. +(*under eq_bigr do rewrite fsdist_convE avgR_mulDl avgRE.*) rewrite big_split -2!big_distrr /=. by rewrite -!fsdistbindEwiden // ?finsupp_conv_subl ?finsupp_conv_subr. Qed. @@ -732,7 +732,7 @@ Lemma supp_fsdist_conv p (p0 : p != 0%:pr) (p1 : p != 1%:pr) a b : finsupp (a <|p|> b) = finsupp a `|` finsupp b. Proof. by rewrite supp_fsdist_conv' (negPf p0) (negPf p1). Qed. -Lemma fsdist_scalept_conv (C : convType) (x y : {dist C}) (p : {prob R}) (i : C) : +Lemma fsdist_scalept_conv (C : convType R) (x y : R.-dist C) (p : {prob R}) (i : C) : scalept ((x <|p|> y) i) (S1 i) = scalept (x i) (S1 i) <|p|> scalept (y i) (S1 i). Proof. by rewrite fsdist_convE scalept_conv. Qed. @@ -748,52 +748,53 @@ Local Open Scope proba_scope. Local Open Scope convex_scope. Section FSDist_affine_instances. +Context {R : realType}. Variable A B : choiceType. -Lemma fsdistmap_affine (f : A -> B) : affine (fsdistmap f). +Lemma fsdistmap_affine (f : A -> B) : @affine R _ _ (fsdistmap f). Proof. by move=> ? ? ?; rewrite /fsdistmap fsdist_conv_bind_left_distr. Qed. HB.instance Definition _ (f : A -> B) := - isAffine.Build _ _ _ (fsdistmap_affine f). + isAffine.Build _ _ _ _ (fsdistmap_affine f). -Definition fsdist_eval (x : A) := fun D : {dist A} => D x. +Definition fsdist_eval (x : A) := fun D : R.-dist A => (D x: R^o). -Lemma fsdist_eval_affine (x : A) : affine (fsdist_eval x). +Lemma fsdist_eval_affine (x : A) : @affine R _ R^o (fsdist_eval x). Proof. by move=> a b p; rewrite /fsdist_eval fsdist_convE. Qed. HB.instance Definition _ (x : A) := - isAffine.Build _ _ _ (fsdist_eval_affine x). + isAffine.Build _ _ _ _ (fsdist_eval_affine x). End FSDist_affine_instances. Section fsdist_convn_lemmas. +Context {R : realType}. Local Open Scope fdist_scope. -Variables (A : choiceType) (n : nat) (e : {fdist 'I_n}) (g : 'I_n -> {dist A}). +Variables (A : choiceType) (n : nat) (e : R.-fdist 'I_n) (g : 'I_n -> R.-dist A). Lemma fsdist_convnE x : (<|>_e g) x = \sum_(i < n) e i * g i x. Proof. by rewrite -/(fsdist_eval x _) Convn_comp /= /fsdist_eval avgnRE. Qed. (*TODO: unused, remove?*) Lemma supp_fsdist_convn : - finsupp (<|>_e g) = \big[fsetU/fset0]_(i < n | (0 < e i)%mcR) finsupp (g i). + finsupp (<|>_e g) = \big[fsetU/fset0]_(i < n | (0 < e i)) finsupp (g i). Proof. apply/fsetP => a; apply/idP/idP => [|]; rewrite mem_finsupp fsdist_convnE. - case/sumR_neq0 => /=; first by move=> ?; apply: mulR_ge0. - move=> j [] /= ? eg0. + rewrite psumr_neq0 /=; last by move=> *; rewrite mulr_ge0. + case/hasP=> /= j jn eg0. apply/bigfcupP. - exists j; first by apply/andP; split=> //; exact/RltP/(pmulR_lgt0' eg0). - rewrite mem_finsupp gtR_eqF //. - exact/(pmulR_rgt0' eg0). -case/bigfcupP=> j /andP [] ? /RltP ? /[!mem_finsupp] /prob_gt0 /= ?. -apply/sumR_neq0; first by move=> ?; apply/mulR_ge0. -by exists j; split=> //; apply/mulR_gt0 => //; exact/RltP. + exists j; first by rewrite jn /= (wpmulr_lgt0 _ eg0). + by rewrite mem_finsupp gt_eqF // (wpmulr_rgt0 _ eg0). +case/bigfcupP=> j /andP [] ? ? /[!mem_finsupp] /prob_gt0 /= ?. +rewrite psumr_neq0 /=; last by move=> *; rewrite mulr_ge0. +by apply/hasP; exists j=> //; rewrite mulr_gt0. Qed. End fsdist_convn_lemmas. (*HB.instance Definition _ a := isAffine.Build _ _ _ (af a). -Definition fsdist_eval (x : A) := fun D : {dist A} => D x. +Definition fsdist_eval (x : A) := fun D : R.-dist A => D x. Lemma fsdist_eval_affine (x : A) : affine (fsdist_eval x). Proof. by move=> a b p; rewrite /fsdist_eval fsdist_convE. Qed. @@ -805,18 +806,19 @@ HB.instance Definition _ (x : A) := (*Section fsdist_ordered_convex_space. Variable A : choiceType. -(*Definition fsdist_orderedConvMixin := @OrderedConvexSpace.Mixin {dist A}. +(*Definition fsdist_orderedConvMixin := @OrderedConvexSpace.Mixin R.-dist A. NB: not used?*) End fsdist_ordered_convex_space.*) Section Convn_of_FSDist. Local Open Scope classical_set_scope. -Variable C : convType. +Context {R : realType}. +Variable C : convType R. -Definition Convn_of_fsdist (d : {dist C}) : C := +Definition Convn_of_fsdist (d : R.-dist C) : C := <$>_(fdist_of_fs d) (fun x : finsupp d => fsval x). -Lemma ssum_seq_finsuppE'' (D : convType) (f : C -> D) (d x : {dist C}) : +Lemma ssum_seq_finsuppE'' (D : convType R) (f : C -> D) (d x : R.-dist C) : \ssum_(i : fdist_of_FSDist.D d) scalept (x (fsval i)) (S1 (f (fsval i))) = \ssum_(i <- finsupp d) scalept (x i) (S1 (f i)). Proof. @@ -825,14 +827,14 @@ by rewrite -(@big_seq_fsetE (fun i => scalept (x i) (S1 (f i)))). Qed. -Lemma ssum_seq_finsuppE' (d x : {dist C}) : +Lemma ssum_seq_finsuppE' (d x : R.-dist C) : \ssum_(i : fdist_of_FSDist.D d) scalept (x (fsval i)) (S1 (fsval i)) = \ssum_(i <- finsupp d) scalept (x i) (S1 i). Proof. by rewrite (ssum_seq_finsuppE'' idfun). Qed. -Lemma ssum_seq_finsuppE (d : {dist C}) : +Lemma ssum_seq_finsuppE (d : R.-dist C) : \ssum_i scalept (fdist_of_fs d i) (S1 (fsval i)) = \ssum_(i <- finsupp d) scalept (d i) (S1 i). Proof. @@ -840,7 +842,7 @@ under eq_bigr do rewrite fdist_of_fsE. by rewrite ssum_seq_finsuppE'. Qed. -Lemma ssum_widen_finsupp (x : {dist C}) X : +Lemma ssum_widen_finsupp (x : R.-dist C) X : (finsupp x `<=` X)%fset -> \ssum_(i <- finsupp x) scalept (x i) (S1 i) = \ssum_(i <- X) scalept (x i) (S1 i). @@ -862,8 +864,8 @@ Proof. move=> p x y. have [->|pn0] := eqVneq p 0%:pr; first by rewrite !conv0. have [->|pn1] := eqVneq p 1%:pr; first by rewrite !conv1. -have opn0 : (Prob.p p).~ != R0. by apply onem_neq0. -apply: S1_inj; rewrite affine_conv/= !S1_Convn_finType ssum_seq_finsuppE. +have opn0 : (Prob.p p).~ != 0. by apply onem_neq0. +apply: (@S1_inj R); rewrite affine_conv/= !S1_Convn_finType ssum_seq_finsuppE. under [LHS]eq_bigr do rewrite fsdist_scalept_conv. rewrite big_seq_fsetE big_scalept_conv_split /=. rewrite 2!ssum_seq_finsuppE' 2!ssum_seq_finsuppE. @@ -871,56 +873,60 @@ rewrite -(@ssum_widen_finsupp x); last exact/finsupp_conv_subr. by rewrite -(@ssum_widen_finsupp y)//; exact/finsupp_conv_subl. Qed. -HB.instance Definition _ := isAffine.Build _ _ _ Convn_of_fsdist_affine. +HB.instance Definition _ := isAffine.Build _ _ _ _ Convn_of_fsdist_affine. End Convn_of_FSDist. Section lemmas_for_probability_monad_and_adjunction. +Context {R : realType}. Local Open Scope fset_scope. Local Open Scope R_scope. -Lemma Convn_of_fsdistjoin (A : choiceType) (D : {dist {dist A}}) : +Lemma Convn_of_fsdistjoin (A : choiceType) (D : R.-dist (R.-dist A)) : Convn_of_fsdist D = fsdistjoin D. Proof. apply: fsdist_ext => a; rewrite -[LHS]Scaled1RK. rewrite (S1_proj_Convn_finType [the {affine _ -> _} of fsdist_eval a]). -rewrite big_scaleR fsdistjoinE big_seq_fsetE; apply eq_bigr => -[d dD] _. -by rewrite (scaleR_scalept _ (fdist_Rge0 _ _)) fdist_of_fsE Scaled1RK. +(* TODO: instantiate scaled as an Lmodule, and use big_scaler *) +rewrite big_scaleR fsdistjoinE big_seq_fsetE; apply eq_bigr => -[d dD] _ /=. +rewrite scaleR_scalept; last by rewrite FDist.ge0. +by rewrite fdist_of_fsE /= mul1r. Qed. -Lemma Convn_of_fsdist1 (C : convType) (x : C) : Convn_of_fsdist (fsdist1 x) = x. +Lemma Convn_of_fsdist1 (C : convType R) (x : C) : Convn_of_fsdist (fsdist1 x) = x. Proof. -apply: (@S1_inj _ _ x). +apply: (@S1_inj R _ _ x). rewrite S1_Convn_finType /=. rewrite (eq_bigr (fun=> S1 x)); last first. - move=> i _; rewrite fdist_of_fsE fsdist1E /= -(supp_fsdist1 x). + move=> i _; rewrite fdist_of_fsE fsdist1E -(@supp_fsdist1 R). rewrite fsvalP scale1pt /=; congr (S1 _). by case: i => i /=; rewrite supp_fsdist1 inE => /eqP. by rewrite big_const (_ : #| _ | = 1%N) // -cardfE supp_fsdist1 cardfs1. Qed. -Lemma Convn_of_fsdistmap (C D : convType) (f : {affine C -> D}) - (d : {dist C}) : +Lemma Convn_of_fsdistmap (C D : convType R) (f : {affine C -> D}) + (d : R.-dist C) : f (Convn_of_fsdist d) = Convn_of_fsdist (fsdistmap f d). Proof. -apply S1_inj => /=. +apply (@S1_inj R) => /=. rewrite S1_proj_Convn_finType // S1_Convn_finType. set X := LHS. under eq_bigr do rewrite fdist_of_fsE. rewrite ssum_seq_finsuppE' supp_fsdistmap. under eq_bigr do rewrite fsdistbindE. rewrite big_seq; under eq_bigr=> y Hy. -- rewrite big_scaleptl'; [| by rewrite scale0pt | by move=> j; apply mulR_ge0]. +- rewrite big_scaleptl'; + [| by rewrite scale0pt | by move=> j; rewrite mulr_ge0]. under eq_bigr=> i do rewrite fsdist1E inE. over. rewrite -big_seq exchange_big /=. rewrite (@big_seq _ _ _ _ (finsupp d)). under eq_bigr=> x Hx. - rewrite (big_fsetD1 (f x)) /=; last by apply/imfsetP; exists x. - rewrite eqxx mulR1. + rewrite eqxx mulr1. rewrite (@big_seq _ _ _ _ ([fset f x0 | x0 in finsupp d] `\ f x)). under eq_bigr=> y do [rewrite in_fsetD1=> /andP [] /negbTE -> Hy; - rewrite mulR0 scale0pt]. + rewrite mulr0 scale0pt]. rewrite big1 // addpt0. over. rewrite /X. @@ -931,25 +937,27 @@ Qed. Section triangular_laws_left_convn. Variable C : choiceType. -Lemma triangular_laws_left0 (d : {dist C}) : - Convn_of_fsdist (fsdistmap (@fsdist1 C) d) = d. +Local Notation S1 := (@S1 R). + +Lemma triangular_laws_left0 (d : R.-dist C) : + Convn_of_fsdist (fsdistmap (@fsdist1 _ C) d) = d. Proof. -apply: fsdist_ext => x; apply S1_inj. +apply: fsdist_ext => x; apply (@S1_inj R). rewrite (S1_proj_Convn_finType [the {affine _ -> _} of fsdist_eval x]). under eq_bigr do rewrite fdist_of_fsE. -rewrite (ssum_seq_finsuppE'' (fun i : {dist C} => i x)). +rewrite (ssum_seq_finsuppE'' (fun i : R.-dist C => i x : R^o)). rewrite supp_fsdistmap. -rewrite big_imfset /=; last by move=> *; apply: fsdist1_inj. +rewrite big_imfset /=; last by move=> ? ? ? ?; exact/fsdist1_inj. under eq_bigr do rewrite fsdist1E inE fsdist1map. have nx0 : \ssum_(i <- finsupp d `\ x) - scalept (d i) (S1 (if x == i then 1 else 0)) = scalept (d x).~ (S1 0). - transitivity (scalept (\sum_(i <- finsupp d `\ x) (d i)) (S1 0)). + scalept (d i) (S1 (if x == i then 1 else 0 : R^o)) = scalept (d x).~ (S1 (0:R^o)). + transitivity (scalept (\sum_(i <- finsupp d `\ x) (d i)) (S1 (0:R^o))). rewrite big_scaleptl' //; last by rewrite scale0pt. by apply: eq_fbigr => y /fsetD1P []; rewrite eq_sym=> /negbTE ->. by congr (_ _ _); rewrite fsdist_suppD1. case/boolP : (x \in finsupp d) => xfd. rewrite (big_fsetD1 x) //= nx0 eqxx -convptE -affine_conv/=. - by rewrite avgRE mulR0 addR0 mulR1. + by rewrite avgRE mulr0 addr0 mulr1. by rewrite -(mem_fsetD1 xfd) nx0 fsfun_dflt // onem0 scale1pt. Qed. @@ -957,6 +965,8 @@ End triangular_laws_left_convn. End lemmas_for_probability_monad_and_adjunction. +Import ereal topology esum measure probability. + Section probability_measure. Section trivIset. diff --git a/probability/graphoid.v b/probability/graphoid.v index 9a41c2d9..514f4cd2 100644 --- a/probability/graphoid.v +++ b/probability/graphoid.v @@ -1,9 +1,8 @@ -(* infotheo: information theory and error-correcting codes in Coq *) -(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) +(* infotheo: information theory and error-correcting codes in Coq *) +(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext fdist. +From mathcomp Require Import reals. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext fdist. Require Import proba jfdist_cond. (******************************************************************************) @@ -18,15 +17,18 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. +Local Open Scope ring_scope. Local Open Scope proba_scope. Local Open Scope fdist_scope. +Import GRing.Theory. + (* TODO: rename *) Module Proj124. Section proj124. -Variables (A B D C : finType) (P : {fdist A * B * D * C}). -Definition d : {fdist A * B * C} := fdistX (fdistA (fdistX (fdistA P)))`2. +Context {R : realType}. +Variables (A B D C : finType) (P : R.-fdist (A * B * D * C)). +Definition d : R.-fdist (A * B * C) := fdistX (fdistA (fdistX (fdistA P)))`2. Lemma dE abc : d abc = \sum_(x in D) P (abc.1.1, abc.1.2, x, abc.2). Proof. case: abc => [[a b] c] /=. @@ -38,18 +40,20 @@ Proof. by rewrite /fdist_snd /d !fdistmap_comp. Qed. End proj124. End Proj124. -Definition Proj14d (A B C D : finType) (d : {fdist A * B * D * C}) : {fdist A * C} := +Definition Proj14d {R : realType} (A B C D : finType) (d : R.-fdist (A * B * D * C)) : + R.-fdist (A * C) := fdist_proj13 (Proj124.d d). (* TODO: rename *) Module QuadA23. Section def. -Variables (A B C D : finType) (P : {fdist A * B * D * C}). +Context {R : realType}. +Variables (A B C D : finType) (P : R.-fdist (A * B * D * C)). Definition f (x : A * B * D * C) : A * (B * D) * C := (x.1.1.1, (x.1.1.2, x.1.2), x.2). Lemma inj_f : injective f. Proof. by rewrite /f => -[[[? ?] ?] ?] [[[? ?] ?] ?] /= [-> -> -> ->]. Qed. -Definition d : {fdist A * (B * D) * C} := fdistmap f P. +Definition d : R.-fdist (A * (B * D) * C) := fdistmap f P. Lemma dE x : d x = P (x.1.1, x.1.2.1, x.1.2.2, x.2). Proof. case: x => -[a [b d] c]; rewrite /def.d fdistmapE /= -/(f (a, b, d, c)). @@ -57,14 +61,16 @@ by rewrite (big_pred1_inj inj_f). Qed. End def. Section prop. -Variables (A B C D : finType) (P : {fdist A * B * D * C}). +Context {R : realType}. +Variables (A B C D : finType) (P : R.-fdist (A * B * D * C)). Lemma snd : (QuadA23.d P)`2 = P`2. Proof. by rewrite /fdist_snd /d fdistmap_comp. Qed. End prop. End QuadA23. Section cinde_rv_prop. -Variables (U : finType) (P : {fdist U}) (A B C D : finType). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U) (A B C D : finType). Variables (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}) (W : {RV P -> D}). Lemma cinde_drv_2C : P |= X _|_ [% Y, W] | Z -> P |= X _|_ [% W, Y] | Z. @@ -83,7 +89,8 @@ End cinde_rv_prop. Section symmetry. -Variable (U : finType) (P : {fdist U}). +Context {R : realType}. +Variable (U : finType) (P : R.-fdist U). Variables (A B C : finType) (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}). Lemma symmetry : P |= X _|_ Y | Z -> P |= Y _|_ X | Z. @@ -92,14 +99,15 @@ move=> H b a c. rewrite /cinde_rv in H. rewrite cpr_eq_pairC. rewrite H. -by rewrite mulRC. +by rewrite mulrC. Qed. End symmetry. Section decomposition. -Variables (U : finType) (P : {fdist U}) (A B C D : finType). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U) (A B C D : finType). Variables (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}) (W : {RV P -> D}). Lemma decomposition : P |= X _|_ [% Y, W] | Z -> P |= X _|_ Y | Z. @@ -121,7 +129,8 @@ End decomposition. Section weak_union. -Variables (U : finType) (P : {fdist U}) (A B C D : finType). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U) (A B C D : finType). Variables (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}) (W : {RV P -> D}). Lemma weak_union : P |= X _|_ [% Y, W] | Z -> P |= X _|_ Y | [% Z, W]. @@ -133,10 +142,10 @@ transitivity (`Pr[ X = a | [% Y, Z, W] = (b, c, d)] * transitivity (`Pr[ X = a | Z = c] * `Pr[ Y = b | [% Z, W] = (c, d)]). rewrite cpr_eq_pairACr. case/boolP : (`Pr[ [% Y, W, Z] = (b, d, c)] == 0) => [/eqP|] H0. - - by rewrite [X in _ * X = _ * X]cpr_eqE pr_eq_pairA pr_eq_pairAC H0 div0R !mulR0. + - by rewrite [X in _ * X = _ * X]cpr_eqE pr_eq_pairA pr_eq_pairAC H0 mul0r !mulr0. - by rewrite (cinde_alt _ H). case/boolP : (`Pr[ [% Z, W] = (c, d) ] == 0) => [/eqP|] ?. -- by rewrite [X in _ * X = _ * X]cpr_eqE (pr_eq_pairC _ Y) (pr_eq_domin_RV2 Y) ?(div0R,mulR0). +- by rewrite [X in _ * X = _ * X]cpr_eqE (pr_eq_pairC _ Y) (pr_eq_domin_RV2 Y) ?(mul0r,mulr0). - have {}H : P |= X _|_ W | Z by move/cinde_drv_2C : H; apply decomposition. by rewrite [in X in _ = X * _]cpr_eq_pairCr (cinde_alt _ H) // pr_eq_pairC. Qed. @@ -145,7 +154,8 @@ End weak_union. Section contraction. -Variables (U : finType) (P : {fdist U}) (A B C D : finType). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U) (A B C D : finType). Variables (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}) (W : {RV P -> D}). Lemma contraction : P |= X _|_ W | [% Z, Y] -> P |= X _|_ Y | Z -> P |= X _|_ [% Y, W] | Z. @@ -156,11 +166,11 @@ transitivity (`Pr[X = a | [% Y, Z] = (b, c)] * `Pr[[% Y, W] = (b, d) | Z = c]). rewrite -cpr_eq_pairAr [in X in X * _ = _]cpr_eq_pairCr -cpr_eq_pairAr. case/boolP : (`Pr[ [% W, [% Z, Y]] = (d, (c, b))] == 0) => [/eqP|] H0. rewrite [in X in _ * X = _ * X]cpr_eqE. - by rewrite -pr_eq_pairA pr_eq_pairC -pr_eq_pairA H0 div0R !mulR0. + by rewrite -pr_eq_pairA pr_eq_pairC -pr_eq_pairA H0 mul0r !mulr0. by rewrite (cinde_alt _ H1) // cpr_eq_pairCr. case/boolP : (`Pr[ [% Y, Z] = (b, c) ] == 0) => [/eqP|] H0. - rewrite [X in _ * X = _ * X]cpr_eqE. - by rewrite pr_eq_pairAC pr_eq_domin_RV2 ?div0R ?mulR0. + by rewrite pr_eq_pairAC pr_eq_domin_RV2 ?mul0r ?mulr0. - by rewrite (cinde_alt _ H2). Qed. @@ -169,7 +179,8 @@ End contraction. (* Probabilistic Reasoning in Intelligent Systems: Networks of Plausible Inference, Pearl, p.88 *) Section derived_rules. -Variables (U : finType) (P : {fdist U}) (A B C D : finType). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U) (A B C D : finType). Variables (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}) (W : {RV P -> D}). Lemma chaining_rule : P |= X _|_ Z | Y /\ P |= [% X, Y] _|_ W | Z -> P |= X _|_ W | Y. @@ -191,7 +202,8 @@ End derived_rules. Section intersection. -Variables (U : finType) (P : {fdist U}) (A B C D : finType). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U) (A B C D : finType). Variables (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}) (W : {RV P -> D}). Hypothesis P0 : forall b c d, `Pr[ [% Y, Z, W] = (b, c, d) ] != 0. @@ -213,13 +225,14 @@ have <- : \sum_(d <- fin_img W) suff H : forall d, `Pr[ [% X, Y] = (a, b) | Z = c] / `Pr[ Y = b | Z = c ] = `Pr[ [% X, W] = (a, d) | Z = c] / `Pr[ W = d | Z = c ]. apply eq_bigr => d _. - rewrite -eqR_divr_mulr; last first. - rewrite cpr_eqE divR_neq0' //. + rewrite -eqr_divr_mulr; last first. + rewrite cpr_eqE mulf_neq0 //. - by move: (P0 b c d); apply: contra => /eqP/(pr_eq_domin_RV2 W d) ->. - - move: (P0 b c d); apply: contra => /eqP/(pr_eq_domin_RV2 [% Y, W] (b, d)). + - move: (P0 b c d); apply: contra. + rewrite invr_eq0; move/eqP/(pr_eq_domin_RV2 [% Y, W] (b, d)). by rewrite pr_eq_pairCA pr_eq_pairA => ->. - rewrite {1}/Rdiv mulRAC -/(Rdiv _ _) (H d) mulRAC eqR_divr_mulr //. - rewrite cpr_eqE divR_neq0' //. + rewrite mulrAC (H d) -mulrA mulVf ?mulr1 //. + rewrite cpr_eqE mulf_eq0 negb_or invr_eq0 pr_eq_pairC; apply/andP; split. - move: (P0 b c d); apply: contra => /eqP/(pr_eq_domin_RV2 Y b). by rewrite pr_eq_pairC pr_eq_pairA pr_eq_pairAC => ->. - move: (P0 b c d); apply: contra => /eqP/(pr_eq_domin_RV2 [% Y, W] (b, d)). @@ -229,12 +242,12 @@ have <- : \sum_(d <- fin_img W) move=> d. rewrite cpr_eq_product_rule (H d). rewrite [in RHS]cpr_eq_product_rule. - rewrite {1}/Rdiv -mulRA mulRV; last first. - rewrite cpr_eqE divR_neq0' //. + rewrite -mulrA mulfV; last first. + rewrite cpr_eqE mulf_eq0 negb_or invr_eq0; apply/andP; split. - by move: (P0 b c d); apply: contra => /eqP/(pr_eq_domin_RV2 W d) ->. - move: (P0 b c d); apply: contra => /eqP/(pr_eq_domin_RV2 [% Y, W] (b, d)). by rewrite pr_eq_pairCA -pr_eq_pairA => ->. - rewrite {1}/Rdiv -[in RHS]mulRA mulRV // cpr_eqE divR_neq0' //. + rewrite -[in RHS]mulrA mulfV // cpr_eqE mulf_eq0 negb_or invr_eq0; apply/andP; split. - move: (P0 b c d); apply: contra => /eqP/(pr_eq_domin_RV2 Y b). by rewrite pr_eq_pairC pr_eq_pairA pr_eq_pairAC => ->. - move: (P0 b c d); apply: contra => /eqP/(pr_eq_domin_RV2 [% Y, W] (b, d)). @@ -243,25 +256,26 @@ have <- : \sum_(d <- fin_img W) `Pr[ X = a | [% W, Z, Y] = (d, c, b)]. move=> d; move: {H2}(H2 a d (c, b)). rewrite cpr_eq_product_rule. - have /eqP H0 : `Pr[ W = d | [% Z, Y] = (c, b)] != 0. + have H0 : `Pr[ W = d | [% Z, Y] = (c, b)] != 0. rewrite cpr_eqE pr_eq_pairA pr_eq_pairAC -pr_eq_pairA. - rewrite pr_eq_pairC divR_neq0' //; first by rewrite pr_eq_pairC. + rewrite pr_eq_pairC mulf_eq0 negb_or invr_eq0. + apply/andP; split; first by rewrite pr_eq_pairC. by move: (P0 b c d); apply: contra => /eqP/(pr_eq_domin_RV2 W d) ->. - move/eqR_mul2r => /(_ H0){H0}/esym. - by rewrite [in LHS]cpr_eq_pairCr cpr_eq_pairAr. + move/mulIf => /(_ H0){H0}/esym. + by rewrite (cpr_eq_pairCr X Z) cpr_eq_pairAr. have {}H1 : forall d, `Pr[ X = a | [% W, Z] = (d, c)] = `Pr[ X = a | [% Y, W, Z] = (b, d, c)]. move=> d; move: {H1}(H1 a b (c, d)). rewrite cpr_eq_product_rule. - have /eqP H0 : `Pr[ Y = b | [% Z, W] = (c, d)] != 0. - rewrite cpr_eqE pr_eq_pairA divR_neq0' //. + have H0 : `Pr[ Y = b | [% Z, W] = (c, d)] != 0. + rewrite cpr_eqE pr_eq_pairA mulf_eq0 negb_or invr_eq0 P0 /=. move: (P0 b c d); apply: contra => /eqP/(pr_eq_domin_RV2 Y b). by rewrite pr_eq_pairC -pr_eq_pairA => ->. - move/eqR_mul2r => /(_ H0){H0}/esym. - by rewrite [in LHS]cpr_eq_pairCr cpr_eq_pairAr cpr_eq_pairACr. + move/mulIf => /(_ H0){H0}/esym. + by rewrite (cpr_eq_pairCr X Z) cpr_eq_pairAr cpr_eq_pairACr. by move=> d; rewrite {H2}(H2 d) {}H1 cpr_eq_pairCr cpr_eq_pairAr. rewrite -big_distrr /=. -rewrite cPr_1 ?mulR1 //. +rewrite cPr_1 ?mulr1 //. move: (P0 b c D_not_empty); apply: contra. rewrite pr_eq_pairAC => /eqP/(pr_eq_domin_RV2 [% Y, W] (b, D_not_empty)). by rewrite pr_eq_pairC => ->. diff --git a/probability/jensen.v b/probability/jensen.v index abfb7a52..611fe70b 100644 --- a/probability/jensen.v +++ b/probability/jensen.v @@ -1,9 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. -From mathcomp Require Import boolp Rstruct. -Require Import Reals. -Require Import ssrR Reals_ext ssr_ext realType_ext ssralg_ext logb. +From mathcomp Require Import mathcomp_extra boolp reals. +Require Import ssr_ext ssralg_ext realType_ext. Require Import fdist proba convex. (******************************************************************************) @@ -14,23 +13,24 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. -Local Open Scope reals_ext_scope. +Local Open Scope ring_scope. Local Open Scope convex_scope. Local Open Scope fdist_scope. -Import GRing.Theory. +Import Order.Theory GRing.Theory Num.Theory. Section jensen_inequality. -Variable f : R -> R. -Variable D : {convex_set R}. +Context {R : realType}. + +Variable f : R^o -> R^o. +Variable D : {convex_set R^o}. Hypothesis convex_f : convex_function_in D f. Variables A : finType. -Local Hint Resolve Rle_refl : core. +(*Local Hint Resolve Rle_refl : core.*) -Lemma jensen_dist (r : A -> R) (X : {fdist A}) : +Lemma jensen_dist (r : A -> R) (X : R.-fdist A) : (forall a, r a \in D) -> f (\sum_(a in A) X a * r a) <= \sum_(a in A) X a * f (r a). Proof. @@ -43,21 +43,21 @@ apply: (@fdist_ind _ A (fun X => move=> n IH {}X b cardA Hb. case/boolP : (X b == 1) => [/eqP|]Xb1. move/eqP : (Xb1); rewrite fdist1E1 => /eqP ->. - by rewrite supp_fdist1 !big_set1 fdist1xx !mul1R. + by rewrite supp_fdist1 !big_set1 fdist1xx !mul1r. have HXb1: (X b).~ != 0 by rewrite onem_neq0. set d := fdistD1 Xb1. have HsumD1 q: \sum_(a in fdist_supp d) d a * q a = - /(X b).~ * \sum_(a in fdist_supp d) X a * q a. - rewrite (eq_bigr (fun a => /(X b).~ * (X a * q a))); last first. + ((X b).~)^-1 * \sum_(a in fdist_supp d) X a * q a. + rewrite (eq_bigr (fun a => ((X b).~)^-1 * (X a * q a))); last first. move=> i; rewrite inE fdistD1E. case: ifP => Hi; first by rewrite eqxx. - by rewrite mulRCA mulRA -divRE RdivE. + by rewrite mulrCA mulrA onemE. by rewrite -big_distrr. have {HsumD1}HsumXD1 q: \sum_(a in fdist_supp X) X a * q a = X b * q b + (X b).~ * (\sum_(a in fdist_supp d) d a * q a). - rewrite HsumD1 mulRA mulRV // mul1R (bigD1 b) ?inE //=. + rewrite HsumD1 mulrA mulfV // mul1r (bigD1 b) ?inE //=. rewrite (eq_bigl (fun a : A => a \in fdist_supp d)) //= => i. rewrite !inE /=. case HXi: (X i == 0) => //=. @@ -70,27 +70,29 @@ split; last first. move/asboolP: (convex_setP D). move/(_ (r b) (\sum_(a in fdist_supp d) d a * r a) (probfdist X b)). by rewrite classical_sets.in_setE; apply; rewrite -classical_sets.in_setE. -move/leR_trans: (convex_f (probfdist X b) (HDr b) HDd); apply => /=. -by rewrite leR_add2l; apply leR_wpmul2l => //; apply/onem_ge0. +have:= (convex_f (probfdist X b) (HDr b) HDd). +move/le_trans; apply. +by rewrite lerD2l; apply ler_wpM2l => //; rewrite onem_ge0. Qed. Local Open Scope proba_scope. -Lemma Jensen (P : {fdist A}) (X : {RV P -> R}) : (forall x, X x \in D) -> +Lemma Jensen (P : R.-fdist A) (X : {RV P -> R}) : (forall x, X x \in D) -> f (`E X) <= `E (f `o X). Proof. move=> H. -rewrite {2}/Ex; erewrite eq_bigr; last by move=> a _; rewrite mulRC. -rewrite {1}/Ex; erewrite eq_bigr; last by move=> a _; rewrite mulRC. +rewrite {2}/Ex; erewrite eq_bigr; last by move=> a _; rewrite mulrC. +rewrite {1}/Ex; erewrite eq_bigr; last by move=> a _; rewrite mulrC. exact: jensen_dist H. Qed. End jensen_inequality. Section jensen_concave. +Context {R : realType}. -Variable f : R -> R. -Variable D : {convex_set R}. +Variable f : R^o -> R^o. +Variable D : {convex_set R^o}. Hypothesis concave_f : concave_function_in D f. Variable A : finType. @@ -102,14 +104,16 @@ rewrite /convex_function_in => x y t Dx Dy. apply /R_convex_function_atN/concave_f => //; by case: t. Qed. -Lemma jensen_dist_concave (r : A -> R) (X : {fdist A}) : +Lemma jensen_dist_concave (r : A -> R) (X : R.-fdist A) : (forall x, r x \in D) -> \sum_(a in A) X a * f (r a) <= f (\sum_(a in A) X a * r a). Proof. move=> HDr. -rewrite -[X in _ <= X]oppRK leR_oppr. -apply/(leR_trans (jensen_dist convex_g X HDr))/Req_le. -by rewrite big_morph_oppR; apply eq_bigr => a _; rewrite mulRN. +rewrite -[X in _ <= X]opprK lerNr. +apply/(le_trans (jensen_dist convex_g X HDr)). +rewrite le_eqVlt -sumrN. +under [eqbLHS]eq_bigr do rewrite /g mulrN. +by rewrite eqxx. Qed. End jensen_concave. diff --git a/probability/jfdist_cond.v b/probability/jfdist_cond.v index da994af2..83d79b55 100644 --- a/probability/jfdist_cond.v +++ b/probability/jfdist_cond.v @@ -2,9 +2,8 @@ (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. From mathcomp Require boolp. -From mathcomp Require Import Rstruct. -Require Import Reals. -Require Import ssrR realType_ext Reals_ext logb ssr_ext ssralg_ext bigop_ext. +From mathcomp Require Import reals. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln. Require Import fdist proba. (******************************************************************************) @@ -34,12 +33,15 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. +Local Open Scope ring_scope. Local Open Scope proba_scope. Local Open Scope fdist_scope. +Import GRing.Theory. + Section conditional_probability. -Variables (A B : finType) (P : {fdist A * B}). +Context {R : realType}. +Variables (A B : finType) (P : R.-fdist (A * B)). Implicit Types (E : {set A}) (F : {set B}). Definition jcPr E F := Pr P (E `* F) / Pr (P`2) F. @@ -98,7 +100,7 @@ Hypothesis cov : cover (F @: I) = [set: B]. Lemma jtotal_prob_cond : Pr P`1 E = \sum_(i in I) \Pr_[E | F i] * Pr P`2 (F i). Proof. rewrite -Pr_XsetT -EsetT. -rewrite (@total_prob_cond _ _ _ _ (fun i => T`* F i)); last 2 first. +rewrite (@total_prob_cond _ _ _ _ _ (fun i => T`* F i)); last 2 first. - move=> i j ij; rewrite -setI_eq0 !setTE setIX setTI. by move: (dis ij); rewrite -setI_eq0 => /eqP ->; rewrite setX0. - (* TODO: lemma? *) apply/setP => -[a b]; rewrite inE /cover. @@ -125,7 +127,8 @@ Notation jcPr_cplt := jcPr_setC (only parsing). Notation jcPr_union_eq := jcPr_setU (only parsing). Section jPr_Pr. -Variables (U : finType) (P : {fdist U}) (A B : finType). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U) (A B : finType). Variables (X : {RV P -> A}) (Y : {RV P -> B}) (E : {set A}) (F : {set B}). Lemma jPr_Pr : \Pr_(`p_[% X, Y]) [E | F] = `Pr[X \in E |Y \in F]. @@ -139,13 +142,14 @@ Qed. End jPr_Pr. Section bayes. -Variables (A B : finType) (PQ : {fdist A * B}). +Context {R : realType}. +Variables (A B : finType) (PQ : R.-fdist (A * B)). Let P := PQ`1. Let Q := PQ`2. Let QP := fdistX PQ. Implicit Types (E : {set A}) (F : {set B}). Lemma jBayes E F : \Pr_PQ[E | F] = \Pr_QP [F | E] * Pr P E / Pr Q F. Proof. -rewrite 2!jcPrE Bayes /Rdiv -2!mulRA. +rewrite 2!jcPrE Bayes -2!mulrA. rewrite EsetT Pr_XsetT setTE Pr_setTX /cPr; congr ((_ / _) * (_ / _)). by rewrite EsetT setTE [in RHS]setIX Pr_fdistX setIX. by rewrite setTE Pr_fdistX. @@ -159,7 +163,7 @@ Lemma jBayes_extended (I : finType) (E : I -> {set A}) (F : {set B}) : \sum_(j in I) \Pr_ QP [F | E j] * Pr P (E j). Proof. move=> dis cov i; rewrite jBayes; congr (_ / _). -move: (@jtotal_prob_cond _ _ QP I F E dis cov). +move: (@jtotal_prob_cond _ _ _ QP I F E dis cov). rewrite {1}/QP fdistX1 => ->. by apply eq_bigr => j _; rewrite -/QP {2}/QP fdistX2. Qed. @@ -167,7 +171,8 @@ Qed. End bayes. Section conditional_probability_prop3. -Variables (A B C : finType) (P : {fdist A * B * C}). +Context {R : realType}. +Variables (A B C : finType) (P : R.-fdist (A * B * C)). Lemma jcPr_TripC12 (E : {set A}) (F : {set B }) (G : {set C}) : \Pr_(fdistC12 P)[F `* E | G] = \Pr_P[E `* F | G]. @@ -195,23 +200,25 @@ End conditional_probability_prop3. Section product_rule. Section main. -Variables (A B C : finType) (P : {fdist A * B * C}). +Context {R : realType}. +Variables (A B C : finType) (P : R.-fdist (A * B * C)). Implicit Types (E : {set A}) (F : {set B}) (G : {set C}). Lemma jproduct_rule_cond E F G : \Pr_P [E `* F | G] = \Pr_(fdistA P) [E | F `* G] * \Pr_(fdist_proj23 P) [F | G]. Proof. -rewrite /jcPr; rewrite !mulRA; congr (_ * _); last by rewrite fdist_proj23_snd. -rewrite -mulRA -/(fdist_proj23 _) -Pr_fdistA. -case/boolP : (Pr (fdist_proj23 P) (F `* G) == 0) => H; last by rewrite mulVR ?mulR1. -suff -> : Pr (fdistA P) (E `* (F `* G)) = 0 by rewrite mul0R. +rewrite /jcPr; rewrite !mulrA; congr (_ * _); last by rewrite fdist_proj23_snd. +rewrite -mulrA -/(fdist_proj23 _) -Pr_fdistA. +case/boolP : (Pr (fdist_proj23 P) (F `* G) == 0) => H; last by rewrite mulVf ?mulr1. +suff -> : Pr (fdistA P) (E `* (F `* G)) = 0 by rewrite mul0r. by rewrite Pr_fdistA; exact/Pr_fdist_proj23_domin/eqP. Qed. End main. Section variant. -Variables (A B C : finType) (P : {fdist A * B * C}). +Context {R : realType}. +Variables (A B C : finType) (P : R.-fdist (A * B * C)). Implicit Types (E : {set A}) (F : {set B}) (G : {set C}). Lemma product_ruleC E F G : @@ -221,7 +228,8 @@ Proof. by rewrite -jcPr_TripC12 jproduct_rule_cond. Qed. End variant. Section prod. -Variables (A B : finType) (P : {fdist A * B}). +Context {R : realType}. +Variables (A B : finType) (P : R.-fdist (A * B)). Implicit Types (E : {set A}) (F : {set B}). Lemma jproduct_rule E F : Pr P (E `* F) = \Pr_P[E | F] * Pr (P`2) F. @@ -229,39 +237,39 @@ Proof. have [/eqP PF0|PF0] := boolP (Pr (P`2) F == 0). rewrite jcPrE /cPr -{1}(setIT E) -{1}(setIT F) -setIX. rewrite [LHS]Pr_domin_setI; last by rewrite -Pr_fdistX Pr_domin_setX // fdistX1. - by rewrite setIC Pr_domin_setI ?(div0R,mul0R) // setTE Pr_setTX. + by rewrite setIC Pr_domin_setI ?mul0r // setTE Pr_setTX. rewrite -{1}(setIT E) -{1}(setIT F) -setIX product_rule. -rewrite -EsetT setTT cPrET Pr_setT mulR1 jcPrE. +rewrite -EsetT setTT cPrET Pr_setT mulr1 jcPrE. rewrite /cPr {1}setTE {1}EsetT. -by rewrite setIX setTI setIT setTE Pr_setTX -mulRA mulVR ?mulR1. +by rewrite setIX setTI setIT setTE Pr_setTX -mulrA mulVf ?mulr1. Qed. End prod. End product_rule. -Lemma jcPr_fdistmap_r (A B B' : finType) (f : B -> B') (d : {fdist A * B}) +Lemma jcPr_fdistmap_r {R : realType} (A B B' : finType) (f : B -> B') (d : R.-fdist (A * B)) (E : {set A}) (F : {set B}): injective f -> \Pr_d [E | F] = \Pr_(fdistmap (fun x => (x.1, f x.2)) d) [E | f @: F]. Proof. move=> injf; rewrite /jcPr; congr (_ / _). -- rewrite (@Pr_fdistmap _ _ (fun x => (x.1, f x.2))) /=; last first. +- rewrite (@Pr_fdistmap _ _ _ (fun x => (x.1, f x.2))) /=; last first. by move=> [? ?] [? ?] /= [-> /injf ->]. congr (Pr _ _); apply/setP => -[a b]; rewrite !inE /=. apply/imsetP/andP. - case=> -[a' b']; rewrite inE /= => /andP[a'E b'F] [->{a} ->{b}]; split => //. apply/imsetP; by exists b'. - case=> aE /imsetP[b' b'F] ->{b}; by exists (a, b') => //; rewrite inE /= aE. -by rewrite /fdist_snd fdistmap_comp (@Pr_fdistmap _ _ f) // fdistmap_comp. +by rewrite /fdist_snd fdistmap_comp (@Pr_fdistmap _ _ _ f) // fdistmap_comp. Qed. -Arguments jcPr_fdistmap_r [A] [B] [B'] [f] [d] [E] [F] _. +Arguments jcPr_fdistmap_r {R} [A] [B] [B'] [f] [d] [E] [F] _. -Lemma jcPr_fdistmap_l (A A' B : finType) (f : A -> A') (d : {fdist A * B}) +Lemma jcPr_fdistmap_l {R : realType} (A A' B : finType) (f : A -> A') (d : R.-fdist (A * B)) (E : {set A}) (F : {set B}): injective f -> \Pr_d [E | F] = \Pr_(fdistmap (fun x => (f x.1, x.2)) d) [f @: E | F]. Proof. move=> injf; rewrite /jcPr; congr (_ / _). -- rewrite (@Pr_fdistmap _ _ (fun x => (f x.1, x.2))) /=; last first. +- rewrite (@Pr_fdistmap _ _ _ (fun x => (f x.1, x.2))) /=; last first. by move=> [? ?] [? ?] /= [/injf -> ->]. congr (Pr _ _); apply/setP => -[a b]; rewrite !inE /=. apply/imsetP/andP. @@ -270,48 +278,50 @@ move=> injf; rewrite /jcPr; congr (_ / _). - by case=> /imsetP[a' a'E] ->{a} bF; exists (a', b) => //; rewrite inE /= a'E. by rewrite /fdist_snd !fdistmap_comp. Qed. -Arguments jcPr_fdistmap_l [A] [A'] [B] [f] [d] [E] [F] _. +Arguments jcPr_fdistmap_l {R} [A] [A'] [B] [f] [d] [E] [F] _. -Lemma Pr_jcPr_unit (A : finType) (E : {set A}) (P : {fdist A}) : +Lemma Pr_jcPr_unit {R : realType} (A : finType) (E : {set A}) (P : R.-fdist A) : Pr P E = \Pr_(fdistmap (fun a => (a, tt)) P) [E | setT]. Proof. rewrite /jcPr/= (_ : [set: unit] = [set tt]); last first. by apply/setP => -[]; rewrite !inE eqxx. rewrite (Pr_set1 _ tt). -rewrite (_ : _`2 = fdist1 tt) ?fdist1xx ?divR1; last first. +rewrite (_ : _`2 = fdist1 tt) ?fdist1xx ?divr1; last first. rewrite /fdist_snd fdistmap_comp; apply/fdist_ext; case. by rewrite fdistmapE fdist1xx (eq_bigl xpredT) // FDist.f1. -rewrite /Pr big_setX /=; apply eq_bigr => a _; rewrite (big_set1 _ tt) /=. +rewrite /Pr big_setX /=; apply: eq_bigr => a _; rewrite (big_set1 _ tt) /=. rewrite fdistmapE (big_pred1 a) // => a0; rewrite inE /=. by apply/eqP/eqP => [[] -> | ->]. Qed. Section jfdist_cond0. -Variables (A B : finType) (PQ : {fdist (A * B)}) (a : A). +Context {R : realType}. +Variables (A B : finType) (PQ : R.-fdist (A * B)) (a : A). Hypothesis Ha : PQ`1 a != 0. Let f := [ffun b => \Pr_(fdistX PQ) [[set b] | [set a]]]. Let f0 b : 0 <= f b. Proof. rewrite ffunE; exact: jcPr_ge0. Qed. -Let f0' b : (0 <= f b)%O. Proof. by apply/RleP. Qed. +Let f0' b : (0 <= f b)%O. Proof. by []. Qed. Let f1 : \sum_(b in B) f b = 1. Proof. under eq_bigr do rewrite ffunE. -by rewrite /jcPr -big_distrl /= PrX_snd mulRV // Pr_set1 fdistX2. +by rewrite /jcPr -big_distrl /= PrX_snd mulfV // Pr_set1 fdistX2. Qed. -Definition jfdist_cond0 : {fdist B} := locked (@FDist.make _ _ _ f0' f1). +Definition jfdist_cond0 : R.-fdist B := locked (@FDist.make _ _ _ f0' f1). Lemma jfdist_cond0E b : jfdist_cond0 b = \Pr_(fdistX PQ) [[set b] | [set a]]. Proof. by rewrite /jfdist_cond0; unlock; rewrite ffunE. Qed. End jfdist_cond0. -Arguments jfdist_cond0 {A} {B} _ _ _. +Arguments jfdist_cond0 {R} {A} {B} _ _ _. Section jfdist_cond. -Variables (A B : finType) (PQ : {fdist A * B}) (a : A). +Context {R : realType}. +Variables (A B : finType) (PQ : R.-fdist (A * B)) (a : A). Let Ha := PQ`1 a != 0. Let sizeB : #|B| = #|B|.-1.+1. @@ -339,7 +349,7 @@ Qed. End jfdist_cond. Notation "P `(| a ')'" := (jfdist_cond P a). -Lemma cPr_1 (U : finType) (P : {fdist U}) (A B : finType) +Lemma cPr_1 {R : realType} (U : finType) (P : R.-fdist U) (A B : finType) (X : {RV P -> A}) (Y : {RV P -> B}) a : `Pr[X = a] != 0 -> \sum_(b <- fin_img Y) `Pr[ Y = b | X = a ] = 1. Proof. @@ -350,46 +360,47 @@ rewrite [X in _ = _ + X](eq_bigr (fun=> 0)); last first. move=> b bY. rewrite /Q jfdist_condE // /jcPr /Pr !(big_setX,big_set1) /= fdistXE fdistX2 fst_RV2. rewrite -!pr_eqE' !pr_eqE. - rewrite /Pr big1 ?div0R // => u. + rewrite /Pr big1 ?mul0r // => u. rewrite inE => /eqP[Yub ?]. exfalso. move/negP : bY; apply. by rewrite mem_undup; apply/mapP; exists u => //; rewrite mem_enum. -rewrite big_const iter_addR mulR0 addR0. +rewrite big_const iter_addr mul0rn !addr0. rewrite big_uniq; last by rewrite /fin_img undup_uniq. apply eq_bigr => b; rewrite mem_undup => /mapP[u _ bWu]. rewrite /Q jfdist_condE // fdistX_RV2. by rewrite jcPrE -cpr_inE' cpr_eq_set1. Qed. -Lemma jcPr_1 (A B : finType) (P : {fdist A * B}) a : P`1 a != 0 -> +Lemma jcPr_1 {R : realType} (A B : finType) (P : R.-fdist (A * B)) a : P`1 a != 0 -> \sum_(b in B) \Pr_(fdistX P)[ [set b] | [set a] ] = 1. Proof. move=> Xa0; rewrite -[RHS](FDist.f1 (P `(| a ))); apply eq_bigr => b _. by rewrite jfdist_condE. Qed. -Lemma jfdist_cond_prod (A B : finType) (P : {fdist A}) (W : A -> {fdist B}) (a : A) : +Lemma jfdist_cond_prod {R : realType} (A B : finType) (P : R.-fdist A) (W : A -> R.-fdist B) (a : A) : (P `X W)`1 a != 0 -> W a = (P `X W) `(| a ). Proof. move=> a0; apply/fdist_ext => b. rewrite jfdist_condE // /jcPr setX1 !Pr_set1 fdistXE fdistX2 fdist_prod1. -rewrite fdist_prodE /= /Rdiv mulRAC mulRV ?mul1R //. +rewrite fdist_prodE /= mulrAC mulfV ?mul1r //. by move: a0; rewrite fdist_prod1. Qed. -Lemma jcPr_fdistX_prod (A B : finType) (P : {fdist A}) (W : A -> {fdist B}) a b : +Lemma jcPr_fdistX_prod {R : realType} (A B : finType) (P : R.-fdist A) (W : A -> R.-fdist B) a b : P a <> 0 -> \Pr_(fdistX (P `X W))[ [set b] | [set a] ] = W a b. Proof. move=> Pxa. rewrite /jcPr setX1 fdistX2 2!Pr_set1 fdistXE fdist_prod1. -by rewrite fdist_prodE /= /Rdiv mulRAC mulRV ?mul1R //; exact/eqP. +by rewrite fdist_prodE /= mulrAC mulfV ?mul1r //; exact/eqP. Qed. Section fdist_split. +Context {R : realType}. Variables (A B : finType). -Definition fdist_split (PQ : {fdist A * B}) := (PQ`1, fun x => PQ `(| x )). +Definition fdist_split (PQ : R.-fdist (A * B)) := (PQ`1, fun x => PQ `(| x )). Lemma fdist_prodK : cancel fdist_split (uncurry (@fdist_prod _ A B)). Proof. @@ -398,19 +409,19 @@ have [Ha|Ha] := eqVneq (PQ`1 ab.1) 0. rewrite Ha GRing.mul0r; apply/esym/(dominatesE (Prod_dominates_Joint PQ)). by rewrite fdist_prodE Ha GRing.mul0r. rewrite jfdist_condE // -fdistX2 GRing.mulrC. -rewrite -(Pr_set1 _ ab.1) -RmultE -jproduct_rule setX1 Pr_set1 fdistXE. +rewrite -(Pr_set1 _ ab.1) -jproduct_rule setX1 Pr_set1 fdistXE. by case ab. Qed. End fdist_split. - -Import GRing.Theory Num.Theory. +Import Num.Theory. Module FDistPart. Section fdistpart. +Context {R: realType}. Local Open Scope fdist_scope. -Variables (n m : nat) (K : 'I_m -> 'I_n) (e : {fdist 'I_m}) (i : 'I_n). +Variables (n m : nat) (K : 'I_m -> 'I_n) (e : R.-fdist 'I_m) (i : 'I_n). Definition d := (fdistX (e `X (fun j => fdist1 (K j)))) `(| i). Definition den := (fdistX (e `X (fun j => fdist1 (K j))))`1 i. @@ -426,8 +437,8 @@ rewrite eq_sym 2!inE. by case: eqP => // _; rewrite (mulr0,mulr1). Qed. -Lemma dE j : fdistmap K e i != 0%coqR -> - d j = (e j * (i == K j)%:R / \sum_(j | K j == i) e j)%coqR. +Lemma dE j : fdistmap K e i != 0 -> + d j = (e j * (i == K j)%:R / \sum_(j | K j == i) e j). Proof. rewrite -denE => NE. rewrite jfdist_condE // {NE} /jcPr /proba.Pr. @@ -435,35 +446,34 @@ rewrite (big_pred1 (j,i)); last first. by move=> k; rewrite !inE [in RHS](surjective_pairing k) xpair_eqE. rewrite (big_pred1 i); last by move=> k; rewrite !inE. rewrite !fdistE big_mkcond [in RHS]big_mkcond /=. -rewrite -RmultE -INRE. congr (_ / _)%R. under eq_bigr => k do rewrite {2}(surjective_pairing k). rewrite -(pair_bigA _ (fun k l => if l == i then e `X (fun j0 : 'I_m => fdist1 (K j0)) (k, l) - else R0))%R /=. + else 0))%R /=. apply eq_bigr => k _. rewrite -big_mkcond /= big_pred1_eq !fdistE /= eq_sym. by case: ifP; rewrite (mulr1,mulr0). Qed. End fdistpart. -Lemma dK n m K (e : {fdist 'I_m}) j : +Lemma dK {R : realType} n m K (e : R.-fdist 'I_m) j : e j = (\sum_(i < n) fdistmap K e i * d K e i j)%R. Proof. under eq_bigr => /= a _. have [Ka0|Ka0] := eqVneq (fdistmap K e a) 0%R. - rewrite Ka0 mul0R. + rewrite Ka0 mul0r. have <- : (e j * (a == K j)%:R = 0)%R. - have [/eqP Kj|] := eqVneq a (K j); last by rewrite mulR0. + have [/eqP Kj|] := eqVneq a (K j); last by rewrite mulr0. move: Ka0; rewrite fdistE /=. - by move/psumr_eq0P => -> //; rewrite ?(mul0R,inE) // eq_sym. + by move/psumr_eq0P => -> //; rewrite ?(mul0r,inE) // eq_sym. over. - rewrite FDistPart.dE // fdistE /= mulRCA mulRV ?mulR1; + rewrite FDistPart.dE // fdistE /= mulrCA mulfV ?mulr1; last by rewrite fdistE in Ka0. over. move=> /=. -rewrite (bigD1 (K j)) //= eqxx mulR1. -by rewrite big1 ?addR0 // => i /negbTE ->; rewrite mulR0. +rewrite (bigD1 (K j)) //= eqxx mulr1. +by rewrite big1 ?addr0 // => i /negbTE ->; rewrite mulr0. Qed. End FDistPart. diff --git a/probability/ln_facts.v b/probability/ln_facts.v deleted file mode 100644 index c5038fc9..00000000 --- a/probability/ln_facts.v +++ /dev/null @@ -1,610 +0,0 @@ -(* infotheo: information theory and error-correcting codes in Coq *) -(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From HB Require Import structures. -From mathcomp Require Import all_ssreflect ssralg ssrnum. -From mathcomp Require boolp. -From mathcomp Require Import Rstruct reals. -Require Import Reals Lra. -Require Import ssrR realType_ext Reals_ext Ranalysis_ext logb convex. - -(******************************************************************************) -(* Results about the Analysis of ln *) -(* *) -(* Section ln_id_sect. *) -(* about the function x |-> ln x - (x - 1) *) -(* Section xlnx_sect. *) -(* about the function x |-> x * ln x *) -(* Section diff_xlnx *) -(* about the function x |-> xlnx (1 - x) - xlnx x. *) -(* Section Rabs_xlnx *) -(* proof that | x - y | <= a implies | xlnx x - xlnx y | <= - xlnx a *) -(* Section log_concave *) -(* concavity of log *) -(******************************************************************************) - -Set Implicit Arguments. -Unset Strict Implicit. -Import Prenex Implicits. - -Local Open Scope R_scope. - -Import Order.Theory GRing.Theory Num.Theory. - -Section ln_id_sect. - -Definition ln_id x := ln x - (x - 1). - -Lemma pderivable_ln_id_xle1 : pderivable ln_id (fun x => 0 < x <= 1). -Proof. -rewrite /pderivable => x Hx. -rewrite /ln_id. -apply derivable_pt_plus. -- apply derivable_pt_ln, Hx. -- apply derivable_pt_opp, derivable_pt_minus; - [apply derivable_pt_id | apply derivable_pt_cst]. -Defined. - -Definition ln_id' x (H : 0 < x <= 1) := derive_pt ln_id x (pderivable_ln_id_xle1 H). - -Lemma derive_pt_ln_id_xle1 : forall x (Hx : 0 < x <= 1), (/ x) - 1 = ln_id' Hx. -Proof. -move=> y Hy. -rewrite /ln_id' /pderivable_ln_id_xle1 /ln_id. -rewrite derive_pt_plus derive_pt_opp derive_pt_ln derive_pt_minus derive_pt_id derive_pt_cst. -rewrite subR0. -reflexivity. -Defined. - -Lemma derive_pt_ln_id_xle1_ge0 x (Hx : 0 < x <= 1) : 0 < if x==1 then 1 else ln_id' Hx. -Proof. -case/boolP : (x == 1) => Hcase ; first lra. -rewrite -derive_pt_ln_id_xle1; apply/subR_gt0. -rewrite -invR1; apply ltR_inv => //; first by case: Hx. -case (Rle_lt_or_eq_dec x 1) ; [apply Hx | by [] | ]. -move/eqP in Hcase ; move => Habs. -rewrite Habs in Hcase ; by contradict Hcase. -Defined. - -Lemma ln_idlt0_xlt1 : forall x, 0 < x < 1 -> ln_id x < 0. -Proof. -rewrite {2}(_ : 0 = ln_id 1); last by rewrite /ln_id ln_1 2!subRR. -move=> x Hx. -have lt01 : 0 < 1 by lra. -apply (pderive_increasing lt01 derive_pt_ln_id_xle1_ge0). -- by split; [apply Hx | apply ltRW, Hx]. -- lra. -- by apply Hx. -Qed. - -Lemma ln_idlt0_xgt1 x : 0 < x -> 1 < x -> ln_id x < 0. -Proof. -move=> x0 x1. -rewrite /ln_id; apply/subR_lt0/exp_lt_inv. -rewrite (exp_ln _ x0) -{1}(addR0 x) -(subRR 1) addRCA. -have ? : x - 1 <> 0 by exact/eqP/gtR_eqF/subR_gt0. (* for Coq 8.14 *) -have ? : 0 < x - 1 by exact/subR_gt0. (* for Coq 8.13 *) -exact/exp_ineq1. -Qed. - -Lemma ln_idgt0 x : 0 < x -> ln_id x <= 0. -Proof. -case: (ltgtP x 1) => [| |] x1 x0. -- by apply/ltRW/ln_idlt0_xlt1; split=> //; apply/RltP. -- by apply/ltRW/ln_idlt0_xgt1 => //; exact/RltP. -- rewrite x1 /ln_id ln_1 2!subRR. - by apply/RleP; rewrite lexx. -Qed. - -Lemma ln_id_cmp x : 0 < x -> ln x <= x - 1. -Proof. by move=> Hx; apply Rminus_le; apply ln_idgt0; exact Hx. Qed. - -Lemma log_id_cmp x : 0 < x -> log x <= (x - 1) * log (exp 1). -Proof. -by move=> x0; rewrite logexp1E; apply leR_wpmul2r; - [exact/invR_ge0 | exact/ln_id_cmp]. -Qed. - -Lemma ln_id_eq x : 0 < x -> ln x = x - 1 -> x = 1. -Proof. -move=> Hx' Hx. -case (total_order_T x 1) => [ [] // Hx2 | Hx2]; contradict Hx. -- apply/eqP/ltR_eqF; rewrite -subR_lt0. - apply ln_idlt0_xlt1; split; [exact Hx' | exact Hx2]. -- by apply/eqP/ltR_eqF; rewrite -subR_lt0; exact: ln_idlt0_xgt1. -Qed. - -Lemma log_id_eq x : 0 < x -> log x = (x - 1) * log (exp 1) -> x = 1. -Proof. -move=> Hx'; rewrite logexp1E. -rewrite eqR_mul2r; last exact/nesym/eqP/ltR_eqF/invR_gt0. -apply ln_id_eq; by [apply Hx' | apply Hx]. -Qed. - -End ln_id_sect. - -Section xlnx_sect. - -Section xlnx. - -Definition xlnx := fun x => if (0 < x)%mcR then x * ln x else 0. - -Lemma xlnx_0 : xlnx 0 = 0. -Proof. rewrite /xlnx mul0R; by case : ifP. Qed. - -Lemma xlnx_1 : xlnx 1 = 0. -Proof. rewrite /xlnx ln_1 mulR0 ; by case : ifP. Qed. - -Lemma xlnx_neg x : 0 < x < 1 -> xlnx x < 0. -Proof. -case => lt0x ltx1. -rewrite /xlnx. -have -> : (0 < x)%mcR ; first exact/RltP. -rewrite -(oppRK 0) ltR_oppr oppR0 -mulRN. -apply mulR_gt0 => //. -rewrite ltR_oppr oppR0. -apply exp_lt_inv. -by rewrite exp_ln // exp_0. -Qed. - -Lemma continue_xlnx : continuity xlnx. -Proof. -rewrite /continuity => r. -rewrite /continuity_pt /continue_in /limit1_in /limit_in => eps eps_pos /=. -case (total_order_T 0 r) ; first case ; move=> Hcase. -- have : continuity_pt (fun x => x * ln x) r. - apply continuity_pt_mult. - by apply derivable_continuous_pt, derivable_id. - by apply derivable_continuous_pt, derivable_pt_ln. - rewrite /continuity_pt /continue_in /limit1_in /limit_in => /(_ eps eps_pos). - case => /= k [k_pos Hk]. - exists (Rmin k r); split; first exact/Rlt_gt/Rmin_pos. - - move=> x ; rewrite /D_x ; move => [[_ Hx1] Hx2]. - rewrite /xlnx. - have -> : (0 < x)%mcR. - apply/RltP. - rewrite -(addR0 x) -{1}(subRR r) addRA addRAC. - apply (@leR_ltR_trans ((x + - r) + `| x + - r |)). - rewrite addRC -leR_subl_addr sub0R -normRN; exact: Rle_abs. - rewrite /R_dist in Hx2. - by apply/ltR_add2l/(@ltR_leR_trans (Rmin k r)) => //; exact: geR_minr. - have -> : (0 < r)%mcR by apply/RltP. - apply Hk. - split => //. - exact/(ltR_leR_trans Hx2)/geR_minl. -- subst r. - exists (exp (- 2 * / eps)). - split ; first exact: exp_pos. - move=> x; rewrite /R_dist subR0; case=> Hx1 Hx2. - rewrite /xlnx ltxx. - case: ifPn => /RltP Hcase. - + rewrite (geR0_norm _ (ltRW Hcase)) in Hx2. - rewrite subR0 -{1}(exp_ln _ Hcase). - set X := ln x. - have X_neg : X < 0. - apply (@ltR_trans (-2 * / eps)). - by apply exp_lt_inv; subst X; rewrite exp_ln. - rewrite mulNR. - exact/oppR_lt0/divR_gt0. - apply: (@ltR_leR_trans (2 * / (- X))). - * rewrite ltR0_norm; last first. - rewrite -(mulR0 (exp X)) ltR_pmul2l => //; exact: exp_pos. - rewrite -mulRN. - apply (@ltR_pmul2r (/ - X)); first exact/invR_gt0/oppR_gt0. - rewrite -mulRA mulRV ?mulR1; last by rewrite oppR_eq0; apply/ltR_eqF. - rewrite -(invRK 2) -mulRA. - rewrite ( _ : forall r, r * r = r ^ 2); last by move=> ?; rewrite /pow mulR1. - rewrite expRV; last exact/eqP/not_eq_sym/eqP/ltR_eqF/oppR_gt0. - rewrite -invRM; last 2 first. - by rewrite invR_neq0' //; exact/gtR_eqF. - by rewrite expR_eq0 oppR_eq0; exact/ltR_eqF. - rewrite -(invRK (exp X)). - apply ltR_inv => //. - exact/invR_gt0/exp_pos. - by apply/mulR_gt0; [lra | apply expR_gt0; lra]. - rewrite -exp_Ropp mulRC (_ : 2 = INR 2`!) //. - exact/exp_strict_lb/oppR_gt0. - * apply (@leR_pmul2r (/ 2)); first exact/invR_gt0. - rewrite mulRC mulRA mulVR ?mul1R //; last exact/gtR_eqF. - rewrite -(invRK eps) -invRM //; last 2 first. - exact/gtR_eqF/invR_gt0. - exact/eqP. - apply leR_inv => //. - - by apply/mulR_gt0 => //; exact: invR_gt0. - - rewrite leR_oppr mulRC -mulNR. - by apply/exp_le_inv/ltRW; subst X; rewrite exp_ln. - + by rewrite subRR normR0. -- exists (- r); split; first exact/oppR_gt0. - move=> x [[_ Hx1] Hx2]. - rewrite /R_dist /xlnx. - have -> : (0 < x)%mcR = false. - apply/RltP/leRNgt. - rewrite -(addR0 x) -{1}(subRR r) addRA addRAC. - apply (@leR_trans ((x + - r) - `| x + - r |)). - apply/leR_add2l/ltRW; by rewrite ltR_oppr. - exact/Rle_minus/Rle_abs. - have -> : (0 < r)%mcR = false by apply/negbTE; rewrite -leNgt; apply/RleP/ltRW. - by rewrite subRR normR0. -Qed. - -(* TODO: not used *) -Lemma uniformly_continue_xlnx : uniform_continuity xlnx (fun x => 0 <= x <= 1). -Proof. -apply Heine ; first by apply compact_P3. -move=> x _ ; by apply continue_xlnx. -Qed. - -Let xlnx_total := fun y => y * ln y. - -Lemma derivable_xlnx_total x : 0 < x -> derivable_pt xlnx_total x. -Proof. -move=> x_pos. -apply derivable_pt_mult. - by apply derivable_id. -by apply derivable_pt_ln. -Defined. - -Lemma xlnx_total_xlnx x : 0 < x -> xlnx x = xlnx_total x. -Proof. by rewrite /xlnx /f => /RltP ->. Qed. - -Lemma derivable_pt_xlnx x (x_pos : 0 < x) : derivable_pt xlnx x. -Proof. apply (@derivable_f_eq_g _ _ x 0 xlnx_total_xlnx x_pos (derivable_xlnx_total x_pos)). Defined. - -Lemma derive_xlnx_aux1 x (x_pos : 0 < x) : - derive_pt xlnx x (derivable_pt_xlnx x_pos) = - derive_pt xlnx_total x (derivable_xlnx_total x_pos). -Proof. by rewrite -derive_pt_f_eq_g. Qed. - -Lemma derive_xlnx_aux2 x (x_pos : 0 < x) : derive_pt xlnx x (derivable_pt_xlnx x_pos) = ln x + 1. -Proof. -rewrite derive_xlnx_aux1 /f derive_pt_mult derive_pt_ln. -rewrite mulRV ?gtR_eqF //. -rewrite (_ : derive_pt ssrfun.id x (derivable_id x) = 1) ; first by rewrite mul1R. -by rewrite -(derive_pt_id x); apply proof_derive_irrelevance. -Qed. - -Lemma derive_pt_xlnx x (x_pos : 0 < x) (pr : derivable_pt xlnx x) : derive_pt xlnx x pr = ln x + 1. -Proof. rewrite -derive_xlnx_aux2 ; by apply proof_derive_irrelevance. Qed. - -Lemma pderivable_Ropp_xlnx : pderivable (fun y => - xlnx y) (fun x => 0 < x <= exp (- 1)). -Proof. -move=> x /= Hx. -apply derivable_pt_opp. -apply derivable_pt_xlnx. -apply Hx. -Defined. - -Lemma xlnx_sdecreasing_0_Rinv_e_helper : forall (t : R) (Ht : 0 < t <= exp (-1)), - 0 < (if t == exp (-1) then 1 else derive_pt (fun x => - xlnx x) t (pderivable_Ropp_xlnx Ht)). -Proof. -move=> t [t0 te]; case: ifPn => [//|] /eqP Hcase. -rewrite derive_pt_opp derive_pt_xlnx //. -rewrite ltR_oppr oppR0 addRC -ltR_subRL sub0R. -apply exp_lt_inv; by rewrite exp_ln // ltR_neqAle. -Qed. - -Lemma xlnx_sdecreasing_0_Rinv_e x y : - 0 <= x <= exp (-1) -> 0 <= y <= exp (-1) -> x < y -> xlnx y < xlnx x. -Proof. -move=> [x1 x2] [y1 y2] xy. -case/boolP : (x == 0) => [/eqP ->|x0]. -- rewrite xlnx_0; apply xlnx_neg. - exact: (conj (@leR_ltR_trans x _ _ _ _) (leR_ltR_trans y2 ltRinve1)). -- rewrite -[X in _ < X]oppRK ltR_oppr. - have {}x0 : 0 < x by apply/RltP; rewrite lt0r x0; exact/RleP. - have {x1 y1}y0 : 0 < y by exact: (@ltR_trans x). - exact: (pderive_increasing (exp_pos _) xlnx_sdecreasing_0_Rinv_e_helper). -Qed. - -Lemma xlnx_decreasing_0_Rinv_e x y : - 0 <= x <= exp (-1) -> 0 <= y <= exp (-1) -> x <= y -> xlnx y <= xlnx x. -Proof. -move=> Hx Hy Hxy. -case/boolP : (x == y) => [/eqP ->|/eqP H]. - by apply/RleP; rewrite lexx. -by apply/ltRW/xlnx_sdecreasing_0_Rinv_e => //; rewrite ltR_neqAle. -Qed. - -End xlnx. - -Section diff_xlnx. - -Definition diff_xlnx := fun x => xlnx (1 - x) - xlnx x. - -Lemma derivable_pt_diff_xlnx x (Hx : 0 < x < 1) : derivable_pt diff_xlnx x. -Proof. -rewrite /diff_xlnx. -apply derivable_pt_plus ; last by apply derivable_pt_opp, derivable_pt_xlnx, Hx. -apply (derivable_pt_comp (fun x => 1 + - x) xlnx). - apply derivable_pt_plus ; first by apply derivable_pt_const. - apply derivable_pt_Ropp. -apply derivable_pt_xlnx. -rewrite subR_gt0; by case: Hx. -Defined. - -Lemma derive_pt_diff_xlnx x (Hx : 0 < x < 1) : - derive_pt diff_xlnx x (derivable_pt_diff_xlnx Hx) = -(2 + ln (x * (1-x))). -Proof. -rewrite derive_pt_plus derive_pt_opp derive_pt_xlnx; last by apply Hx. -rewrite derive_pt_comp derive_pt_plus derive_pt_const. -rewrite derive_pt_xlnx /=; last first. - rewrite subR_gt0; by case: Hx. -rewrite add0R ln_mult; first field. -- by apply Hx. -- rewrite subR_gt0; by case: Hx. -Qed. - -Lemma diff_xlnx_0 : diff_xlnx 0 = 0. -Proof. by rewrite /diff_xlnx subR0 xlnx_0 xlnx_1 subRR. Qed. - -Lemma diff_xlnx_1 : diff_xlnx 1 = 0. -Proof. by rewrite /diff_xlnx subRR xlnx_0 xlnx_1 subRR. Qed. - -Lemma derive_diff_xlnx_neg_aux x (Hx : 0 < x < 1) : x < exp (-2) -> 0 < derive_pt diff_xlnx x (derivable_pt_diff_xlnx Hx). -Proof. -rewrite derive_pt_diff_xlnx; case: Hx => Hx1 Hx2 xltexp2. -rewrite oppRD subR_gt0. -apply exp_lt_inv. -rewrite exp_ln ; last first. - apply mulR_gt0 => //; by rewrite subR_gt0. -apply (@ltR_trans (exp (-2) * (1 - x))). - apply ltR_pmul2r => //; by rewrite ltR_subRL addR0. -rewrite -{2}(mulR1 (exp (-2))). -apply ltR_pmul2l; first exact: exp_pos. -apply (@ltR_add2r (-1)). -by rewrite addRAC -[X in _ < X](addR0 _) ltR_add2l ltR_oppl oppR0. -Qed. - -Lemma derive_diff_xlnx_pos x (Hx : 0 < x < 1) (pr : derivable_pt diff_xlnx x) : - x < exp (-2) -> 0 < derive_pt diff_xlnx x pr. -Proof. -rewrite (proof_derive_irrelevance _ (derivable_pt_diff_xlnx Hx)) //. -exact: derive_diff_xlnx_neg_aux. -Qed. - -Lemma diff_xlnx_sincreasing_0_Rinv_e2 : forall x y : R, 0 <= x <= exp (-2) -> 0 <= y <= exp (-2) -> x < y -> diff_xlnx x < diff_xlnx y. -Proof. -apply derive_sincreasing_interv. -- move=> x /= [Hx1 Hx2]. - apply derivable_pt_diff_xlnx. - split => //. - exact: (ltR_trans Hx2 ltRinve21). -- move=> x /= Hx. - rewrite /diff_xlnx. - apply continuity_pt_minus ; last by apply continue_xlnx. - apply (continuity_pt_comp (fun x => 1 - x) xlnx); last by apply continue_xlnx. - apply continuity_pt_plus ; first by apply continuity_pt_const. - apply continuity_pt_opp. - apply derivable_continuous_pt. - by apply derivable_pt_id. -- by apply exp_pos. -- move => t prt [Ht1 Ht2]. - apply derive_diff_xlnx_pos => //. - exact: (conj Ht1 (ltR_trans Ht2 ltRinve21)). -Qed. - -Lemma xlnx_ineq x : 0 <= x <= exp (-2) -> xlnx x <= xlnx (1-x). -Proof. -move=> [Hx1 Hx2]. -apply Rge_le, Rminus_ge, Rle_ge. -rewrite -diff_xlnx_0 -/(diff_xlnx x). -case/boolP : (0 == x) => [/eqP ->|/eqP xnot0]. - by apply/RleP; rewrite lexx. -apply/ltRW/diff_xlnx_sincreasing_0_Rinv_e2 => //. - split; [ | exact/ltRW/exp_pos]. - by apply/RleP; rewrite lexx. -by rewrite ltR_neqAle. -Qed. - -End diff_xlnx. - -Section Rabs_xlnx. - -Definition xlnx_delta a := fun x => xlnx (x + a) - xlnx x. - -Lemma derivable_xlnx_delta eps (Heps : 0 < eps < 1) x (Hx : 0 < x < 1 - eps) : - derivable_pt (xlnx_delta eps) x. -Proof. -rewrite /xlnx_delta. -apply derivable_pt_minus. -- apply (derivable_pt_comp (fun x => x + eps) xlnx). - apply derivable_pt_plus ; first by apply derivable_pt_id. - by apply derivable_pt_const. - apply derivable_pt_xlnx. - apply addR_gt0; by [apply Heps | apply Hx]. -- by apply derivable_pt_xlnx, Hx. -Defined. - -Lemma derive_pt_xlnx_delta eps (Heps : 0 < eps < 1) x (Hx : 0 < x < 1 - eps) : - derive_pt (xlnx_delta eps) x (derivable_xlnx_delta Heps Hx) = ln (x + eps) - ln x. -Proof. -rewrite derive_pt_minus derive_pt_comp derive_pt_plus derive_pt_id. -rewrite derive_pt_const derive_pt_xlnx; last first. - apply addR_gt0; by [apply Hx | apply Heps]. -rewrite derive_pt_xlnx ; by [field | apply Hx]. -Qed. - -Lemma increasing_xlnx_delta eps (Heps : 0< eps < 1) : - forall x y : R, 0 <= x <= 1 - eps -> 0 <= y <= 1 - eps -> x < y -> - xlnx_delta eps x < xlnx_delta eps y. -Proof. -apply derive_sincreasing_interv. -- move=> x /= [Hx1 Hx2] ; rewrite /xlnx_delta. - apply derivable_pt_minus. - - apply (derivable_pt_comp (fun x => x + eps) xlnx). - apply derivable_pt_plus ; first by apply derivable_pt_id. - by apply derivable_pt_const. - apply derivable_pt_xlnx. - apply addR_gt0 => //; by apply Heps. - - exact: derivable_pt_xlnx. -- move=> x /= [Hx1 Hx2] ; rewrite /xlnx_delta. - apply continuity_pt_minus. - - apply (continuity_pt_comp (fun x => x + eps) xlnx); last by apply continue_xlnx. - apply continuity_pt_plus ; first by apply derivable_continuous_pt, derivable_pt_id. - by apply continuity_pt_const. - - by apply continue_xlnx. -- apply subR_gt0; by case: Heps. -- move=> t prd Ht. - rewrite (proof_derive_irrelevance _ (derivable_xlnx_delta Heps Ht)) //. - rewrite derive_pt_xlnx_delta. - apply/subR_gt0/ln_increasing; first by apply Ht. - rewrite -{1}(addR0 t). - by apply ltR_add2l, Heps. -Qed. - -Lemma xlnx_delta_bound eps : 0 < eps <= exp (-2) -> - forall x, 0 <= x <= 1 - eps -> `| xlnx_delta eps x | <= - xlnx eps. -Proof. -move=> [Heps1 Heps2] x [Hx1 Hx2]. -apply/RleP; rewrite ler_norml; apply/andP; split; apply/RleP. -- rewrite RoppE opprK (_ : xlnx eps = xlnx_delta eps 0); last first. - by rewrite /xlnx_delta add0R xlnx_0 subR0. - have [->|xnot0] := eqVneq x 0; first by apply/RleP; rewrite lexx. - apply/ltRW/increasing_xlnx_delta => //. - + exact: (conj Heps1 (leR_ltR_trans Heps2 ltRinve21)). - + split; by [apply (@leR_trans x) |]. - + by apply/RltP; rewrite lt0r xnot0/=; exact/RleP. -- apply: (@leR_trans (xlnx_delta eps (1 - eps))). - have [->|xnot0] := eqVneq x (1 - eps); first by apply/RleP; rewrite lexx. - apply/ltRW/increasing_xlnx_delta => //. - + exact: (conj Heps1 (leR_ltR_trans Heps2 ltRinve21)). - + split; [by apply (@leR_trans x) | ]. - by apply/RleP; rewrite lexx. - + by apply/RltP; rewrite lt_neqAle xnot0/=; exact/RleP. - rewrite /xlnx_delta subRK xlnx_1 sub0R leR_oppr oppRK. - by apply: xlnx_ineq; split => //; apply/RleP/ltW/RltP. -Qed. - -Lemma Rabs_xlnx a (Ha : 0 <= a <= exp(-2)) x y : - 0 <= x <= 1 -> 0 <= y <= 1 -> `| x - y | <= a -> - `| xlnx x - xlnx y | <= - xlnx a. -Proof. -move=> [Hx1 Hx2] [Hy1 Hy2] H. -case : (Rtotal_order x y) ; last case ; move => Hcase. -- have Haux : y = x + `| x - y |. - by rewrite distRC gtR0_norm ?subR_gt0 // subRKC. - rewrite Haux -normRN oppRD oppRK addRC. - apply (@leR_trans (- xlnx `| x - y |)). - apply xlnx_delta_bound. - - split. - - exact/Rabs_pos_lt/eqP/ltR_eqF/subR_lt0. - - by apply (@leR_trans a) => //; apply Ha. - - by split => //; rewrite leR_subr_addr -Haux. - rewrite leR_oppr oppRK. - apply xlnx_decreasing_0_Rinv_e => //. - - split; first exact: normR_ge0. - apply (@leR_trans a) => //. - apply (@leR_trans (exp (- 2))); first by apply Ha. - apply/ltRW/exp_increasing; lra. - - split; first by apply Ha. - apply (@leR_trans (exp (-2))); first by apply Ha. - apply/ltRW/exp_increasing; lra. -- subst x ; rewrite subRR normR0 leR_oppr oppR0. - case/orP : (orbN (0 == a)); last move=> anot0. - move=> /eqP <-; rewrite xlnx_0. - by apply/RleP; rewrite lexx. - apply/ltRW/xlnx_neg; split. - - by apply/RltP; rewrite lt0r eq_sym anot0; exact/RleP/(proj1 Ha). - - exact: (leR_ltR_trans (proj2 Ha) ltRinve21). -- apply Rgt_lt in Hcase. - have Haux : x = y + `| x - y | by rewrite gtR0_norm ?subR_gt0 // subRKC. - rewrite distRC in H Haux. - rewrite Haux. - apply (@leR_trans (- xlnx `| y - x |)). - apply xlnx_delta_bound. - - split. - - exact/Rabs_pos_lt/eqP/ltR_eqF/subR_lt0. - - by apply (@leR_trans a) => //; apply Ha. - - split => //. - by rewrite leR_subr_addr -Haux. - rewrite leR_oppr oppRK. - apply xlnx_decreasing_0_Rinv_e => //. - + split; first exact: normR_ge0. - apply (@leR_trans a) => //. - apply (@leR_trans (exp (-2))); first by apply Ha. - apply/ltRW/exp_increasing; lra. - - split; first by apply Ha. - apply (@leR_trans (exp (-2))); first by apply Ha. - apply/ltRW/exp_increasing; lra. -Qed. - -End Rabs_xlnx. - -End xlnx_sect. - -Section log_concave. - -Lemma pderivable_log a x1 : 0 <= a -> pderivable log (fun x2 : R => a < x2 < x1). -Proof. -move=> a0; rewrite /pderivable => x Hx. -rewrite /log /Log (_ : (fun x0 => ln x0 / ln 2) = - (mult_real_fct (/ ln 2) (fun x0 => ln x0))); last first. - by rewrite boolp.funeqE => x0; rewrite /mult_real_fct mulRC. -apply/derivable_pt_scal/derivable_pt_ln/(leR_ltR_trans a0); by case: Hx. -Qed. - -Lemma ln_concave_at_gt0 x y (t : {prob R}) : x < y -> - 0 < x -> 0 < y -> concave_function_at ln x y t. -Proof. -move=> xy x0 y0; apply RNconcave_function_at. -set Df := fun x => - / x. -move: t. -have HDf : pderivable (fun x => - ln x) (fun x0 => x <= x0 <= y). - rewrite (_ : (fun x => - ln x) = comp Ropp ln); last by rewrite boolp.funeqE. - move=> r xry; apply derivable_pt_comp; last exact: derivable_pt_Ropp. - apply/derivable_pt_ln/(@ltR_leR_trans x) => //; by case: xry. -set DDf := fun x => / x^2. -have HDDf : pderivable Df (fun x0 : R => x <= x0 <= y). - rewrite /Df (_ : (fun x => - / x) = comp Ropp Rinv); last first. - by rewrite boolp.funeqE. - move=> r xry; apply derivable_pt_comp; last exact/derivable_pt_Ropp. - rewrite (_ : Rinv = inv_fct (fun x => x)); last by rewrite boolp.funeqE. - apply derivable_pt_inv; last exact: derivable_pt_id. - by apply/eqP/gtR_eqF/(@ltR_leR_trans x) => //; case: xry. -apply: (@second_derivative_convexf_pt _ _ _ HDf Df _ HDDf DDf) => //. -- move=> r xry; rewrite /Df. - have r0 : 0 < r by apply (@ltR_leR_trans x) => //; case: xry. - transitivity (derive_pt (comp Ropp ln) _ - (derivable_pt_comp ln Ropp _ (derivable_pt_ln r0) (derivable_pt_Ropp _))). - by rewrite derive_pt_comp /= mulN1R. - exact: proof_derive_irrelevance. -- move=> r xry; rewrite /DDf /Df. - have /eqP r0 : r != 0 by apply/gtR_eqF/(@ltR_leR_trans x) => //; case: xry. - transitivity (derive_pt (comp Ropp Rinv) _ - (derivable_pt_comp Rinv Ropp _ - (derivable_pt_inv _ _ r0 (derivable_pt_id _)) (derivable_pt_Ropp _))). - rewrite derive_pt_comp [in RHS]/= derive_pt_inv derive_pt_id mulN1R. - by rewrite /Rdiv mulNR oppRK mul1R Rsqr_pow2 (* TODO: rename? *). - exact/proof_derive_irrelevance. -- move=> r; rewrite /DDf => -[x11 x12]. - rewrite -expRV; last by apply/gtR_eqF/(@ltR_leR_trans x). - exact/expR_ge0/ltRW/invR_gt0/(@ltR_leR_trans x). -Qed. - -Local Open Scope reals_ext_scope. - -Lemma log_concave_at_gt0W x y (t : {prob R}) : x < y -> - 0 < x -> 0 < y -> concave_function_at log x y t. -Proof. -move=> xy x0 y0; rewrite /log /Log. -apply concave_function_atN; [exact: ln_concave_at_gt0 | exact/ltRW/invR_gt0/ln2_gt0]. -Qed. - -Lemma log_concave_at_gt0 x y (t : {prob R}) : 0 < x -> 0 < y -> concave_function_at log x y t. -Proof. -move=> x0 y0. -case/boolP : (x < y)%mcR => [/RltP xy|]. - exact: log_concave_at_gt0W. -rewrite -leNgt le_eqVlt => /predU1P[->|yx]. - exact: concave_function_atxx. -rewrite (probK t); apply: concavef_at_onem => //. - exact/RltP. -by apply: log_concave_at_gt0W => //; exact/RltP. -Qed. - -Lemma log_concave : concave_function_in Rpos_interval log. -Proof. -move=> x y t; rewrite !classical_sets.in_setE(*TODO: import?*) => Hx Hy. -exact: log_concave_at_gt0. -Qed. - -End log_concave. diff --git a/probability/log_sum.v b/probability/log_sum.v index 45e2394b..889a3988 100644 --- a/probability/log_sum.v +++ b/probability/log_sum.v @@ -1,72 +1,72 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect all_algebra. -Require Import Reals Lra. -From mathcomp Require Import Rstruct lra. -Require Import ssrR realType_ext Reals_ext Ranalysis_ext logb ln_facts bigop_ext. +From mathcomp Require Import all_ssreflect all_algebra lra. +From mathcomp Require Import Rstruct reals exp. +Require Import bigop_ext realType_ext realType_ln. (******************************************************************************) (* The log-sum Inequality *) (******************************************************************************) -Import GRing.Theory Num.Theory Order.TTheory. +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. -Local Open Scope reals_ext_scope. -Local Open Scope R_scope. +Local Open Scope ring_scope. + +Import Order.POrderTheory GRing.Theory Num.Theory. Local Notation "'\sum_{' C '}' f" := (\sum_(a | a \in C) f a) (at level 10, format "\sum_{ C } f"). -Definition log_sum_stmt {A : finType} (C : {set A}) (f g : {ffun A -> R}) := - (forall x, 0 <= f x) -> - (forall x, 0 <= g x) -> +Definition log_sum_stmt {R : realType} {A : finType} (C : {set A}) + (f g : {ffun A -> R}) := + (forall x, 0 <= f x) -> (forall x, 0 <= g x) -> f `<< g -> \sum_{C} f * log (\sum_{C} f / \sum_{C} g) <= \sum_(a | a \in C) f a * log (f a / g a). -Lemma log_sum1 {A : finType} (C : {set A}) (f g : {ffun A -> R}) : +Lemma log_sum1 {R : realType} {A : finType} (C : {set A}) (f g : {ffun A -> R}) : (forall a, a \in C -> 0 < f a) -> log_sum_stmt C f g. Proof. move=> fspos f0 g0 fg. case/boolP : (C == set0) => [ /eqP -> | Hc]. - by apply/RleP; rewrite !big_set0 mul0R lexx. + by rewrite !big_set0 mul0r lexx. have gspos : forall a, a \in C -> 0 < g a. - move=> a a_C. case (g0 a) => //. + move=> a a_C. + rewrite lt_neqAle g0 andbT; apply/eqP. move=>/esym/(dominatesE fg) abs. - by move: (fspos _ a_C); rewrite abs => /ltRR. + by move: (fspos _ a_C); rewrite abs ltxx. have Fnot0 : \sum_{ C } f != 0. apply/eqP => /psumr_eq0P abs. case/set0Pn : Hc => a aC. move: (fspos _ aC); rewrite abs //. - by move=> /RltP; rewrite ltxx. - by move=> i iC; exact/RleP. + by rewrite ltxx. have Gnot0 : \sum_{ C } g != 0. apply/eqP => /psumr_eq0P abs. case/set0Pn : Hc => a aC. - move: (gspos _ aC); rewrite abs //. - by move=> /RltP; rewrite ltxx. - by move=> i iC; exact/RleP. + by move: (gspos _ aC); rewrite abs // ltxx. wlog : Fnot0 g g0 Gnot0 fg gspos / \sum_{ C } f = \sum_{ C } g. move=> Hwlog. set k := (\sum_{ C } f / \sum_{ C } g). have Fspos : 0 < \sum_{ C } f. - suff Fpos : 0 <= \sum_{ C } f by apply/RltP; rewrite lt0r Fnot0; exact/RleP. - by apply/RleP/sumr_ge0 => ? ?; exact/RleP/ltRW/fspos. + suff Fpos : 0 <= \sum_{ C } f by rewrite lt0r Fnot0. + by apply/sumr_ge0 => ? ?; exact/ltW/fspos. have Gspos : 0 < \sum_{ C } g. - suff Gpocs : 0 <= \sum_{ C } g by apply/RltP; rewrite lt0r Gnot0; exact/RleP. - by apply/RleP/sumr_ge0 => ? ?; exact/RleP/ltRW/gspos. - have kspos : 0 < k by exact: divR_gt0. + suff Gpocs : 0 <= \sum_{ C } g by rewrite lt0r Gnot0. + by apply/sumr_ge0 => ? ?; exact/ltW/gspos. + have kspos : 0 < k by exact: divr_gt0. set kg := [ffun x => k * g x]. have kg_pos : forall a, 0 <= kg a. - by move=> a; rewrite /kg /= ffunE; apply mulR_ge0 => //; exact: ltRW. + by move=> a; rewrite /kg /= ffunE; apply mulr_ge0 => //; exact: ltW. have kabs_con : f `<< kg. - apply/dominates_scale => //; exact/gtR_eqF. + by apply/dominates_scale => //; rewrite ?gt_eqF//. have kgspos : forall a, a \in C -> 0 < kg a. - by move=> a a_C; rewrite ffunE; apply mulR_gt0 => //; exact: gspos. + by move=> a a_C; rewrite ffunE; apply mulr_gt0 => //; exact: gspos. have Hkg : \sum_{C} kg = \sum_{C} f. transitivity (\sum_(a in C) k * g a). by apply eq_bigr => a aC; rewrite /= ffunE. - by rewrite -big_distrr /= /k /Rdiv -mulRA mulRC mulVR // mul1R. + by rewrite -big_distrr /= /k -mulrA mulVf ?mulr1. have Htmp : \sum_{ C } kg != 0. rewrite /=. evar (h : A -> R); rewrite (eq_bigr h); last first. @@ -75,58 +75,54 @@ wlog : Fnot0 g g0 Gnot0 fg gspos / \sum_{ C } f = \sum_{ C } g. by apply eq_bigr => a aC /=; rewrite ffunE. symmetry in Hkg. move: {Hwlog}(Hwlog Fnot0 kg kg_pos Htmp kabs_con kgspos Hkg) => /= Hwlog. - rewrite Hkg {1}/Rdiv mulRV // /log Log_1 mulR0 in Hwlog. + rewrite Hkg mulfV // log1 mulr0 in Hwlog. set rhs := \sum_(_ | _) _ in Hwlog. rewrite (_ : rhs = \sum_(a | a \in C) (f a * log (f a / g a) - f a * log k)) in Hwlog; last first. rewrite /rhs. apply eq_bigr => a a_C. - rewrite /Rdiv /log LogM; last 2 first. + rewrite logM; last 2 first. exact/fspos. - rewrite ffunE; apply/invR_gt0/mulR_gt0 => //; exact/gspos. - rewrite LogV; last first. - rewrite ffunE; apply mulR_gt0 => //; exact: gspos. - rewrite ffunE LogM //; last exact: gspos. - rewrite LogM //; last 2 first. + by rewrite ffunE invr_gt0// mulr_gt0//; exact/gspos. + rewrite logV; last first. + rewrite ffunE; apply mulr_gt0 => //; exact: gspos. + rewrite ffunE logM //; last exact: gspos. + rewrite logM //; last 2 first. exact/fspos. - by apply invR_gt0 => //; apply gspos. - by rewrite LogV; [field | apply gspos]. - rewrite big_split /= -big_morph_oppR -big_distrl /= in Hwlog. - by rewrite -subR_ge0. + by rewrite invr_gt0//; apply gspos. + by rewrite logV; [lra | apply gspos]. + rewrite big_split /= -big_morph_oppr -big_distrl /= in Hwlog. + by rewrite -subr_ge0. move=> Htmp; rewrite Htmp. -rewrite /Rdiv mulRV; last by rewrite -Htmp. -rewrite /log Log_1 mulR0. +rewrite mulfV; last by rewrite -Htmp. +rewrite log1 mulr0. suff : 0 <= \sum_(a | a \in C) f a * ln (f a / g a). move=> H. - rewrite /log /Rdiv. set rhs := \sum_( _ | _ ) _. have -> : rhs = \sum_(H | H \in C) (f H * (ln (f H / g H))) / ln 2. rewrite /rhs. - apply eq_bigr => a a_C; by rewrite /Rdiv -mulRA. + by apply eq_bigr => a a_C; by rewrite -mulrA. rewrite -big_distrl /=. - by apply mulR_ge0 => //; exact/invR_ge0. -apply (@leR_trans (\sum_(a | a \in C) f a * (1 - g a / f a))). - apply (@leR_trans (\sum_(a | a \in C) (f a - g a))). - rewrite big_split /= -big_morph_oppR Htmp addRN. - by apply/RleP; rewrite lexx. - apply/Req_le/eq_bigr => a a_C. - rewrite mulRDr mulR1 mulRN. - case: (Req_EM_T (g a) 0) => [->|ga_not_0]. - by rewrite div0R mulR0. - by field; exact/eqP/gtR_eqF/(fspos _ a_C). -apply: leR_sumR => a C_a. -apply leR_wpmul2l; first exact/ltRW/fspos. -rewrite -[X in _ <= X]oppRK leR_oppr -ln_Rinv; last first. - apply divR_gt0; by [apply fspos | apply gspos]. -rewrite invRM; last 2 first. - exact/gtR_eqF/(fspos _ C_a). - by rewrite invR_neq0' // gtR_eqF //; exact/(gspos _ C_a). -rewrite invRK mulRC; apply: leR_trans. - by apply/ln_id_cmp/divR_gt0; [apply gspos | apply fspos]. -apply Req_le. -by field; exact/eqP/gtR_eqF/(fspos _ C_a). + by rewrite mulr_ge0// invr_ge0// ln2_ge0. +apply (@le_trans _ _ (\sum_(a | a \in C) f a * (1 - g a / f a))). + apply (@le_trans _ _ (\sum_(a | a \in C) (f a - g a))). + by rewrite big_split /= -big_morph_oppr Htmp subrr. + rewrite le_eqVlt; apply/orP; left; apply/eqP. + apply/eq_bigr => a a_C. + rewrite mulrDr mulr1 mulrN. + have [->|ga_not_0] := eqVneq (g a) 0. + by rewrite mul0r mulr0. + by rewrite mulrCA divff ?mulr1// gt_eqF//; exact/(fspos _ a_C). +apply: ler_sum => a C_a. +apply ler_wpM2l; first exact/ltW/fspos. +rewrite -[X in _ <= X]opprK lerNr -lnV; last first. + by rewrite posrE divr_gt0//; [apply fspos | apply gspos]. +rewrite invfM. +rewrite invrK mulrC; apply: le_trans. + by apply/ln_id_cmp; rewrite divr_gt0//; [apply gspos | apply fspos]. +by rewrite opprB. Qed. -Lemma log_sum {A : finType} (C : {set A}) (f g : {ffun A -> R}) : +Lemma log_sum {R : realType} {A : finType} (C : {set A}) (f g : {ffun A -> R}) : log_sum_stmt C f g. Proof. move=> f0 g0 fg. @@ -140,13 +136,13 @@ suff : \sum_{D} f * log (\sum_{D} f / \sum_{D} g) <= move Hlhs : (a \in C) => lhs. destruct lhs => //. symmetry. - rewrite in_setU /C1 /C1 !in_set Hlhs /=. + rewrite in_setU !in_set Hlhs /=. by destruct (f a == 0). - by rewrite in_setU in_set Hlhs /= /C1 in_set Hlhs. + by rewrite in_setU in_set Hlhs /= in_set Hlhs. have DID' : [disjoint D & D']. rewrite -setI_eq0. apply/eqP/setP => a. - rewrite in_set0 /C1 /C1 in_setI !in_set. + rewrite in_set0 in_setI !in_set. by destruct (a \in C) => //=; rewrite andNb. have H1 : \sum_{C} f = \sum_{D} f. rewrite setUC in DUD'. @@ -155,45 +151,48 @@ suff : \sum_{D} f * log (\sum_{D} f / \sum_{D} g) <= apply eq_bigr => a. rewrite /D' in_set. by case/andP => _ /eqP. - by rewrite big_const iter_addR mulR0 add0R. + by rewrite big_const iter_addr addr0 mul0rn add0r. rewrite -H1 in H. - have pos_F : 0 <= \sum_{C} f by apply/RleP/sumr_ge0 => ? ?; exact/RleP. - apply (@leR_trans (\sum_{C} f * log (\sum_{C} f / \sum_{D} g))). - case/Rle_lt_or_eq_dec : pos_F => pos_F; last first. - by rewrite -pos_F !mul0R. - have H2 : 0 <= \sum_(a | a \in D) g a by apply/RleP/sumr_ge0 => ? _; exact/RleP. - case/Rle_lt_or_eq_dec : H2 => H2; last first. + have pos_F : 0 <= \sum_{C} f by apply/sumr_ge0 => ? ?. + apply (@le_trans _ _ (\sum_{C} f * log (\sum_{C} f / \sum_{D} g))). + move: pos_F; rewrite le_eqVlt => /predU1P[pos_F|pos_F]. + by rewrite -pos_F !mul0r. + have H2 : 0 <= \sum_(a | a \in D) g a by apply/sumr_ge0. + move: H2; rewrite le_eqVlt => /predU1P[g0'|gt0']. have : 0 = \sum_{D} f. - transitivity (\sum_(a | a \in D) 0). - by rewrite big_const iter_addR mulR0. + transitivity (\sum_(a | a \in D) (0:R))%R. + by rewrite big1. apply: eq_bigr => a a_C1. rewrite (dominatesE fg) //. - apply/(@psumr_eq0P _ _ (mem D) g) => // i _. - exact/RleP. - move=> abs; rewrite -abs in H1; rewrite H1 in pos_F. - by move/ltRR : pos_F. + by apply/(@psumr_eq0P _ _ (mem D)) => //. + by move=> abs; rewrite -abs in H1; rewrite H1 ltxx in pos_F. have H3 : 0 < \sum_(a | a \in C) g a. rewrite setUC in DUD'. rewrite DUD' (big_union _ g DID') /=. - by apply: addR_gt0wr => //; apply/RleP/sumr_ge0=> ? _; exact/RleP. - apply/(leR_wpmul2l (ltRW pos_F))/Log_increasing_le => //. - by apply divR_gt0 => //; rewrite -HG. - apply/(leR_wpmul2l (ltRW pos_F))/leR_inv => //. + rewrite ltr_pwDr//. + by apply/sumr_ge0 => //. + apply/ler_wpM2l => //. + exact/ltW. + rewrite ler_log// ?posrE//; last 2 first. + by apply divr_gt0 => //; rewrite -HG. + by apply divr_gt0 => //; rewrite -HG. + apply/ler_wpM2l => //. + exact/ltW. + rewrite lef_pV2//. rewrite setUC in DUD'. - rewrite DUD' (big_union _ g DID') /= -[X in X <= _]add0R; apply leR_add2r. - by apply/RleP/sumr_ge0 => ? ?; exact/RleP. - apply: (leR_trans H). + rewrite DUD' (big_union _ g DID') /=. + rewrite lerDr//. + by apply/sumr_ge0. + apply: (le_trans H). rewrite setUC in DUD'. rewrite DUD' (big_union _ (fun a => f a * log (f a / g a)) DID') /=. rewrite (_ : \sum_(_ | _ \in D') _ = 0); last first. - transitivity (\sum_(a | a \in D') 0). + transitivity (\sum_(a | a \in D') (0:R)). apply eq_bigr => a. - by rewrite /D' in_set => /andP[a_C /eqP ->]; rewrite mul0R. - by rewrite big_const iter_addR mulR0. - by apply/RleP; rewrite add0R lexx. + by rewrite /D' in_set => /andP[a_C /eqP ->]; rewrite mul0r. + by rewrite big1. + by rewrite add0r lexx. apply: log_sum1 => // a. -rewrite /C1 in_set. -case/andP => a_C fa_not_0. -case (f0 a) => // abs. -by rewrite abs eqxx in fa_not_0. +rewrite in_set => /andP[a_C fa_not_0]. +by rewrite lt_neqAle eq_sym fa_not_0 f0. Qed. diff --git a/probability/necset.v b/probability/necset.v index 592e6e65..55022183 100644 --- a/probability/necset.v +++ b/probability/necset.v @@ -5,8 +5,7 @@ Require Import Reals. From mathcomp Require Import all_ssreflect ssralg ssrnum. From mathcomp Require Import mathcomp_extra boolp classical_sets Rstruct reals. From mathcomp Require Import finmap. -Require Import Reals_ext realType_ext classical_sets_ext ssrR fdist fsdist. -Require Import convex. +Require Import realType_ext classical_sets_ext fdist fsdist convex. (******************************************************************************) (* Semi-complete semilattice structures and non-empty convex sets *) @@ -163,11 +162,11 @@ HB.instance Definition _ {A B} (f : A -> B) (X : neset A) := HB.instance Definition _ {T} (X Y : neset T) := isNESet.Build _ _ (neset_setU_neq0 X Y). -Lemma neset_hull_neq0 (T : convType) (F : neset T) : hull F != set0. +Lemma neset_hull_neq0 {R : realType} (T : convType R) (F : neset T) : hull F != set0. Proof. by rewrite hull_eq0 neset_neq0. Qed. (* Canonical neset_hull *) -HB.instance Definition _ (T : convType) (F : neset T) := +HB.instance Definition _ {R : realType} (T : convType R) (F : neset T) := isNESet.Build _ _ (neset_hull_neq0 F). End neset_lemmas. @@ -175,12 +174,13 @@ Local Hint Resolve repr_in_neset : core. (*Arguments image_neset : simpl never.*) #[short(type=necset)] -HB.structure Definition NECSet (A : convType) := {X of @isConvexSet A X & @isNESet A X}. +HB.structure Definition NECSet {R : realType} (A : convType R) := + {X of @isConvexSet R A X & @isNESet A X}. Section conv_set_def. Local Open Scope classical_set_scope. -Local Open Scope R_scope. -Variable L : convType. +Context {R : realType}. +Variable L : convType R. (* The three definitions below work more or less the same way, although the lemmas are not sufficiently provided in classical_sets.v @@ -207,8 +207,8 @@ Notation "X :<| p |>: Y" := (conv_set p X Y) : convex_scope. Section conv_set_lemmas. Local Open Scope classical_set_scope. -Local Open Scope R_scope. -Variables A : convType. +Context {R : realType}. +Variables A : convType R. Lemma conv_setE p (X Y : set A) : X :<| p |>: Y = \bigcup_(x in X) (x <| p |>: Y). @@ -359,7 +359,7 @@ Qed. (*Canonical conv_pt_cset*) HB.instance Definition _ (p : {prob R}) (x : A) (Y : {convex_set A}) := - isConvexSet.Build _ _ (conv_pt_cset_is_convex p x Y). + isConvexSet.Build R _ _ (conv_pt_cset_is_convex p x Y). Lemma conv_cset_is_convex (p : {prob R}) (X Y : {convex_set A}) : is_convex_set (conv_set p X Y). @@ -372,7 +372,7 @@ by rewrite convACA; apply/conv_in_conv_set; Qed. HB.instance Definition _ (p : {prob R}) (X Y : {convex_set A}) := - isConvexSet.Build _ _ (conv_cset_is_convex p X Y). + isConvexSet.Build R _ _ (conv_cset_is_convex p X Y). Lemma oplus_conv_cset_is_convex (X Y : {convex_set A}) : is_convex_set (oplus_conv_set X Y). @@ -392,13 +392,13 @@ apply (prob_trichotomy' q) => [| |oq]. by move/asboolP: (convex_setP Y); apply. + rewrite conv1 convC convA; apply conv_in_oplus_conv_set=> //. by move/asboolP: (convex_setP X); apply. - + case: (convACA' xu yu xv yv oq op or)=> q' [] p' [] r' ->. + + case: (convACA' xu yu xv yv (OProb.p oq) (OProb.p op) (OProb.p or)(*TODO: oprob coercions broken*))=> q' [] p' [] r' ->. by apply conv_in_oplus_conv_set; [move/asboolP: (convex_setP X); apply | move/asboolP: (convex_setP Y); apply]. Qed. HB.instance Definition _ (X Y : {convex_set A}) := - isConvexSet.Build _ _ (oplus_conv_cset_is_convex X Y). + isConvexSet.Build _ _ _ (oplus_conv_cset_is_convex X Y). Fixpoint iter_conv_cset_is_convex (X : {convex_set A}) (n : nat) : is_convex_set (iter_conv_set X n) := @@ -407,11 +407,11 @@ Fixpoint iter_conv_cset_is_convex (X : {convex_set A}) (n : nat) : | n'.+1 => oplus_conv_cset_is_convex X (ConvexSet.Pack (ConvexSet.Class - (isConvexSet.Build _ _ (iter_conv_cset_is_convex X n')))) + (isConvexSet.Build R _ _ (iter_conv_cset_is_convex X n')))) end. HB.instance Definition _ (X : {convex_set A}) (n : nat) := - isConvexSet.Build _ _ (iter_conv_cset_is_convex X n). + isConvexSet.Build R _ _ (iter_conv_cset_is_convex X n). Lemma conv_pt_set_monotone (p : {prob R}) (x : A) (Y Y' : set A) : Y `<=` Y' -> x <| p |>: Y `<=` x <| p |>: Y'. @@ -449,16 +449,16 @@ by exists 1%:pr => //; rewrite conv1_set. Qed. Lemma Convn_iter_conv_set (n : nat) : - forall (g : 'I_n -> A) (d : {fdist 'I_n}) (X : set A), + forall (g : 'I_n -> A) (d : R.-fdist 'I_n) (X : set A), g @` setT `<=` X -> iter_conv_set X n (<|>_d g). Proof. elim: n => [g d|n IHn g d X]; first by have := fdistI0_False d. -have [/eqP ->|Xneq0 gX] := boolP (X == set0). +have [->|Xneq0 gX] := eqVneq X set0. by move=> /(_ (g ord0)) H; exfalso; apply/H/imageP. set X' := NESet.Pack (NESet.Class (isNESet.Build _ _ Xneq0)). have gXi : forall i : 'I_n.+1, X (g i). by move=> i; move/subset_image : gX; apply. -have [/eqP d01|d0n1] := boolP (d ord0 == 1). +have [d01|d0n1] := eqVneq (d ord0) 1%R. - suff : X (<|>_d g) by move/(@iter_conv_set_superset X' n.+1 (<|>_d g)). by rewrite (Convn_proj g d01); exact/gX/imageP. - rewrite ConvnIE //; exists (probfdist d ord0) => //; exists (g ord0) => //. @@ -511,7 +511,7 @@ Qed. Lemma hull_conv_set_strr (p : {prob R}) (X Y : set A) : hull (X :<| p |>: hull Y) = hull (X :<| p |>: Y). Proof. -apply hull_eqEsubset=> u. +apply: hull_eqEsubset => u. - case=> x Xx; rewrite conv_pt_setE=> -[] y [] n [] g [] d [] gY yg <-. exists n, (fun i => x <|p|> g i), d; rewrite -ConvnDr yg; split=> //. by move=> v [] i _ <-; exists x=> //; apply/conv_in_conv_pt_set/gY/imageP. @@ -521,10 +521,9 @@ Qed. End conv_set_lemmas. -Local Open Scope classical_set_scope. -Lemma affine_image_conv_set (A B : convType) (f : {affine A -> B}) p - (X Y : set A) : - f @` (X :<| p |>: Y) = f @` X :<| p |>: f @` Y. +Lemma affine_image_conv_set {R : realType} (A B : convType R) + (f : {affine A -> B}) p (X Y : set A) : + (f @` (X :<| p |>: Y) = f @` X :<| p |>: f @` Y)%classic. Proof. rewrite eqEsubset; split=> [u [v]|u]. - move=> /conv_in_conv_set' [] x [] y [] Xx [] Yy ->; rewrite affine_conv=> <-. @@ -532,7 +531,6 @@ rewrite eqEsubset; split=> [u [v]|u]. - case/conv_in_conv_set'=> x [] y [] [] x0 Xx0 <- [] [] y0 Yy0 <- ->. by rewrite -affine_conv; apply/imageP/conv_in_conv_set. Qed. -Local Close Scope classical_set_scope. (* (saikawa) I am aware that ssreflect/order.v has definitions of porder and lattice. For now, I write down the following definition of semilattice @@ -542,7 +540,7 @@ HB.mixin Record isSemiLattice (T : Type) of Choice T := { lub : T -> T -> T ; lubC : commutative lub; lubA : associative lub; - lubxx : idempotent lub }. + lubxx : idempotent_op lub }. #[short(type=semiLattType)] HB.structure Definition SemiLattice := { T of isSemiLattice T & }. @@ -644,7 +642,7 @@ Proof. by move=> x y; rewrite /lub_binary -!lubE lubC. Qed. Let lub_binaryA : associative lub_binary. Proof. by move=> x y z; rewrite /lub_binary -!lubE lubA. Qed. -Let lub_binaryxx : idempotent lub_binary. +Let lub_binaryxx : idempotent_op lub_binary. Proof. by move=> x; rewrite /lub_binary -lubE lubxx. Qed. End semicompsemilatt_lemmas. @@ -658,8 +656,7 @@ HB.mixin Record isBiglubMorph (U V : semiCompSemiLattType) (f : U -> V) := { HB.structure Definition BiglubMorph (U V : semiCompSemiLattType) := {f of isBiglubMorph U V f}. -Notation "{ 'Biglub_morph' T '->' R }" := - (BiglubMorph.type T R) : convex_scope. +Notation "{ 'Biglub_morph' T '->' R }" := (BiglubMorph.type T R) : convex_scope. Section biglub_morph. Variables (L M : semiCompSemiLattType). @@ -683,13 +680,13 @@ Local Open Scope convex_scope. Local Open Scope latt_scope. Local Open Scope classical_set_scope. -HB.mixin Record isSemiLattConv L of ConvexSpace L & SemiLattice L := { +HB.mixin Record isSemiLattConv {R : realType} L of ConvexSpace R L & SemiLattice L := { lubDr : forall (p : {prob R}) (x y z : L), conv p x (y [+] z) = (conv p x y) [+] (conv p x z) }. #[short(type=semiLattConvType)] -HB.structure Definition SemiLattConv := - {L of isSemiLattConv L & ConvexSpace L & SemiLattice L}. +HB.structure Definition SemiLattConv {R : realType} := + {L of isSemiLattConv R L & ConvexSpace R L & SemiLattice L}. (* Homomorphism between semilattice convex spaces *) (* TODO: define LubAffine for semiLattConvType *) @@ -697,8 +694,9 @@ HB.structure Definition SemiLattConv := Section semilattconvtype_lemmas. Local Open Scope latt_scope. Local Open Scope convex_scope. +Context {R : realType}. -Variable L : semiLattConvType. +Variable L : semiLattConvType R. Lemma lubDl p : left_distributive (fun x y => x <|p|> y) (@lub L). Proof. by move=> x y z; rewrite convC lubDr -(convC _ x z) -(convC _ y z). Qed. @@ -741,26 +739,26 @@ Fail Lemma lub_absorbs_convn (n : nat) (d : {fdist 'I_n}) (f : 'I_n -> L) : \lub_(i < n) f i = (\lub_(i < n) f i) [+] (<|>_d f). End semilattconvtype_lemmas. -HB.mixin Record isSemiCompSemiLattConv L of SemiCompSemiLatt L & - ConvexSpace L := { +HB.mixin Record isSemiCompSemiLattConv {R : realType} L of SemiCompSemiLatt L & + ConvexSpace R L := { biglubDr : forall (p : {prob R}) (x : L) (I : neset L), conv p x (|_| I) = |_| ((conv p x) @` I)%:ne }. #[short(type=semiCompSemiLattConvType)] -HB.structure Definition SemiCompSemiLattConv := - { L of isSemiCompSemiLattConv L & SemiCompSemiLatt L & ConvexSpace L & - isSemiLattConv L}. +HB.structure Definition SemiCompSemiLattConv {R : realType} := + { L of isSemiCompSemiLattConv R L & SemiCompSemiLatt L & ConvexSpace R L & + isSemiLattConv R L}. -HB.structure Definition BiglubAffine (U V : semiCompSemiLattConvType) := - {f of isAffine U V f & isBiglubMorph U V f}. +HB.structure Definition BiglubAffine {R : realType} (U V : semiCompSemiLattConvType R) := + {f of @isAffine R U V f & isBiglubMorph U V f}. Notation "{ 'Biglub_affine' T '->' R }" := (BiglubAffine.type T R) : convex_scope. Section biglub_affine_functor_laws. -Variables (R S T : semiCompSemiLattConvType) +Variables (R' : realType) (R S T : semiCompSemiLattConvType R') (f : {Biglub_affine S -> T}) (g : {Biglub_affine R -> S}). Let biglubmorph_idfun : biglubmorph (@idfun R). @@ -784,8 +782,9 @@ Section semicompsemilattconvtype_lemmas. Local Open Scope latt_scope. Local Open Scope convex_scope. Local Open Scope classical_set_scope. +Context {R : realType}. -Variable L : semiCompSemiLattConvType. +Variable L : semiCompSemiLattConvType R. Lemma biglubDl (p : {prob R}) (X : neset L) (y : L) : |_| X <|p|> y = |_| ((fun x => x <|p|> y) @` X)%:ne. @@ -836,7 +835,7 @@ elim: n => [|n IHn /=]; first by congr (|_| _); apply/neset_ext. rewrite (biglub_oplus_conv_setE _ (iter_conv_set X n)%:ne). transitivity (|_| [set |_| X]%:ne); last by rewrite biglub1. congr (|_| _%:ne); apply/neset_ext => /=. -transitivity ((fun _ => |_| X) @` probset); last by rewrite image_const. +transitivity ((fun _ => |_| X) @` @probset R); last by rewrite image_const. by congr image; apply funext=> p; rewrite IHn convmm. Qed. @@ -870,7 +869,8 @@ HB.instance Definition _ (*biglubDr_semiLattConvType*) := @isSemiLattConv.Build End semicompsemilattconvtype_lemmas. Section necset_canonical. -Variable (A : convType). +Context {R : realType}. +Variable (A : convType R). Canonical necset_predType := Eval hnf in PredType (fun t : necset A => (fun x => x \in (t : set _))). HB.instance Definition _ := gen_eqMixin (necset A). @@ -878,7 +878,8 @@ HB.instance Definition _ := gen_choiceMixin (necset A). End necset_canonical. Section necset_lemmas. -Variable A : convType. +Context {R : realType}. +Variable A : convType R. Lemma necset_ext (a b : necset A) : a = b :> set _ -> a = b. Proof. @@ -887,33 +888,34 @@ congr NECSet.Pack; congr NECSet.Class; f_equal; exact/Prop_irrelevance. Qed. (*Canonical neset_hull_necset*) -HB.instance Definition _ (T : convType) (F : neset T) := - isConvexSet.Build _ _ (hull_is_convex F). -HB.instance Definition _ (T : convType) (F : neset T) := +HB.instance Definition _ (T : convType R) (F : neset T) := + isConvexSet.Build R _ _ (hull_is_convex F). +HB.instance Definition _ (T : convType R) (F : neset T) := isNESet.Build _ _ (neset_hull_neq0 F). (*Canonical necset1*) -HB.instance Definition _ (T : convType) (x : T) := - isConvexSet.Build _ _ (is_convex_set1 x). -HB.instance Definition _ (T : convType) (x : T) := +HB.instance Definition _ (T : convType R) (x : T) := + isConvexSet.Build R _ _ (is_convex_set1 x). +HB.instance Definition _ (T : convType R) (x : T) := isNESet.Build _ _ (set1_neq0 x). End necset_lemmas. -(*Definition necset_convType_conv {A : convType} p (X Y : necset A) := +Definition necset_convType_conv {R : realType} {A : convType R} p (X Y : necset A) := X :<|p|>: Y. -HB.instance Definition _ {A : convType} p (X Y : necset A) := +HB.instance Definition _ {R : realType} {A : convType R} p (X Y : necset A) := NESet.on (necset_convType_conv p X Y). -HB.instance Definition _ {A : convType} p (X Y : necset A) := - ConvexSet.on (necset_convType_conv p X Y).*) +HB.instance Definition _ {R : realType} {A : convType R} p (X Y : necset A) := + ConvexSet.on (necset_convType_conv p X Y). -HB.instance Definition _ {A : convType} (p : {prob R}) (X Y : necset A) := +HB.instance Definition _ {R : realType} {A : convType R} (p : {prob R}) (X Y : necset A) := isNESet.Build _ _ (conv_set_neq0 p X Y). Module necset_convType. Section def. -Variable A : convType. +Context {R : realType}. +Variable A : convType R. Definition conv p (X Y : necset A) : necset A := X :<|p|>: Y. @@ -941,7 +943,8 @@ End def. Section lemmas. Local Open Scope classical_set_scope. -Variable A : convType. +Context {R : realType}. +Variable A : convType R. (* This lemma is now trivial since we redefined conv directly by conv_set; now kept just for compatibility. *) @@ -951,22 +954,23 @@ Proof. by rewrite convE. Qed. End lemmas. End necset_convType. -HB.instance Definition necset_convType (A : convType) := - @isConvexSpace.Build (necset A) - (@necset_convType.conv A) - (@necset_convType.conv1 A) - (@necset_convType.convmm A) - (@necset_convType.convC A) - (@necset_convType.convA A). +HB.instance Definition necset_convType {R : realType} (A : convType R) := + @isConvexSpace.Build R (necset A) + (@necset_convType.conv R A) + (@necset_convType.conv1 R A) + (@necset_convType.convmm R A) + (@necset_convType.convC R A) + (@necset_convType.convA R A). -Definition Necset_to_convType (A : convType) := +Definition Necset_to_convType {R : realType} (A : convType R) := fun phT : phant (Choice.sort A) => necset A. Local Notation "{ 'necset' T }" := (Necset_to_convType (Phant T)). Module necset_semiCompSemiLattType. Section def. Local Open Scope classical_set_scope. -Variable (A : convType). +Context {R : realType}. +Variable (A : convType R). Definition pre_op (X : neset {necset A}) : {convex_set A} := hull (\bigcup_(i in X) idfun i)%:ne. @@ -1015,7 +1019,7 @@ Proof. by move=> x y z; rewrite !lub_E; apply necset_ext => /=; exact: hullUA. Qed. -Let lub_xx : idempotent lub_. +Let lub_xx : idempotent_op lub_. Proof. by move=> x; rewrite lub_E; apply necset_ext => /=; rewrite setUid hull_cset. Qed. @@ -1039,7 +1043,8 @@ HB.export necset_semiCompSemiLattType. Module necset_semiCompSemiLattConvType. Section def. -Variable A : convType. +Context {R : realType}. +Variable A : convType R. Let L := necset A. Let biglubDr' (p : {prob R}) (X : L) (I : neset L) : @@ -1067,17 +1072,17 @@ by apply/neset_ext => /=; rewrite image_setU !image_set1. Qed. #[export] -HB.instance Definition _ := @isSemiLattConv.Build (necset A) lubDr'. +HB.instance Definition _ := @isSemiLattConv.Build R (necset A) lubDr'. #[export] -HB.instance Definition _ := @isSemiCompSemiLattConv.Build (necset A) biglubDr'. +HB.instance Definition _ := @isSemiCompSemiLattConv.Build R (necset A) biglubDr'. End def. End necset_semiCompSemiLattConvType. HB.export necset_semiCompSemiLattConvType. -Definition Necset_to_semiCompSemiLattConvType (A : convType) := - fun phT : phant (Choice.sort A) => [the semiCompSemiLattConvType of necset A]. +Definition Necset_to_semiCompSemiLattConvType {R : realType} (A : convType R) := + fun phT : phant (Choice.sort A) => [the semiCompSemiLattConvType R of necset A]. Notation "{ 'necset' T }" := (Necset_to_semiCompSemiLattConvType (Phant T)) : convex_scope. @@ -1085,14 +1090,14 @@ Module necset_join. Section def. Local Open Scope classical_set_scope. Local Open Scope proba_scope. -Definition F (T : Type) := {necset {dist {classic T}}}. +Definition F (T : Type) := {necset (R.-dist {classic T})}. Variable T : Type. -Definition L := [the convType of F T]. +Definition L := [the convType R of F T]. Definition FFT := F (F T). -Definition F1join0' (X : FFT) : set L := (@Convn_of_fsdist L) @` X. +Definition F1join0' (X : FFT) : set L := (@Convn_of_fsdist R L) @` X. Lemma F1join0'_convex X : is_convex_set (F1join0' X). Proof. @@ -1105,17 +1110,17 @@ Lemma F1join0'_neq0 X : (F1join0' X) != set0. Proof. apply/set0P. case/set0P: (neset_neq0 X) => x Xx. -by exists (Convn_of_fsdist (x : {dist (F T)})), x. +by exists (Convn_of_fsdist (x : R.-dist (F T))), x. Qed. Definition L' := necset L. Definition F1join0 : FFT -> L' := fun X => NECSet.Pack (NECSet.Class - (isConvexSet.Build _ _ (F1join0'_convex X)) (isNESet.Build _ _ (F1join0'_neq0 X))). + (isConvexSet.Build R _ _ (F1join0'_convex X)) (isNESet.Build _ _ (F1join0'_neq0 X))). Definition join1' (X : L') - : {convex_set [the convType of {dist {classic T}}]} := - ConvexSet.Pack (ConvexSet.Class (isConvexSet.Build _ _ (hull_is_convex + : {convex_set [the convType R of R.-dist {classic T}]} := + ConvexSet.Pack (ConvexSet.Class (isConvexSet.Build R _ _ (hull_is_convex (\bigcup_(i in X) if i \in X then (i : set _) else set0)))). Lemma join1'_neq0 (X : L') : join1' X != set0 :> set _. @@ -1129,7 +1134,7 @@ by rewrite sy. Qed. Definition join1 : L' -> L := fun X => - NECSet.Pack (NECSet.Class (isConvexSet.Build _ _ (hull_is_convex _)) + NECSet.Pack (NECSet.Class (isConvexSet.Build R _ _ (hull_is_convex _)) (isNESet.Build _ _ (join1'_neq0 X))). Definition join : FFT -> L := join1 \o F1join0. End def. @@ -1170,7 +1175,7 @@ by exists (fsdistmap (f : {classic a} -> {classic b}) x), x. Qed. Definition necset_fmap : M a -> M b := fun ma => - NECSet.Pack (NECSet.Class (isConvexSet.Build _ _ (necset_fmap'_convex ma)) + NECSet.Pack (NECSet.Class (isConvexSet.Build R _ _ (necset_fmap'_convex ma)) (isNESet.Build _ _ (necset_fmap'_neq0 ma))). End fmap. @@ -1182,7 +1187,7 @@ End bind. End necset_bind. Section technical_corollaries. -Variable L : semiCompSemiLattConvType. +Variable L : semiCompSemiLattConvType R. Corollary Varacca_Winskel_Lemma_5_6 (Y Z : neset L) : hull Y = hull Z -> |_| Y = |_| Z. @@ -1198,7 +1203,7 @@ rewrite lubE -[in LHS]biglub_hull; congr (|_| _); apply neset_ext => /=. rewrite eqEsubset; split=> i /=. - have /set0P x0 := set1_neq0 x. have /set0P y0 := set1_neq0 y. - move/(@hull_setU _ _ (set1 x) (set1 y) x0 y0). + move/(@hull_setU R _ _ (set1 x) (set1 y) x0 y0). by move=> [a /asboolP ->] [b /asboolP ->] [p ->]; exists p. - by case=> p ? <-; exact/mem_hull_setU. Qed. diff --git a/probability/partition_inequality.v b/probability/partition_inequality.v index a6cb0a11..4dfdce83 100644 --- a/probability/partition_inequality.v +++ b/probability/partition_inequality.v @@ -1,10 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum. -Require Import Reals Lra. -From mathcomp Require Import Rstruct. -Require Import ssrR realType_ext Reals_ext Ranalysis_ext ssr_ext logb ln_facts. -Require Import bigop_ext fdist divergence log_sum variation_dist. +From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp Require Import Rstruct reals. +Require Import ssr_ext bigop_ext realType_ext realType_ln. +Require Import fdist divergence log_sum variation_dist. (******************************************************************************) (* Partition inequality *) @@ -21,23 +20,26 @@ Local Open Scope divergence_scope. Local Open Scope fdist_scope. Local Open Scope R_scope. -Import Num.Theory. +Local Open Scope ring_scope. +Local Open Scope fdist_scope. + +Import Order.POrderTheory GRing.Theory Num.Theory. Local Notation "0" := (false). Local Notation "1" := (true). Section bipart_sect. - +Context {R : realType}. Variable A : finType. Variable A_ : bool -> {set A}. Hypothesis dis : A_ 0 :&: A_ 1 = set0. Hypothesis cov : A_ 0 :|: A_ 1 = [set: A]. -Variable P : {fdist A}. +Variable P : R.-fdist A. Definition bipart_pmf := [ffun i => \sum_(a in A_ i) P a]. -Definition bipart : {fdist bool}. -apply (@FDist.make _ _ bipart_pmf). +Definition bipart : R.-fdist bool. +apply (@FDist.make R _ bipart_pmf). - by move=> a; rewrite ffunE; apply: sumr_ge0. - rewrite big_bool /= /bipart_pmf /= !ffunE. transitivity (\sum_(a | (a \in A_ 0 :|: A_ 1)) P a). @@ -50,16 +52,16 @@ End bipart_sect. Local Open Scope reals_ext_scope. Section bipart_lem. - +Context {R : realType}. Variable A : finType. Variable A_ : bool -> {set A}. Hypothesis dis : A_ 0 :&: A_ 1 = set0. Hypothesis cov : A_ 0 :|: A_ 1 = setT. -Variable P Q : {fdist A}. +Variable P Q : R.-fdist A. Hypothesis P_dom_by_Q : P `<< Q. -Let P_A := bipart dis cov P. -Let Q_A := bipart dis cov Q. +Let P_A : R.-fdist bool := bipart dis cov P. +Let Q_A : R.-fdist bool:= bipart dis cov Q. Lemma partition_inequality : D(P_A || Q_A) <= D(P || Q). Proof. @@ -71,68 +73,57 @@ have step2 : (\sum_(a in A_ 0) P a) * log ((\sum_(a in A_ 0) P a) / \sum_(a in A_ 0) Q a) + (\sum_(a in A_ 1) P a) * log ((\sum_(a in A_ 1) P a) / \sum_(a in A_ 1) Q a) <= \sum_(a in A_ 0) P a * log (P a / Q a) + \sum_(a in A_ 1) P a * log (P a / Q a). - apply: leR_add; by apply log_sum => //; move=> x; apply/RleP/FDist.ge0. -apply: (leR_trans _ step2) => {step2}. + by apply: lerD => //; exact: log_sum. +apply: (le_trans _ step2) => {step2}. rewrite [X in _ <= X](_ : _ = P_A 0 * log ((P_A 0) / (Q_A 0)) + P_A 1 * log ((P_A 1) / (Q_A 1))); last first. by rewrite !ffunE. rewrite /div big_bool. rewrite [P_A]lock [Q_A]lock /= -!lock. -have [A0_P_neq0 | /esym A0_P_0] : {0 < P_A 0} + {0%R = P_A 0}. - by apply Rle_lt_or_eq_dec; rewrite ffunE; exact/RleP/sumr_ge0. -- have [A1_Q_neq0 | /esym A1_Q_0] : {0 < Q_A 1} + {0%R = Q_A 1}. - by apply Rle_lt_or_eq_dec; rewrite ffunE; exact/RleP/sumr_ge0. - + have [A0_Q__neq0 | /esym A0_Q_0] : {0 < Q_A 0} + {0%R = Q_A 0}. - by apply Rle_lt_or_eq_dec; rewrite ffunE; exact/RleP/sumr_ge0. - * rewrite /Rdiv /log LogM //; last exact/invR_gt0. - rewrite LogV //. - have [A1_P_neq0 | /esym A1_P_0] : {0 < P_A 1} + {0%R = P_A 1}. - by apply Rle_lt_or_eq_dec; rewrite ffunE; exact/RleP/sumr_ge0. - - rewrite /log LogM //; last exact/invR_gt0. - rewrite LogV //. - apply Req_le; by field. - - rewrite A1_P_0 !mul0R addR0; exact/Req_le. +have := FDist.ge0 P_A 0. +rewrite le_eqVlt => /predU1P[/esym A0_P_0|A0_P_neq0]; last first. +- have := FDist.ge0 Q_A 1. + rewrite le_eqVlt => /predU1P[/esym A1_Q_0|A1_Q_neq0]; last first. + + have := FDist.ge0 Q_A 0. + rewrite le_eqVlt => /predU1P[/esym A0_Q_0|A0_Q__neq0]; last first. + * by rewrite logM// invr_gt0//. * rewrite ffunE in A0_Q_0; move/psumr_eq0P in A0_Q_0. have {}A0_Q_0 : forall i : A, i \in A_ 0 -> P i = 0%R. move=> i ?; rewrite (dominatesE P_dom_by_Q) // A0_Q_0 // => a ?; exact/pos_ff_ge0. have Habs : P_A 0 = 0%R. - transitivity (\sum_(H|H \in A_ 0) 0%R). + transitivity (\sum_(H|H \in A_ 0) (0:R))%R. rewrite ffunE. apply eq_big => // i Hi; by rewrite -A0_Q_0. - by rewrite big_const iter_addR mulR0. - by move: A0_P_neq0; rewrite Habs; move/ltRR. + by rewrite big1. + by move: A0_P_neq0; rewrite Habs ltxx. + have H2 : P_A 1 = 0%R. rewrite ffunE in A1_Q_0; move/psumr_eq0P in A1_Q_0. rewrite /bipart /= ffunE /bipart_pmf (eq_bigr (fun=> 0%R)). - by rewrite big_const iter_addR mulR0. - move=> a ?; rewrite (dominatesE P_dom_by_Q) // A1_Q_0 // => b ?; exact/pos_ff_ge0. - rewrite H2 !mul0R !addR0. + by rewrite big1. + by move=> a ?; rewrite (dominatesE P_dom_by_Q) // A1_Q_0 // => b ?; exact/pos_ff_ge0. + rewrite H2 !mul0r !addr0. have H3 : Q_A 0 = 1%R. - rewrite -[X in X = _]addR0 -[X in _ + X = _]A1_Q_0 R1E -(FDist.f1 Q). + rewrite -[X in X = _]addr0 -[X in _ + X = _]A1_Q_0 -(FDist.f1 Q). rewrite !ffunE -big_union //. apply eq_bigl => i; by rewrite cov in_set inE. by rewrite -setI_eq0 -dis setIC. - rewrite H3 /Rdiv /log LogM //; last lra. - by rewrite LogV; [apply Req_le; field | lra]. + by rewrite H3 logM// invr1. - have H1 : P_A 1 = 1%R. - rewrite -[X in X = _]add0R -[X in X + _ = _]A0_P_0 R1E -(FDist.f1 P). + rewrite -[X in X = _]add0r -[X in X + _ = _]A0_P_0 -(FDist.f1 P). rewrite !ffunE -big_union //. apply eq_bigl => i; by rewrite cov in_set inE. by rewrite -setI_eq0 -dis setIC. - have [A1_Q_neq0 | /esym A1_Q_0] : {0 < Q_A 1} + {0%R = Q_A 1}. - by apply Rle_lt_or_eq_dec; rewrite ffunE; exact/RleP/sumr_ge0. - + rewrite A0_P_0 !mul0R !add0R H1 !mul1R. - rewrite /Rdiv /log LogM; last 2 first. - lra. - exact/invR_gt0. - rewrite /log LogV //; apply Req_le; by field. + have := FDist.ge0 Q_A 1. + rewrite le_eqVlt => /predU1P[/esym A1_Q_0|A1_Q_neq0]; last first. + + rewrite A0_P_0 !mul0r !add0r H1 !mul1r. + by rewrite ler_log// ?posrE// invr_gt0. + (* contradiction H1 / Bi_true_Q_0 *) rewrite ffunE in A1_Q_0; move/psumr_eq0P in A1_Q_0. have : P_A 1 = 0%R. rewrite !ffunE /bipart /= /bipart_pmf (eq_bigr (fun=> 0%R)). - by rewrite big_const iter_addR mulR0. - move=> a ?; rewrite (dominatesE P_dom_by_Q) // A1_Q_0 // => b ?; exact/pos_ff_ge0. - by move=> abs; rewrite abs in H1; lra. + by rewrite big1. + by move=> a ?; rewrite (dominatesE P_dom_by_Q) // A1_Q_0 // => b ?; exact/pos_ff_ge0. + by rewrite A0_P_0. Qed. End bipart_lem. diff --git a/probability/pinsker.v b/probability/pinsker.v index fb0885ba..51ab7df6 100644 --- a/probability/pinsker.v +++ b/probability/pinsker.v @@ -1,11 +1,12 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum. -Require Import Reals Lra. -From mathcomp Require Import mathcomp_extra Rstruct reals. -Require Import ssrR Reals_ext realType_ext Ranalysis_ext ssr_ext. -Require Import logb ln_facts bigop_ext convex fdist divergence. -Require Import variation_dist partition_inequality. +From mathcomp Require Import all_ssreflect ssralg ssrnum interval ring lra. +From mathcomp Require Import mathcomp_extra classical_sets functions. +From mathcomp Require Import set_interval reals Rstruct topology normedtype. +From mathcomp Require Import sequences derive exp realfun. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln. +Require Import derive_ext. +Require Import fdist divergence variation_dist partition_inequality. (******************************************************************************) (* Pinsker's Inequality *) @@ -20,316 +21,310 @@ Unset Strict Implicit. Import Prenex Implicits. Import Order.TTheory GRing.Theory Num.Theory. +Import numFieldTopology.Exports. +Import numFieldNormedType.Exports. -Local Open Scope R_scope. +Local Open Scope ring_scope. Local Open Scope fdist_scope. -Definition pinsker_fun p c := fun q => - p * log (div_fct (fun _ => p) id q) + - (1 - p) * log (div_fct (fun _ => 1 - p) (fun q => 1 - q) q) - - 4 * c * comp (fun x => x ^2) (fun q => p - q) q. +Section pinsker_fun_def. +Variable R : realType. -Lemma derive_pinsker_fun (p : R) c : 0 < p < 1 -> - pderivable (pinsker_fun p c) (fun q => 0 < q < 1). +Definition pinsker_fun (p c q : R) := + p * log (p / q) + + (1 - p) * log ((1 - p) / (1 - q)) - + 4 * c * (p - q) ^+ 2. + +Definition pinsker_fun' (p c : R) := fun q => + (q - p) * ((q * (1 - q) * ln 2)^-1 - 8 * c). + +Definition pinsker_function_spec (c q : R) := + - log (1 - q) - 4 * c * q ^+ 2. + +Definition pinsker_function_spec' (c q : R) := + ((1 - q) * ln 2)^-1 - 8 * c * q. + +Lemma pinsker_fun_p0 c q : q < 1 -> pinsker_fun 0 c q = pinsker_function_spec c q. Proof. -move=> [H0p Hp1] q /= [Hq1 Hq2]. -rewrite /pinsker_fun. -apply: derivable_pt_minus. - apply derivable_pt_plus. - apply derivable_pt_mult. - exact: derivable_pt_const. - apply derivable_pt_comp. - apply derivable_pt_mult. - apply derivable_pt_const. - apply derivable_pt_inv. - exact/eqP/gtR_eqF. - apply derivable_pt_id. - apply derivable_pt_Log. - exact: divR_gt0. - apply derivable_pt_mult. - exact: derivable_pt_const. - apply derivable_pt_comp. - apply derivable_pt_div. - apply derivable_pt_const. - apply derivable_pt_Rminus. - move=> abs; lra. - apply derivable_pt_Log. - by apply divR_gt0 => //; lra. -apply derivable_pt_mult. - exact: derivable_pt_const. -by apply: derivable_pt_comp; [exact: derivable_pt_Rminus|exact: derivable_pt_pow]. -Defined. - -Definition pinsker_fun' p c := fun q => - (q - p) * (inv_fct (fun q => (q * (1 - q) * ln 2)) q - 8 * c). - -Lemma derive_pt_pinsker_fun p (Hp : 0 < p < 1) c q (Hq : 0 < q < 1) - (pr : derivable_pt (pinsker_fun p c) q) : - derive_pt (pinsker_fun p c) q pr = pinsker_fun' p c q. +move=> q1. +rewrite /pinsker_fun /pinsker_function_spec /=. +rewrite mul0r subr0 !add0r mul1r sqrrN. +by rewrite logDiv// ?subr_gt0// log1 add0r. +Qed. + +Lemma pinsker_fun_onem p c q : pinsker_fun (1 - p) c (1 - q) = pinsker_fun p c q. +Proof. +rewrite /pinsker_fun [X in X + _ = _]addrC. +congr (_ + _ - _). + by rewrite !opprD !opprK !addrA !subrr !add0r. +by rewrite -sqrrN !opprD !opprK addrCA !addrA subrr add0r. +Qed. + +Lemma pinsker_fun_p p c : pinsker_fun p c p = 0. Proof. -transitivity (derive_pt (pinsker_fun p c) q (@derive_pinsker_fun _ c Hp q Hq)). - by apply proof_derive_irrelevance. -rewrite /pinsker_fun /derive_pinsker_fun. -case: Hp => Hp1 Hp2. -case: Hq => Hq1 Hq2. -rewrite !(derive_pt_minus,derive_pt_plus,derive_pt_comp,derive_pt_ln, - derive_pt_const,derive_pt_mult,derive_pt_inv,derive_pt_id,derive_pt_div, - derive_pt_pow). -rewrite !(mul0R,mulR0,addR0,add0R,Rminus_0_l) /= (_ : INR 2 = 2) //. -rewrite /pinsker_fun' /div_fct [X in _ = X]mulRBr. -f_equal; last by field. -rewrite (_ : id q = q)// 2!Rinv_div. -have -> : p * (/ ln 2 * (q / p) * (p * (-1 / q²))) = - (p / q) * / ln 2. - rewrite !mulRA /Rsqr. - field. - split; [exact/eqP/ln2_neq0 | split => ?; lra]. -have -> : (1 - p) * (/ ln 2 * ((1 - q) / (1 - p)) * (- (-1 * (1 - p)) / (1 - q)²)) = - (((1 - p) / (1 - q))) * / ln 2. - rewrite /Rsqr. - field. - split; [exact/eqP/ln2_neq0 | split => ?; lra]. -rewrite /inv_fct. -field. -by split; [exact/eqP/ln2_neq0 | split => ?; lra]. +rewrite /pinsker_fun subrr expr0n /= mulr0 subr0. +have [->|p0] := eqVneq p 0. + by rewrite mul0r !subr0 add0r mul1r div1r invr1 log1. +have [->|p1] := eqVneq p 1. + by rewrite divr1 log1 subrr mul0r mulr0 addr0. +rewrite divff // divff ?subr_eq0 1?eq_sym//. +by rewrite log1 !mulr0 addr0. Qed. -Definition pinsker_function_spec c q := - log (1 - q) - 4 * c * q ^ 2. +End pinsker_fun_def. -Definition pinsker_function_spec' c q0 := - / ((1 - q0) * ln 2) - 8 * c * q0. +Section pinsker_function_analysis. +Variable R : realType. -Lemma pderivable_pinsker_function_spec c : - pderivable (pinsker_function_spec c) (fun q => 0 <= q < 1). +Lemma derivable_pinsker_fun (p c v : R) : 0 < p < 1 -> + {in [pred q | 0 < q < 1], forall q, derivable (pinsker_fun p c) q v}. Proof. -move=> q0 Hq0. -rewrite /pinsker_function_spec. -apply derivable_pt_minus. - apply derivable_pt_opp. - apply derivable_pt_comp. - apply derivable_pt_Rminus. - apply derivable_pt_Log. - rewrite /= in Hq0. - decompose [and] Hq0; clear Hq0; lra. -by apply: derivable_pt_mult; [exact: derivable_pt_const|exact: derivable_pt_pow]. -Defined. - -Lemma derive_pt_pinsker_function_spec c q0 (Hq0 : 0 <= q0 < 1) - (pr : derivable_pt (pinsker_function_spec c) q0) : - derive_pt (pinsker_function_spec c) q0 pr = pinsker_function_spec' c q0. +move=> /andP [H0p Hp1] /= q /[!inE] /andP [Hq1 Hq2]. +apply: diff_derivable. +rewrite /pinsker_fun. +apply: differentiableB; last by []. +apply: differentiableD. + apply: differentiableM; first by []. + apply: differentiable_comp. + apply: differentiableM; first by []. + by apply: differentiableV; rewrite // gt_eqF. + apply: differentiable_Log=> //. + exact: divr_gt0. +apply: differentiableM; first by []. +apply: differentiable_comp. + apply: differentiableM=> //. + apply: differentiableV=> //. + lra. +apply: differentiable_Log=> //. +by apply: divr_gt0; lra. +Qed. + +Lemma is_derive1_pinsker_fun + (p : R) (Hp : 0 < p < 1) (c q : R) (Hq : 0 < q < 1) : + is_derive q 1 (pinsker_fun p c) (pinsker_fun' p c q). +Proof. +case/andP: Hp => Hp1 Hp2. +case/andP: Hq => Hq1 Hq2. +rewrite /pinsker_fun /pinsker_fun'. +under [F in is_derive _ _ F]boolp.funext=> x. + rewrite -sqrrN opprB. + rewrite (_ : (x - p) ^+ 2 = ((fun x => x - p) ^+ 2) x); last by []. + over. +rewrite mulrBr; apply: is_deriveB=> /=; last first. + apply: is_deriveZ_eq. + rewrite expr1 -!mulr_regl. + ring. +rewrite (_ : q - p = p * (- (1 - q)) + (1 - p) * q ); last by ring. +rewrite mulrDl; apply: is_deriveD=> /=. + rewrite -!mulrA; apply: is_deriveZ=> /=. + apply: is_derive1_LogfM_eq=> //. + - by apply: is_deriveV; rewrite gt_eqF. + - by rewrite invr_gt0. + - rewrite mulr_algl -mulr_regl; field. + by rewrite ln2_neq0 /= subr_eq0 gt_eqF//= !gt_eqF. +rewrite -!mulrA; apply: is_deriveZ=> /=. +rewrite invfM mulrA mulfV ?gt_eqF//. +apply: is_derive1_LogfM_eq=> //=. +- by apply: is_deriveV; rewrite subr_eq0 gt_eqF. +- by rewrite subr_gt0. +- by rewrite invr_gt0 subr_gt0. + rewrite -mulr_regl; field. + by rewrite ln2_neq0 /= !subr_eq0 !gt_eqF. +Qed. + +Lemma derive1_pinsker_fun (p : R) (Hp : 0 < p < 1) c q (Hq : 0 < q < 1) : + 'D_1 (pinsker_fun p c) q = pinsker_fun' p c q. +Proof. by have/@derive_val:= is_derive1_pinsker_fun Hp c Hq. Qed. + +Lemma derivable_pinsker_function_spec (c v : R) : + {in [pred q | 0 <= q < 1], + forall q, derivable (pinsker_function_spec c) q v}. Proof. -rewrite (proof_derive_irrelevance _ (pderivable_pinsker_function_spec c Hq0)) //. +move=> q /[!inE] /andP [q0 q1]. +apply: diff_derivable. rewrite /pinsker_function_spec. -rewrite derive_pt_minus. -rewrite derive_pt_opp. -rewrite derive_pt_comp. -rewrite derive_pt_Log. -rewrite derive_pt_mult. -rewrite derive_pt_pow. -rewrite derive_pt_const. -rewrite mul0R add0R /= /pinsker_function_spec' (_ : INR 2 = 2) //. -field. -split; [exact/eqP/ln2_neq0|case: Hq0 => ? ? ?; lra]. -Defined. - -Lemma pinsker_fun_increasing_on_0_to_1 (c : R) (Hc : c <= / (2 * ln 2)) : - forall x y, - 0 <= x < 1 -> 0 <= y < 1 -> x <= y -> - pinsker_function_spec c x <= pinsker_function_spec c y. +apply: differentiableB; last by []. +apply/differentiableN/differentiable_comp; first by []. +apply: differentiable_Log=> //. +by rewrite subr_gt0. +Qed. + +Lemma is_derive1_pinsker_function_spec (c q : R) (Hq : 0 <= q < 1) : + is_derive q 1 (pinsker_function_spec c) (pinsker_function_spec' c q). Proof. -apply pderive_increasing_closed_open with (pderivable_pinsker_function_spec c). -lra. -move=> t Ht. -rewrite derive_pt_pinsker_function_spec // /pinsker_function_spec'. -apply (@leR_trans (/ ((1 - t) * ln 2) - 8 * t / (2 * ln 2))); last first. - apply leR_add2l. - rewrite leR_oppr oppRK -mulRA /Rdiv -[X in _ <= X]mulRA -/(Rdiv _ _). - apply leR_wpmul2l; first lra. - rewrite mulRC; apply leR_wpmul2l => //. - by case: Ht. -apply (@leR_trans ((2 - 8 * t * (1 - t)) / (2 * (1 - t) * ln 2))); last first. - apply Req_le. - field. - split; [exact/eqP/ln2_neq0 | case: Ht => ? ? ?; lra]. -apply divR_ge0; last first. - rewrite mulRC mulRA. - apply mulR_gt0. - apply mulR_gt0 => //; lra. - case: Ht => ? ?; lra. -have H2 : -2 <= - 8 * t * (1 - t). - rewrite !mulNR -mulRA. - rewrite leR_oppr oppRK [X in _ <= X](_ : 2 = 8 * / 4); last by field. - apply leR_wpmul2l; [lra | exact: x_x2_max]. -move: H2 => /RleP; rewrite -mulRA RmultE mulNr lerNl opprK. -by move=> /RleP; rewrite -!RmultE mulRA subR_ge0. +move: Hq=> /andP [q0 q1]. +apply: is_deriveB. + apply: is_deriveN_eq; first by apply: is_derive1_Logf=> //; rewrite subr_gt0. + by simpl; field; rewrite ln2_neq0 subr_eq0 gt_eqF. +have->: 8 * c = 4 * c * 2 by ring. +apply: is_deriveZ_eq. +by rewrite -!mulr_regr; ring. Qed. -Lemma pinsker_function_spec_pos c q : - 0 <= c <= / (2 * ln 2) -> - 0 <= q < 1 -> - 0 <= pinsker_function_spec c q. +Lemma derive1_pinsker_function_spec (c : R) q (Hq : 0 <= q < 1) : + 'D_1 (pinsker_function_spec c) q = pinsker_function_spec' c q. +Proof. by have/@derive_val:= is_derive1_pinsker_function_spec c Hq. Qed. + +Lemma pinsker_fun_p0_increasing_on_0_to_1 (c : R) (Hc : c <= (2 * ln 2)^-1) : + forall (x y : R), + x \in `[0, 1[ -> y \in `[0, 1[ -> x <= y -> + pinsker_fun 0 c x <= pinsker_fun 0 c y. Proof. -move=> Hc [q0 q1]. -rewrite (_ : 0 = pinsker_function_spec c 0); last first. - by rewrite /pinsker_function_spec /= subR0 /log Log_1; field. -apply pinsker_fun_increasing_on_0_to_1 => //. -by case: Hc. +move=> x y x01 y01. +have x1: x < 1 by have:= x01; rewrite in_itv /=; lra. +have y1: y < 1 by have:= y01; rewrite in_itv /=; lra. +rewrite !pinsker_fun_p0//. +apply: (derivable1_homo x01 y01). + exact: derivable_pinsker_function_spec. +move=> q xqy. +move: x01 y01 xqy; rewrite !in_itv /==> x01 y01 xqy. +rewrite derive1_pinsker_function_spec; last lra. +rewrite /pinsker_function_spec'. +rewrite subr_ge0 mulrAC. +rewrite -ler_pdivlMl ?mulr_gt0//; last lra. +rewrite (le_trans Hc)//. +rewrite !invfM mulrA ler_pM2r ?invr_gt0 ?ln2_gt0//. +rewrite (_ : 8^-1 = 2^-1 * 4^-1); last by field. +rewrite -[leLHS]mulr1 -!mulrA ler_pM2l; last lra. +rewrite -ler_pdivrMr -!invfM; last by rewrite invr_gt0 mulr_gt0; lra. +by rewrite invrK mul1r x_x2_max. Qed. -Section pinsker_function_analysis. -Variables p q : {prob R}. +Lemma pinsker_fun_p0_pos (c q : R) : + 0 <= c <= (2 * ln 2)^-1 -> + q \in `[0, 1[ -> + 0 <= pinsker_fun 0 c q. +Proof. +move=> ? /[dup] q01 /[!in_itv] /= q01'. +rewrite [leLHS](_ : _ = pinsker_fun 0 c 0); last first. + by rewrite pinsker_fun_p0 // /pinsker_function_spec /= subr0 log1; field. +apply pinsker_fun_p0_increasing_on_0_to_1=> //; [lra | | lra]. +by rewrite in_itv /= lexx /=. +Qed. -Lemma pinsker_fun_p c : pinsker_fun (Prob.p p) c (Prob.p p) = 0. +Let derivableN_pinsker_fun (p c : R) v (Hp' : 0 < p < 1) : + {in [pred q | 0 < q <= p], + forall q, derivable (fun x => - pinsker_fun p c x) q v}. Proof. -rewrite /pinsker_fun /= /div_fct /comp subRR mul0R mulR0 subR0. -have [->|p0] := eqVneq p 0%:pr. - by rewrite mul0R !subR0 add0R mul1R div1R invR1 /log Log_1. -have [->|p1] := eqVneq p 1%:pr. - by rewrite divR1 /log Log_1 subRR mul0R mulR0 addR0. -rewrite divRR; last by rewrite subR_eq0' eq_sym. -by rewrite /log Log_1 divRR // /log Log_1; field. +move=> x /[!inE] ?. +apply/derivableN/derivable_pinsker_fun=> //. +by rewrite inE; lra. Qed. -Lemma pinsker_fun_pderivable1 c (Hp' : 0 < Prob.p p < 1) : - pderivable (fun x => - pinsker_fun (Prob.p p) c x) (fun q => 0 < q <= Prob.p p). -move=> x [Hx1 Hx2]. -apply derivable_pt_opp. -apply: (@derive_pinsker_fun _ c Hp'). -case: Hp' => Hp'1 Hp'2. -split => //. +Lemma pinsker_fun'_ge0 (p c q : R) : + c <= (2 * ln 2)^-1 -> 0 < q < 1 -> p <= q -> 0 <= pinsker_fun' p c q. +Proof. +move=> Hc q01 pq. +rewrite /pinsker_fun' mulr_ge0 ?(subr_ge0 p)//. +rewrite (@le_trans _ _ (4 / ln 2 - 8 * c)) //. + rewrite subr_ge0 -ler_pdivlMl//. + by rewrite [leRHS](_ : _ = (2 * ln 2)^-1); last by lra. +rewrite lerB// invfM ler_pM// ?invr_ge0 ?ln2_ge0//. +rewrite -[leLHS]invrK lef_pV2 ?x_x2_max// posrE ?x_x2_pos//. lra. -Defined. +Qed. -Lemma pinsker_fun_decreasing_on_0_to_p (c : R) (Hc : c <= / (2 * ln 2)) - (p01 : 0 < Prob.p p < 1) : - forall x y, 0 < x <= Prob.p p -> 0 < y <= Prob.p p -> x <= y -> - pinsker_fun (Prob.p p) c y <= pinsker_fun (Prob.p p) c x. +Lemma pinsker_fun'_le0 (p c q : R) : + c <= (2 * ln 2)^-1 -> 0 < q < 1 -> q <= p -> pinsker_fun' p c q <= 0. Proof. -move=> x y Hx Hy xy. -rewrite -[X in _ <= X]oppRK leR_oppr. -move: x y Hx Hy xy. -apply pderive_increasing_open_closed with (pinsker_fun_pderivable1 c p01). - by case: p01. -move=> t [t0 tp]. -rewrite /pinsker_fun_pderivable1. -rewrite derive_pt_opp. -rewrite derive_pt_pinsker_fun //; last lra. -rewrite /pinsker_fun' /div_fct. -have Hlocal : 0 <= / ln 2 by exact/invR_ge0. -have X : 0 <= (/ (t * (1 - t) * ln 2) - 8 * c). - rewrite subR_ge0; apply (@leR_trans (4 / ln 2)). - apply (@leR_trans (8 * / (2 * ln 2))). - apply leR_wpmul2l => //; lra. - rewrite invRM; last 2 first. - by apply/eqP. - exact/ln2_neq0. - rewrite mulRA; apply leR_wpmul2r => //; lra. - rewrite invRM; last 2 first. - by apply/gtR_eqF/mulR_gt0; lra. - exact/ln2_neq0. - apply leR_wpmul2r => //. - rewrite -(invRK 4). - apply leR_inv => //. - by apply/mulR_gt0 => //; lra. - exact: x_x2_max. -by rewrite /inv_fct -mulNR; apply mulR_ge0 => //; lra. +move=> Hc q01 qp. +rewrite /pinsker_fun' -opprB mulNr -oppr_ge0 opprK. +rewrite mulr_ge0 ?(subr_ge0 q)//. +rewrite (@le_trans _ _ (4 / ln 2 - 8 * c)) //. + rewrite subr_ge0 -ler_pdivlMl//. + by rewrite [leRHS](_ : _ = (2 * ln 2)^-1); last by lra. +rewrite lerB// invfM ler_pM// ?invr_ge0 ?ln2_ge0//. +rewrite -[leLHS]invrK lef_pV2 ?x_x2_max// posrE ?x_x2_pos//. +lra. Qed. -Lemma pinsker_fun_pderivable2 c (Hp' : 0 < Prob.p p < 1) : - pderivable (fun x : R => pinsker_fun (Prob.p p) c x) (fun q : R => Prob.p p <= q < 1). -move=> x [Hx1 Hx2]. -apply: (@derive_pinsker_fun _ c Hp'). -split => //. -case: Hp' => Hp'1 Hp'2. -lra. -Defined. +Lemma pinsker_fun_decreasing_on_0_to_p (p c : R) (Hc : c <= (2 * ln 2)^-1) + (p01 : 0 < p < 1) (x y : R) : + x \in `]0, p] -> y \in `]0, p] -> x <= y -> + pinsker_fun p c y <= pinsker_fun p c x. +Proof. +move=> /[dup] x0p /[1!in_itv] /= x0p' /[dup] y0p /[!in_itv] /= y0p' xy. +rewrite -lerN2. +set f := (fun x => -pinsker_fun p c x). +apply (derivable1_homo x0p y0p (derivableN_pinsker_fun p01))=> //. +move=> t /[dup] xty /[!in_itv] /= xty'; have: 0 < t < 1 by lra. +rewrite deriveN; last first. + apply: derivable_pinsker_fun=> //. + by rewrite inE; lra. +move /(is_derive1_pinsker_fun p01 c) /@derive_val ->. +by rewrite oppr_ge0 pinsker_fun'_le0; lra. +Qed. -Lemma pinsker_fun_increasing_on_p_to_1 (c : R) (Hc : c <= / (2 * ln 2)) - (p01 : 0 < Prob.p p < 1) : - forall x y, Prob.p p <= x < 1 -> Prob.p p <= y < 1 -> x <= y -> - pinsker_fun (Prob.p p) c x <= pinsker_fun (Prob.p p) c y. +Lemma pinsker_fun_increasing_on_p_to_1 (p c : R) (Hc : c <= (2 * ln 2)^-1) + (p01 : 0 < p < 1) : + forall x y, x \in `[p, 1[ -> y \in `[p, 1[ -> x <= y -> + pinsker_fun p c x <= pinsker_fun p c y. Proof. -apply pderive_increasing_closed_open with (pinsker_fun_pderivable2 c p01). - by case: p01. -move=> t [pt t1]. -rewrite /pinsker_fun_pderivable2. -rewrite derive_pt_pinsker_fun //; last lra. -rewrite /pinsker_fun' /div_fct. -have X : 0 <= (/ (t * (1 - t) * ln 2) - 8 * c). - have : forall a b, b <= a -> 0 <= a - b by move=> *; lra. - apply. - have Hlocal : 0 <= / ln 2 by exact/invR_ge0. - have /eqP Hlocal2 : t * (1 - t) <> 0 by apply/eqP/gtR_eqF/mulR_gt0; lra. - apply (@leR_trans (4 / ln 2)). - apply (@leR_trans (8 * / (2 * ln 2))). - apply/RleP. - rewrite 2!RmultE ler_pM2l//; last first. - by apply/RltP; rewrite (_ : 0%mcR = 0)//; lra. - exact/RleP. - rewrite invRM ?mulRA; last 2 first. - exact/eqP. - exact/ln2_neq0. - by apply leR_wpmul2r => //; lra. - rewrite invRM //; last exact/ln2_neq0. - apply leR_wpmul2r => //. - rewrite -(invRK 4) //=. - apply leR_inv => //. - by apply/mulR_gt0; lra. - exact: x_x2_max. -rewrite /inv_fct; apply mulR_ge0 => //; lra. +move=> x y. +move=> /[dup] /[1!in_itv] /= ?; rewrite (_ : x = 1 - (1 - x)); [move=>? | ring]. +move=> /[dup] /[1!in_itv] /= ?; rewrite (_ : y = 1 - (1 - y)); [move=>? | ring]. +rewrite (_ : p = 1 - (1 - p)); last ring. +move=> ?. +set x' := 1 - x; set y' := 1 - y; set p' := 1 - p. +rewrite [leLHS]pinsker_fun_onem [leRHS]pinsker_fun_onem. +apply: (pinsker_fun_decreasing_on_0_to_p Hc); rewrite /x' /y' /p' ?in_itv /=; lra. Qed. End pinsker_function_analysis. + Local Open Scope reals_ext_scope. Section pinsker_fun_pos. +Variable R : realType. Variables p q : {prob R}. Variable A : finType. Hypothesis card_A : #|A| = 2%nat. Hypothesis P_dom_by_Q : fdist_binary card_A p (Set2.a card_A) `<< fdist_binary card_A q (Set2.a card_A). -Lemma pinsker_fun_pos c : 0 <= c <= / (2 * ln 2) -> 0 <= pinsker_fun (Prob.p p) c (Prob.p q). +Lemma pinsker_fun_pos (c : R) : 0 <= c <= (2 * ln 2)^-1 -> 0 <= pinsker_fun p c q. Proof. move=> Hc. set a := Set2.a card_A. set b := Set2.b card_A. have [p0|p0] := eqVneq p 0%:pr. subst p. - rewrite /pinsker_fun /div_fct /comp. - rewrite !(mul0R,mulR0,addR0,add0R,Rminus_0_l,subR0). + rewrite /pinsker_fun. + rewrite !(mul0r,mulr0,addr0,add0r,sub0r,subr0). have [q1|q1] := eqVneq q 1%:pr. subst q. exfalso. move/dominatesP : P_dom_by_Q => /(_ a). - by rewrite !fdist_binaryE !/onem subrr eqxx subr0 -R1E -R0E; lra. - apply: leR_trans. - apply: (@pinsker_function_spec_pos _ (Prob.p q) Hc); split=> //. - by apply/RltP; rewrite -prob_lt1. - rewrite /pinsker_function_spec. - apply: Req_le. - by rewrite mul1R div1R /log LogV; [field| - rewrite subR_gt0; apply /RltP; rewrite -prob_lt1]. + by rewrite !fdist_binaryE !/onem subrr eqxx subr0; lra. + apply: le_trans. + apply: (@pinsker_fun_p0_pos _ _ q Hc). + rewrite in_itv /=; apply/andP; split=> //. + by rewrite -prob_lt1. + rewrite pinsker_fun_p0 /pinsker_function_spec -?prob_lt1//. + rewrite le_eqVlt; apply/orP; left; apply/eqP. + by rewrite mul1r div1r logV; [field | rewrite subr_gt0 -prob_lt1]. have [p1|p1] := eqVneq p 1%:pr. subst p. - rewrite /pinsker_fun /div_fct /comp subRR mul0R addR0. + rewrite /pinsker_fun subrr mul0r addr0. have [q0|q0] := eqVneq q 0%:pr. subst q. exfalso. move/dominatesP : P_dom_by_Q => /(_ b). rewrite !fdist_binaryE /onem subrr eq_sym (negbTE (Set2.a_neq_b card_A)) /=. by move=> /(_ erefl)/eqP; rewrite oner_eq0. - apply: leR_trans. - have : 0 <= 1 - Prob.p q < 1. - split; first by rewrite subR_ge0. - by rewrite ltR_subl_addr -{1}(addR0 1) ltR_add2l; apply/RltP/ prob_gt0. - exact: pinsker_function_spec_pos Hc. - rewrite /pinsker_function_spec. - apply Req_le. - rewrite mul1R div1R /log LogV; [|by apply/RltP/prob_gt0]. - rewrite /id (_ : 1 - (1 - Prob.p q) = Prob.p q) //; by field. + apply: le_trans. + have : 0 <= 1 - q < 1. + apply/andP; split; first by rewrite subr_ge0. + by rewrite ltrBlDr -{1}(addr0 1) ltrD2l; apply/prob_gt0. + exact: pinsker_fun_p0_pos Hc. + rewrite pinsker_fun_p0 /pinsker_function_spec; last first. + by rewrite -[ltRHS]subr0 ltrD2l ltrN2 -prob_gt0. + rewrite le_eqVlt; apply/orP; left; apply/eqP. + rewrite mul1r div1r logV; [|by apply/prob_gt0]. + by rewrite (_ : 1 - (1 - q) = q :> R) //=; by field. have [q0|q0] := eqVneq q 0%:pr. subst q. - rewrite /pinsker_fun /div_fct /comp. + rewrite /pinsker_fun. exfalso. move/dominatesP : P_dom_by_Q => /(_ b). rewrite !fdist_binaryE eq_sym (negbTE (Set2.a_neq_b card_A)) => /(_ erefl) p0_. @@ -338,22 +333,20 @@ have [q1|q1] := eqVneq q 1%:pr. subst q. exfalso. move/dominatesP : P_dom_by_Q => /(_ a). - rewrite !fdist_binaryE /onem subrr eqxx subR_eq0 => /(_ erefl) p1_. + rewrite !fdist_binaryE /onem subrr eqxx=> /(_ erefl) /eqP /[!subr_eq0] /eqP p1_. by move/eqP : p1; apply; apply/val_inj; rewrite /= -p1_. rewrite -(pinsker_fun_p p c). -case: (Rlt_le_dec (Prob.p q) (Prob.p p)) => qp. +have/orP[qp|qp]:= le_total q p. apply pinsker_fun_decreasing_on_0_to_p => //. - lra. - - by split; apply/RltP; [rewrite -prob_gt0 | rewrite -prob_lt1]. - - by split; [apply/RltP/prob_gt0 | exact/ltRW]. - - split; [by apply/RltP/prob_gt0 | ]. - by apply/RleP; rewrite lexx. - - exact/ltRW. + - by apply/andP; split; [rewrite -prob_gt0 | rewrite -prob_lt1]. + - by apply/andP; split; [apply/prob_gt0 | ]. + - by apply/andP; split; [exact/prob_gt0 | exact/lexx]. apply pinsker_fun_increasing_on_p_to_1 => //. - lra. -- by split; apply/RltP; [rewrite -prob_gt0 |rewrite -prob_lt1]. -- by split; [by apply/RleP; rewrite lexx |apply/RltP/prob_lt1]. -- by split => //; apply/RltP; rewrite -prob_lt1. +- by apply/andP; split; [rewrite -prob_gt0 |rewrite -prob_lt1]. +- by apply/andP; split; [by rewrite lexx |apply/prob_lt1]. +- by apply/andP; split => //; rewrite -prob_lt1. Qed. End pinsker_fun_pos. @@ -362,6 +355,7 @@ Local Open Scope divergence_scope. Local Open Scope variation_distance_scope. Section Pinsker_2_bdist. +Variable R : realType. Variables p q : {prob R}. Variable A : finType. Hypothesis card_A : #|A| = 2%nat. @@ -371,78 +365,61 @@ Let Q := fdist_binary card_A q (Set2.a card_A). Hypothesis P_dom_by_Q : P `<< Q. -Lemma pinsker_fun_p_eq c : pinsker_fun (Prob.p p) c (Prob.p q) = D(P || Q) - c * d(P , Q) ^ 2. +Lemma pinsker_fun_p_eq c : pinsker_fun p c q = D(P || Q) - c * d(P , Q) ^+ 2. Proof. pose a := Set2.a card_A. pose b := Set2.b card_A. set pi := P a. set pj := P b. set qi := Q a. set qj := Q b. -have Hpi : pi = 1 - Prob.p p by rewrite /pi /P fdist_binaryxx. -have Hqi : qi = 1 - Prob.p q by rewrite /qi /= fdist_binaryxx. -have Hpj : pj = Prob.p p. +have Hpi : pi = 1 - p by rewrite /pi /P fdist_binaryxx. +have Hqi : qi = 1 - q by rewrite /qi /= fdist_binaryxx. +have Hpj : pj = p. by rewrite /pj /= fdist_binaryE eq_sym (negbTE (Set2.a_neq_b card_A)). -have Hqj : qj = Prob.p q. +have Hqj : qj = q. by rewrite /qj /= fdist_binaryE eq_sym (negbTE (Set2.a_neq_b card_A)). -transitivity (D(P || Q) - c * (`| Prob.p p - Prob.p q | + `| (1 - Prob.p p) - (1 - Prob.p q) |) ^ 2). +transitivity (D(P || Q) - c * (`| (p : R) - q | + `| (1 - p) - (1 - q) |) ^+ 2). rewrite /pinsker_fun /div Set2sumE -/a -/b -/pi -/pj -/qi -/qj Hpi Hpj Hqi Hqj. - set tmp := (`| _ | + _) ^ 2. - have -> : tmp = 4 * (Prob.p p - Prob.p q) ^ 2. - rewrite /tmp (_ : 1 - Prob.p p - (1 - Prob.p q) = Prob.p q - Prob.p p); last by field. - rewrite sqrRD (distRC (Prob.p q) (Prob.p p)) -mulRA -{3}(pow_1 `| Prob.p p - Prob.p q |). - rewrite -expRS sqR_norm; ring. - rewrite [X in _ = _ + _ - X]mulRA. - rewrite [in X in _ = _ + _ - X](mulRC c). + set tmp := (`| _ | + _) ^+ 2. + have -> : tmp = 4 * ((p : R) - q) ^+ 2. + rewrite /tmp (_ : 1 - p - (1 - q) = (q : R) - p); last by simpl; ring. + rewrite sqrrD (distrC (q : R) (p : R)) -{3}(expr1 `|(p : R) - q|). + by rewrite -exprS real_normK ?num_real//; ring. + rewrite [X in _ = _ + _ - X]mulrA. + rewrite [in X in _ = _ + _ - X](mulrC c). congr (_ - _). - case/boolP : (p == 0%:pr) => [/eqP |] p0. - rewrite p0 !mul0R subR0 addR0 add0R !mul1R /log (*_Log_1*) /Rdiv. - have [q1|q1] := eqVneq q 1%:pr. - move/dominatesP : P_dom_by_Q => /(_ (Set2.a card_A)). - rewrite -/pi -/qi Hqi q1 subRR => /(_ erefl). - by rewrite Hpi p0 subR0 -R0E => ?; exfalso; lra. - rewrite /log LogM; last 2 first. - lra. - by apply/invR_gt0; rewrite subR_gt0; apply/RltP/prob_lt1. - rewrite LogV; last by apply/subR_gt0/RltP/prob_lt1. - by rewrite Log_1. + case/boolP : (p == 0%:pr) => [/eqP |] p0; + first by rewrite p0 !mul0r subr0 addr0 add0r !mul1r. have [q0|q0] := eqVneq q 0%:pr. move/dominatesP : P_dom_by_Q => /(_ (Set2.b card_A)). rewrite -/pj -/qj Hqj q0 => /(_ erefl). rewrite Hpj => abs. - have : p == 0%:pr by apply/eqP/val_inj. + have : p == 0%:pr by exact/eqP/val_inj. by rewrite (negbTE p0). - rewrite /div_fct /comp /= (_ : id (Prob.p q) = Prob.p q) //. have [->|p1] := eqVneq p 1%:pr. - rewrite subRR !mul0R /Rdiv /log LogM //; last first. - apply/invR_gt0; by apply/RltP/prob_gt0. - rewrite Log_1 /= mul1R LogV //; last by apply/RltP/prob_gt0. - by rewrite !(add0R,mul1R,addR0,sub0R). - rewrite /log LogM //; last 2 first. - by apply/RltP/prob_gt0. - by apply/invR_gt0/RltP/prob_gt0. - rewrite LogV //; last by apply/RltP/prob_gt0. + rewrite subrr !mul0r logM //; last first. + by rewrite invr_gt0; exact/prob_gt0. + by rewrite !(add0r,mul1r,addr0,sub0r). + rewrite logM //; [| exact/prob_gt0 | by rewrite invr_gt0; exact/prob_gt0]. + rewrite logV //; last exact/prob_gt0. have [q1|q1] := eqVneq q 1%:pr. move/dominatesP : P_dom_by_Q => /(_ (Set2.a card_A)). - rewrite -/pi -/qi Hqi q1 subRR => /(_ erefl). - rewrite Hpi subR_eq0 => abs. - have : p == 1%:pr by apply/eqP/val_inj. - by rewrite (negbTE p1). - rewrite /Rdiv LogM ?subR_gt0 //; last 2 first. - by apply/RltP/prob_lt1. - by apply/invR_gt0; rewrite subR_gt0; apply/RltP/prob_lt1. - rewrite LogV; last by rewrite subR_gt0; apply/RltP/prob_lt1. - ring. + rewrite -/pi -/qi Hqi q1 subrr => /(_ erefl). + by rewrite Hpi=> ->; rewrite mul0r addr0 add0r. + rewrite logM ?invr_gt0 ?subr_gt0 -?prob_lt1//. + rewrite logV ?subr_gt0-?prob_lt1//. + by rewrite addrC. congr (_ - _ * _). -by rewrite /var_dist Set2sumE // -/pi -/pj -/qi -/qj Hpi Hpj Hqi Hqj addRC. +by rewrite /var_dist Set2sumE // -/pi -/pj -/qi -/qj Hpi Hpj Hqi Hqj addrC. Qed. -Lemma Pinsker_2_inequality_bdist : / (2 * ln 2) * d(P , Q) ^ 2 <= D(P || Q). +Lemma Pinsker_2_inequality_bdist : (2 * ln 2)^-1 * d(P , Q) ^+ 2 <= D(P || Q). Proof. set lhs := _ * _. set rhs := D(_ || _). -rewrite -subR_ge0 -pinsker_fun_p_eq. +rewrite -subr_ge0 -pinsker_fun_p_eq. apply pinsker_fun_pos with A card_A => //. -by split; [exact/invR_ge0/mulR_gt0 | by apply/RleP; rewrite lexx]. +by rewrite lexx andbT invr_ge0 mulr_ge0// ln2_ge0. Qed. End Pinsker_2_bdist. @@ -452,7 +429,7 @@ Variables (A : finType) (P Q : {fdist A}). Hypothesis card_A : #|A| = 2%nat. Hypothesis P_dom_by_Q : P `<< Q. -Lemma Pinsker_2_inequality : / (2 * ln 2) * d(P , Q) ^ 2 <= D(P || Q). +Lemma Pinsker_2_inequality : (2 * ln 2)^-1 * d(P , Q) ^+ 2 <= D(P || Q). Proof. move: (charac_bdist P card_A) => [r1 Hp]. move: (charac_bdist Q card_A) => [r2 Hq]. @@ -473,86 +450,76 @@ Local Notation "1" := (true). Lemma bipart_dominates : let A_ := fun b => if b then [set a | (P a < Q a)%mcR] else [set a | (Q a <= P a)%mcR] in - forall (cov : A_ 0 :|: A_ 1 = [set: A]) (dis : A_ 0 :&: A_ 1 = set0), + forall (cov : A_ 0 :|: A_ 1 = [set: A]) (dis : A_ 0 :&: A_ 1 = finset.set0), bipart dis cov P `<< bipart dis cov Q. Proof. move=> A_ cov dis; apply/dominatesP => /= b. rewrite !ffunE => /psumr_eq0P H. -transitivity (\sum_(a | a \in A_ b) 0%R). - apply eq_bigr => // a ?. - by rewrite (dominatesE P_dom_by_Q) // H // => a' ?; exact/pos_ff_ge0. -by rewrite big_const iter_addR mulR0. +by apply: big1=> ? ?; rewrite (dominatesE P_dom_by_Q) // ?H //. Qed. -Lemma Pinsker_inequality : / (2 * ln 2) * d(P , Q) ^ 2 <= D(P || Q). +Lemma Pinsker_inequality : (2 * ln 2)^-1 * d(P , Q) ^+ 2 <= D(P || Q). Proof. pose A0 := [set a | (Q a <= P a)%mcR]. pose A1 := [set a | (P a < Q a)%mcR]. pose A_ := fun b => match b with 0 => A0 | 1 => A1 end. -have cov : A_ 0 :|: A_ 1 = setT. +have cov : A_ 0 :|: A_ 1 = finset.setT. rewrite /= /A0 /A1. have -> : [set x | (P x < Q x)%mcR] = ~: [set x | (Q x <= P x)%mcR]. - by apply/setP => a; rewrite in_set in_setC in_set ltNge. - by rewrite setUCr. -have dis : A_ 0 :&: A_ 1 = set0. + by apply/setP => a; rewrite finset.in_set finset.in_setC finset.in_set ltNge. + by rewrite finset.setUCr. +have dis : A_ 0 :&: A_ 1 = finset.set0. rewrite /A_ /A0 /A1. have -> : [set x | (P x < Q x)%mcR] = ~: [set x | (Q x <= P x)%mcR]. - by apply/setP => a; rewrite in_set in_setC in_set ltNge. - by rewrite setICr. + by apply/setP => a; rewrite finset.in_set finset.in_setC finset.in_set ltNge. + by rewrite finset.setICr. pose P_A := bipart dis cov P. pose Q_A := bipart dis cov Q. have step1 : D(P_A || Q_A) <= D(P || Q). by apply partition_inequality; exact P_dom_by_Q. -suff : / (2 * ln 2) * d(P , Q) ^2 <= D(P_A || Q_A). - move=> ?; apply (@leR_trans (D(P_A || Q_A))) => //; exact/Rge_le. +suff : (2 * ln 2)^-1 * d(P , Q) ^+ 2 <= D(P_A || Q_A). + move=> ?; apply (@le_trans _ _ (D(P_A || Q_A))) => //; exact/ge_le. have -> : d( P , Q ) = d( P_A , Q_A ). rewrite /var_dist. transitivity (\sum_(a | a \in A0) `| P a - Q a | + \sum_(a | a \in A1) `| P a - Q a |). - rewrite -big_union //; last by rewrite -setI_eq0 -dis /A_ setIC. - apply eq_bigl => a; by rewrite cov in_set. + rewrite -big_union //; last by rewrite -setI_eq0 -dis /A_ finset.setIC. + apply eq_bigl => a; by rewrite cov finset.in_set. transitivity (`| P_A 0 - Q_A 0 | + `| P_A 1 - Q_A 1 |). congr (_ + _). - rewrite /P_A /Q_A /bipart /= /bipart_pmf /=. transitivity (\sum_(a | a \in A0) (P a - Q a)). - apply: eq_bigr => a; rewrite /A0 in_set => /RleP Ha. - by rewrite geR0_norm ?subR_ge0. - rewrite big_split /= geR0_norm; last first. - rewrite subR_ge0; rewrite !ffunE. - by apply leR_sumR => ?; rewrite inE => /RleP. - by rewrite -big_morph_oppR // 2!ffunE addR_opp. + apply: eq_bigr => a; rewrite /A0 finset.in_set => Ha. + by rewrite ger0_norm ?subr_ge0. + rewrite big_split /= ger0_norm; last first. + rewrite subr_ge0; rewrite !ffunE. + by apply ler_sum => ?; rewrite inE. + by rewrite -big_morph_oppr // 2!ffunE. - rewrite /P_A /Q_A /bipart /= !ffunE /=. have [A1_card | A1_card] : #|A1| = O \/ (0 < #|A1|)%nat. destruct (#|A1|); [tauto | by right]. + move/eqP : A1_card; rewrite cards_eq0; move/eqP => A1_card. - by rewrite A1_card !big_set0 subRR normR0. + by rewrite A1_card !big_set0 subrr normr0. + transitivity (\sum_(a | a \in A1) - (P a - Q a)). - apply eq_bigr => a; rewrite /A1 in_set => Ha. - by rewrite ltR0_norm // subR_lt0; exact/RltP. - rewrite -big_morph_oppR // big_split /= ltR0_norm; last first. - rewrite subR_lt0; apply ltR_sumR_support => // a. - by rewrite /A1 in_set => /RltP. - by rewrite -big_morph_oppR. + apply eq_bigr => a; rewrite /A1 finset.in_set => Ha. + by rewrite ltr0_norm // subr_lt0. + rewrite -big_morph_oppr // big_split /= ltr0_norm; last first. + rewrite subr_lt0; apply: ltR_sumR_support => // a. + by rewrite /A1 finset.in_set. + by rewrite -big_morph_oppr. by rewrite big_bool /= /bipart_pmf !ffunE /=. exact/(Pinsker_2_inequality card_bool)/bipart_dominates. Qed. -Lemma Pinsker_inequality_weak : d(P , Q) <= sqrt (2 * D(P || Q)). +Lemma Pinsker_inequality_weak : d(P , Q) <= Num.sqrt (2 * D(P || Q)). Proof. -rewrite -(sqrt_Rsqr (d(P , Q))); last exact/pos_var_dist. -apply sqrt_le_1_alt. -apply (@leR_pmul2l (/ 2)); first by apply invR_gt0; lra. -apply (@leR_trans (D(P || Q))); last first. - rewrite mulRA mulVR // ?mul1R; [| exact/gtR_eqF]. - by apply/RleP; rewrite lexx. -apply: (leR_trans _ Pinsker_inequality). -rewrite (_ : forall x, Rsqr x = x ^ 2); last first. - by move=> ?; rewrite /Rsqr /pow mulR1. -apply leR_wpmul2r; first exact: pow_even_ge0. -apply leR_inv => //; first exact/mulR_gt0. -rewrite -[X in _ <= X]mulR1. -apply leR_wpmul2l; first lra. -rewrite [X in _ <= X](_ : 1%R = ln (exp 1)); last by rewrite ln_exp. -by apply ln_increasing_le; [lra | exact leR2e]. +rewrite -[leLHS]ger0_norm ?pos_var_dist// -sqrtr_sqr. +rewrite ler_wsqrtr// -ler_pdivrMl//. +apply: (le_trans _ Pinsker_inequality). +rewrite invfM mulrAC ler_peMr//. + by rewrite mulr_ge0// ?invr_ge0// sqr_ge0. +rewrite invf_ge1// ?ln2_gt0//. +rewrite -[leRHS]expRK. +by rewrite ler_ln ?posrE// ?expR_gt0// ltW// expR1_gt2. Qed. End Pinsker. diff --git a/probability/proba.v b/probability/proba.v index 390cccf4..0f2dca1f 100644 --- a/probability/proba.v +++ b/probability/proba.v @@ -1,11 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. +From mathcomp Require Import all_ssreflect ssralg ssrnum matrix lra. From mathcomp Require boolp. -From mathcomp Require Import Rstruct reals. -Require Import Reals Lra. -Require Import ssrR Reals_ext realType_ext logb ssr_ext ssralg_ext. -Require Import bigop_ext fdist. +From mathcomp Require Import reals exp. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln fdist. (******************************************************************************) (* Probabilities over finite distributions *) @@ -123,20 +121,22 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. +Local Open Scope ring_scope. Local Open Scope reals_ext_scope. Local Open Scope fdist_scope. Local Open Scope proba_scope. -Import Order.POrderTheory Num.Theory. +Import Order.POrderTheory GRing.Theory Num.Theory. -Lemma m1powD k : k <> 0%nat -> (-1)^(k-1) = - (-1)^k. -Proof. by case: k => [//|k _]; rewrite subn1 /= mulN1R oppRK. Qed. +(* TODO: mv *) +Lemma m1powD {R : ringType} k : k <> 0%nat -> (-1) ^+ (k-1) = - (-1) ^+ k :> R. +Proof. by case: k => [//|k _]; rewrite subn1 /= exprS mulN1r opprK. Qed. Notation "E `*T" := ([set x | x.1 \in E]) : proba_scope. Notation "T`* F" := ([set x | x.2 \in F]) : proba_scope. Section TsetT. +Context {R : realType}. Variables (A B : finType) (P : R.-fdist (A * B)). Implicit Types (E : {set A}) (F : {set B}). @@ -171,40 +171,32 @@ Proof. by apply/setP => -[a b]; rewrite !inE. Qed. End TsetT. (* TODO: consider moving this to fdist.v *) -#[global] Hint Extern 0 (IZR Z0 <= _) => +(*#[global] Hint Extern 0 (IZR Z0 <= _) => solve [apply/RleP; exact: FDist.ge0] : core. #[global] Hint Extern 0 (_ <= IZR (Zpos xH)) => - solve [apply/RleP; exact: FDist.le1] : core. + solve [apply/RleP; exact: FDist.le1] : core.*) Section probability. +Context {R : realType}. Variables (A : finType) (P : R.-fdist A). Implicit Types E : {set A}. Definition Pr E := \sum_(a in E) P a. -Lemma Pr_ge0 E : 0 <= Pr E. Proof. exact/RleP/sumr_ge0. Qed. +Lemma Pr_ge0 E : 0 <= Pr E. Proof. exact/sumr_ge0. Qed. Local Hint Resolve Pr_ge0 : core. Lemma Pr_gt0P E : 0 < Pr E <-> Pr E != 0. Proof. -split => H; first by move/gtR_eqF : H. -by rewrite ltR_neqAle; split => //; exact/nesym/eqP. +by split => H; [rewrite gt_eqF|rewrite lt_neqAle eq_sym H/=]. Qed. Lemma Pr_le1 E : Pr E <= 1. -Proof. -rewrite (_ : 1 = GRing.one _)//. -rewrite -(FDist.f1 P); apply leR_sumRl => // a _. -by apply/RleP; rewrite lexx. -Qed. +Proof. by rewrite -(FDist.f1 P) /Pr; exact/ler_suml. Qed. Lemma Pr_lt1P E : Pr E < 1 <-> Pr E != 1. -Proof. -split => H; move: (Pr_le1 E); rewrite leR_eqVlt. - by move=> [Pr1|]; [move: H; rewrite Pr1 => /ltRR|exact: ltR_eqF]. -by move=> [Pr1|//]; rewrite Pr1 eqxx in H. -Qed. +Proof. by rewrite lt_neqAle Pr_le1 andbT. Qed. Lemma Pr_set0 : Pr set0 = 0. Proof. by rewrite /Pr big_pred0 // => a; rewrite in_set0. Qed. @@ -227,20 +219,18 @@ Proof. by rewrite /Pr big_set1. Qed. Lemma Pr_cplt E : Pr E + Pr (~: E) = 1. Proof. rewrite /Pr -bigU /=; last by rewrite -subsets_disjoint. -rewrite (_ : 1 = GRing.one _)//. by rewrite -(FDist.f1 P); apply eq_bigl => /= a; rewrite !inE /= orbN. Qed. Lemma Pr_to_cplt E : Pr E = 1 - Pr (~: E). -Proof. by rewrite -(Pr_cplt E); field. Qed. +Proof. by rewrite -(Pr_cplt E) addrK. Qed. Lemma Pr_setC E : Pr (~: E) = 1 - Pr E. -Proof. by rewrite -(Pr_cplt E); field. Qed. +Proof. by rewrite -(Pr_cplt E) addrAC subrr add0r. Qed. Lemma subset_Pr E E' : E \subset E' -> Pr E <= Pr E'. Proof. -move=> H; apply leR_sumRl => a aE //; [ | by move/subsetP : H; exact]. -by apply/RleP; rewrite lexx. +by move=> H; apply ler_suml => a aE //; move/subsetP : H; exact. Qed. Lemma le_Pr_setU E1 E2 : Pr (E1 :|: E2) <= Pr E1 + Pr E2. @@ -252,28 +242,28 @@ rewrite [X in _ <= X + _](_ : _ = \sum_(i in A | pred_of_set E1 i) P i); last fi by apply eq_bigl => x /=; rewrite unfold_in. rewrite [X in _ <= _ + X](_ : _ = \sum_(i in A | pred_of_set E2 i) P i); last first. by apply eq_bigl => x /=; rewrite unfold_in. -exact/leR_sumR_predU. +exact: ler_sum_predU. Qed. Lemma Pr_bigcup (B : finType) (p : pred B) F : Pr (\bigcup_(i | p i) F i) <= \sum_(i | p i) Pr (F i). Proof. rewrite /Pr; elim: (index_enum _) => [| h t IH]. - by rewrite big_nil; apply/RleP/sumr_ge0 => b _; rewrite big_nil. + by rewrite big_nil; apply/sumr_ge0 => b _; rewrite big_nil. rewrite big_cons; case: ifP => H1. - apply: leR_trans; first by eapply leR_add2l; exact: IH. + apply: (@le_trans _ _ (P h + \sum_(i | p i) \sum_(a <- t | a \in F i) P a)). + by rewrite lerD2l. rewrite [X in _ <= X](exchange_big_dep (fun h => (h \in A) && [pred x in \bigcup_(i | p i) F i] h)) /=; last first. by move=> b a Ea jFi; apply/bigcupP; exists b. - rewrite big_cons /= H1 big_const iter_addR -exchange_big_dep /=; last first. + rewrite big_cons /= H1 big_const iter_addr -exchange_big_dep /=; last first. by move=> b a Ea iFj; apply/bigcupP; exists b. - apply/leR_add2r. - rewrite -{1}(mul1R (P h)); apply: (@leR_wpmul2r (P h)) => //. - rewrite (_ : 1 = 1%:R) //; apply/le_INR/ssrnat.leP/card_gt0P. + rewrite lerD2r// addr0 -mulr_natl -{1}(mul1r (P h)) ler_wpM2r//. + rewrite [leLHS](_ : 1 = 1%:R)// ler_nat; apply/card_gt0P. by case/bigcupP : H1 => b Eb hFb; exists b; rewrite -topredE /= Eb. -apply/(leR_trans IH)/leR_sumR => b Eb; rewrite big_cons. -case: ifPn => hFb; last by apply/RleP; rewrite lexx. -by rewrite -[X in X <= _]add0R; exact/leR_add2r. +apply/(le_trans IH)/ler_sum => b Eb; rewrite big_cons. +case: ifPn => hFb; last by rewrite lexx. +by rewrite -[X in X <= _]add0r lerD2r. Qed. Lemma disjoint_Pr_setU E1 E2 : [disjoint E1 & E2] -> Pr (E1 :|: E2) = Pr E1 + Pr E2. @@ -291,16 +281,16 @@ by rewrite big_ord_recl IH // => i j ij; rewrite H. Qed. Lemma Pr_setD E1 E2 : Pr (E1 :\: E2) = Pr E1 - Pr (E1 :&: E2). -Proof. by rewrite /Pr [in RHS](big_setID E2) /= addRC addRK. Qed. +Proof. by rewrite /Pr [in RHS](big_setID E2) //= addrAC subrr add0r. Qed. Lemma Pr_setU E1 E2 : Pr (E1 :|: E2) = Pr E1 + Pr E2 - Pr (E1 :&: E2). Proof. -rewrite addRC -addR_opp -addRA addR_opp -Pr_setD -disjoint_Pr_setU -?setU_setUD //. +rewrite addrAC -Pr_setD addrC -disjoint_Pr_setU -?setU_setUD//. by rewrite -setI_eq0 setIDA setDIl setDv set0I. Qed. Lemma Pr_setI E1 E2 : Pr (E1 :&: E2) = Pr E1 + Pr E2 - Pr (E1 :|: E2). -Proof. by rewrite Pr_setU subRBA addRC addRK. Qed. +Proof. by rewrite Pr_setU opprB addrCA subrr addr0. Qed. Lemma Boole_eq (I : finType) (F : I -> {set A}) : (forall i j, i != j -> [disjoint F i & F j]) -> @@ -354,7 +344,7 @@ Notation Pr_gt0 := Pr_gt0P (only parsing). #[deprecated(since="infotheo 0.7.2", note="renamed to `Pr_lt1P`")] Notation Pr_lt1 := Pr_lt1P (only parsing). -Lemma Pr_domin_setI (A : finType) (d : {fdist A}) (E F : {set A}) : +Lemma Pr_domin_setI {R : realType} (A : finType) (d : R.-fdist A) (E F : {set A}) : Pr d E = 0 -> Pr d (E :&: F) = 0. Proof. move=> PE0; apply/eqP; rewrite psumr_eq0//; apply/allP => a _. @@ -364,6 +354,7 @@ by move=> /(_ a); rewrite mem_index_enum => /(_ isT); rewrite aE implyTb. Qed. Section Pr_extra. +Context {R : realType}. Variables (A B : finType) (P : R.-fdist (A * B)). Implicit Types (E : {set A}) (F : {set B}). @@ -396,18 +387,18 @@ Qed. End Pr_extra. -Lemma Pr_domin_setX (A B : finType) (P : {fdist A * B}) E F : +Lemma Pr_domin_setX {R : realType} (A B : finType) (P : R.-fdist (A * B)) E F : Pr P`1 E = 0 -> Pr P (E `* F) = 0. Proof. move/Pr_set0P => H; apply/Pr_set0P => -[? ?]. by rewrite inE /= => /andP[/H /dom_by_fdist_fst ->]. Qed. -Lemma Pr_domin_setXN (A B : finType) (P : {fdist A * B}) E F : +Lemma Pr_domin_setXN {R : realType} (A B : finType) (P : R.-fdist (A * B)) E F : Pr P (E `* F) != 0 -> Pr P`1 E != 0. Proof. by apply/contra => /eqP/Pr_domin_setX => ?; exact/eqP. Qed. -Lemma Pr_fdistmap (A B : finType) (f : A -> B) (d : R.-fdist A) (E : {set A}) : +Lemma Pr_fdistmap {R : realType} (A B : finType) (f : A -> B) (d : R.-fdist A) (E : {set A}) : injective f -> Pr d E = Pr (fdistmap f d) (f @: E). Proof. @@ -418,9 +409,9 @@ rewrite (exchange_big_dep (mem E)) /=; last first. apply eq_bigr => a aE; rewrite (big_pred1 (f a)) // => b /=. by rewrite !inE andb_idl //= => /eqP <-{b}; apply/imsetP; exists a. Qed. -Arguments Pr_fdistmap [A] [B] [f] [d] [E]. +Arguments Pr_fdistmap {R} [A] [B] [f] [d] [E]. -Lemma Pr_fdist_prod (A B : finType) (P1 : {fdist A}) (P2 : {fdist B}) +Lemma Pr_fdist_prod {R : realType} (A B : finType) (P1 : R.-fdist A) (P2 : R.-fdist B) (E1 : {set A}) (E2 : {set B}) : Pr (P1 `x P2) ((E1 `*T) :&: (T`* E2)) = Pr (P1 `x P2) (E1 `*T) * Pr (P1 `x P2) (T`* E2). Proof. @@ -446,11 +437,11 @@ rewrite [in RHS](eq_bigl (fun x => true && (x.2 \in E2))) //. rewrite -[in RHS](pair_big xpredT (fun x => x \in E2) (fun x1 x2 => P (x1, x2))) /=. rewrite exchange_big /= big_distrr /=; apply eq_big => // b E2b. rewrite fdist_prodE /=; congr (_ * _); under eq_bigr do rewrite fdist_prodE /=. - by rewrite -big_distrr /= FDist.f1 mulR1. -by rewrite -big_distrl /= FDist.f1 mul1R. + by rewrite -big_distrr /= FDist.f1 mulr1. +by rewrite -big_distrl /= FDist.f1 mul1r. Qed. -Lemma Pr_fdist_fst (A B : finType) (P : {fdist A * B}) (E : {set A}) : +Lemma Pr_fdist_fst {R : realType} (A B : finType) (P : R.-fdist (A * B)) (E : {set A}) : Pr P`1 E = Pr P (E `*T). Proof. rewrite /Pr (eq_bigr (fun x => P (x.1, x.2))); last by case. @@ -460,7 +451,7 @@ rewrite -[in RHS](pair_big (mem E) xpredT (fun x1 x2 => P (x1, x2))) /=. by under eq_bigr do rewrite fdist_fstE. Qed. -Lemma Pr_fdist_snd (A B : finType) (P : {fdist A * B}) (E : {set B}) : +Lemma Pr_fdist_snd {R : realType} (A B : finType) (P : R.-fdist (A * B)) (E : {set B}) : Pr P`2 E = Pr P (T`* E). Proof. rewrite /Pr (eq_bigr (fun x => P (x.1, x.2))); last by case. @@ -472,7 +463,7 @@ by rewrite exchange_big. Qed. Local Open Scope vec_ext_scope. -Lemma Pr_fdist_prod_of_rV (A : finType) n (P : {fdist 'rV[A]_n.+1}) +Lemma Pr_fdist_prod_of_rV {R : realType} (A : finType) n (P : R.-fdist 'rV[A]_n.+1) (E : {set A}) (F : {set 'rV[A]_n}) : Pr (fdist_prod_of_rV P) (E `* F) = Pr P [set x : 'rV[A]_n.+1 | ((x ``_ ord0) \in E) && ((rbehead x) \in F)]. @@ -487,13 +478,13 @@ rewrite -(big_rV_cons_behead _ (mem E) (mem F)) /=. by apply eq_bigr => a aE; apply eq_bigr => v _; rewrite fdist_prod_of_rVE. Qed. -Lemma Pr_fdist_prod_of_rV1 (A : finType) n (P : {fdist 'rV[A]_n.+1}) (E : {set A}) : +Lemma Pr_fdist_prod_of_rV1 {R : realType} (A : finType) n (P : R.-fdist 'rV[A]_n.+1) (E : {set A}) : Pr (fdist_prod_of_rV P) (E `*T) = Pr P [set x : 'rV[A]_n.+1 | (x ``_ ord0) \in E]. Proof. by rewrite EsetT Pr_fdist_prod_of_rV; congr Pr; apply/setP => v; rewrite !inE andbT. Qed. -Lemma Pr_fdist_prod_of_rV2 (A : finType) n (P : {fdist 'rV[A]_n.+1}) (E : {set 'rV[A]_n}) : +Lemma Pr_fdist_prod_of_rV2 {R : realType} (A : finType) n (P : R.-fdist 'rV[A]_n.+1) (E : {set 'rV[A]_n}) : Pr (fdist_prod_of_rV P) (T`* E) = Pr P [set x : 'rV[A]_n.+1 | (rbehead x) \in E]. Proof. by rewrite setTE Pr_fdist_prod_of_rV; congr Pr; apply/setP => v; rewrite !inE. @@ -502,21 +493,23 @@ Qed. Local Close Scope vec_ext_scope. Section random_variable. +Context {R : realType}. Variables (U : finType) (T : eqType). Definition RV (P : R.-fdist U) := U -> T. -Definition RV_of (P : {fdist U}) := +Definition RV_of (P : R.-fdist U) := fun (phA : phant (Equality.sort U)) (phT : phant (Equality.sort T)) => RV P. Local Notation "{ 'RV' P -> V }" := (RV_of P (Phant _) (Phant V)). -Definition ambient_dist (P : {fdist U}) (X : {RV P -> T}) : {fdist U} := P. +Definition ambient_dist (P : R.-fdist U) (X : {RV P -> T}) : R.-fdist U := P. End random_variable. Notation "{ 'RV' P -> T }" := (RV_of P (Phant _) (Phant T)) : proba_scope. Section random_variable_eqType. +Context {R : realType}. Variables (U : finType) (A : eqType) (P : R.-fdist U). Definition pr_eq (X : {RV P -> A}) (a : A) := locked (Pr P (finset (X @^-1 a))). @@ -532,11 +525,13 @@ Lemma pr_eq_neq0 (X : {RV P -> A}) (a : A) : `Pr[ X = a ] != 0 <-> exists i, i \in X @^-1 a /\ 0 < P i. Proof. split; rewrite pr_eqE /Pr => PXa0. - have H : forall i : U, 0 <= P i by move=> ?; apply/RleP/FDist.ge0. - have := proj1 (@sumR_neq0 U P (enum (finset (X @^-1 a))) H). - by rewrite !big_enum /= => /(_ PXa0) [i]; rewrite mem_enum inE => ?; exists i. -case: PXa0 => i ?; rewrite -big_enum; apply/sumR_neq0; - by [move=> ?; exact/RleP/FDist.ge0 | exists i; rewrite mem_enum inE]. + have H : forall i : U, 0 <= P i by move=> ?; apply/FDist.ge0. + have := @psumr_neq0 R U (enum (finset (X @^-1 a))) xpredT _ (fun i _ => H i). + rewrite big_enum PXa0 => /esym/hasP[i/=]. + by rewrite mem_enum inE/= => Xia Pi_gt0; exists i. +case: PXa0 => i; rewrite inE => ?. +rewrite psumr_neq0//; apply/hasP; exists i => //. +by rewrite inE; exact/andP. Qed. Lemma pr_eq0 (X : {RV P -> A}) (a : A) : a \notin fin_img X -> `Pr[ X = a ] = 0. @@ -551,6 +546,7 @@ Notation "`Pr[ X = a ]" := (pr_eq X a) : proba_scope. Global Hint Resolve pr_eq_ge0 : core. Section random_variable_order. +Context {R : realType}. Context (U : finType) d (T : porderType d) (P : R.-fdist U). Variables (X : {RV P -> T}). @@ -563,6 +559,7 @@ Notation "'`Pr[' X '>=' r ']'" := (pr_geq X r) : proba_scope. Notation "'`Pr[' X '<=' r ']'" := (pr_leq X r) : proba_scope. Section random_variable_finType. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (A : finType). Definition pr_eq_set (X : {RV P -> A}) (E : {set A}) := @@ -573,7 +570,7 @@ Lemma pr_eq_setE (X : {RV P -> A}) (E : {set A}) : `Pr[ X \in E ] = Pr P (X @^-1: E). Proof. by rewrite /pr_eq_set; unlock. Qed. -Definition dist_of_RV (X : {RV P -> A}) : {fdist A} := fdistmap X P. +Definition dist_of_RV (X : {RV P -> A}) : R.-fdist A := fdistmap X P. Local Notation "`p_ X" := (dist_of_RV X). Lemma pr_eqE' (X : {RV P -> A}) (a : A) : `Pr[ X = a ] = `p_X a. @@ -595,6 +592,7 @@ Notation "`Pr[ X '\in' E ]" := (pr_eq_set X E) : proba_scope. Notation "`p_ X" := (dist_of_RV X) : proba_scope. Section random_variables. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U). Definition const_RV (T : eqType) cst : {RV P -> T} := fun=> cst. @@ -609,7 +607,7 @@ Definition sumR_RV I (r : seq.seq I) (p : pred I) (X : I -> {RV P -> R}) : {RV P Definition sub_RV (X Y : {RV P -> R}) : {RV P -> R} := fun x => X x - Y x. Definition trans_add_RV (X : {RV P -> R}) m : {RV P -> R} := fun x => X x + m. Definition trans_min_RV (X : {RV P -> R}) m : {RV P -> R} := fun x => X x - m. -Definition sq_RV (X : {RV P -> R}) : {RV P -> R} := (fun x => x ^ 2) `o X. +Definition sq_RV (X : {RV P -> R}) : {RV P -> R} := (fun x => x ^+ 2) `o X. Definition neg_RV (X : {RV P -> R}) : {RV P -> R} := fun x => - X x. Definition log_RV : {RV P -> R} := fun x => log (P x). Definition unit_RV : {RV P -> unit} := fun=> tt. @@ -629,24 +627,26 @@ Notation "'`--' P" := (neg_RV P) : proba_scope. Notation "'`log' P" := (log_RV P) : proba_scope. Section RV_lemmas. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U). Implicit Types X : {RV P -> R}. Lemma scalel_RVA k l X : scalel_RV (k * l) X = scalel_RV k (scalel_RV l X). -Proof. by rewrite /scalel_RV boolp.funeqE => u; rewrite mulRA. Qed. +Proof. by rewrite /scalel_RV boolp.funeqE => u; rewrite mulrA. Qed. Lemma scaler_RVA X k l : scaler_RV X (k * l) = scaler_RV (scaler_RV X k) l. -Proof. by rewrite /scaler_RV boolp.funeqE => u; rewrite mulRA. Qed. +Proof. by rewrite /scaler_RV boolp.funeqE => u; rewrite mulrA. Qed. -Lemma sq_RV_pow2 X x : sq_RV X x = (X x) ^ 2. +Lemma sq_RV_pow2 X x : sq_RV X x = (X x) ^+ 2. Proof. reflexivity. Qed. Lemma sq_RV_ge0 X x : 0 <= sq_RV X x. -Proof. by rewrite sq_RV_pow2; exact: pow2_ge_0. Qed. +Proof. by rewrite sq_RV_pow2 sqr_ge0. Qed. End RV_lemmas. Section pair_of_RVs. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U). Variables (A : eqType) (X : {RV P -> A}) (B : eqType) (Y : {RV P -> B}). Definition RV2 : {RV P -> A * B} := fun x => (X x, Y x). @@ -655,6 +655,7 @@ End pair_of_RVs. Notation "'[%' x , y , .. , z ']'" := (RV2 .. (RV2 x y) .. z). Section RV2_prop. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U). Variables (A B : finType) (X : {RV P -> A}) (Y : {RV P -> B}). @@ -676,6 +677,7 @@ Proof. by []. Qed. End RV2_prop. Section RV3_prop. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U). Variables (A B C D : finType). Variables (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}) (W : {RV P -> D}). @@ -696,10 +698,10 @@ Proof. by rewrite /fdistC12 /dist_of_RV /fdistA fdistmap_comp. Qed. End RV3_prop. -Lemma pr_eq_unit (U : finType) (P : R.-fdist U) : `Pr[ (unit_RV P) = tt ] = 1. +Lemma pr_eq_unit {R : realType} (U : finType) (P : R.-fdist U) : `Pr[ (unit_RV P) = tt ] = 1. Proof. by rewrite pr_eqE'; apply/eqP/fdist1P; case. Qed. -Lemma Pr_fdistmap_RV2 (U : finType) (P : R.-fdist U) (A B : finType) +Lemma Pr_fdistmap_RV2 {R : realType} (U : finType) (P : R.-fdist U) (A B : finType) (E : {set A}) (F : {set B}) (X : {RV P -> A}) (Z : {RV P -> B}) : Pr `p_[% X, Z] (E `* F) = Pr P ([set x | preim X (mem E) x] :&: [set x | preim Z (mem F) x]). @@ -713,6 +715,7 @@ by rewrite fdistmapE. Qed. Section pr_pair. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U). Variables (A B C : finType) (TA TB TC : eqType). Variables (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}). @@ -772,17 +775,18 @@ Qed. End pr_pair. -Lemma pr_eq_pair_setT (U : finType) (P : {fdist U}) (A B : finType) (E : {set A}) +Lemma pr_eq_pair_setT {R : realType} (U : finType) (P : R.-fdist U) (A B : finType) (E : {set A}) (X : {RV P -> A}) (Y : {RV P -> B}) : `Pr[ [% X, Y] \in E `*T ] = `Pr[ X \in E ]. Proof. apply/esym. -rewrite (@pr_in_comp _ _ _ _ _ (fun a => (a, tt))); last by move=> u1 u2 -[]. +rewrite (@pr_in_comp _ _ _ _ _ _ (fun a => (a, tt))); last by move=> u1 u2 -[]. rewrite 2!pr_eq_setE; congr Pr; apply/setP => u; rewrite !inE /=. by apply/imsetP/idP => [[a aE [] ->//]|XuE]; exists (X u). Qed. Section RV_domin. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (A B : finType) (TA TB : eqType). Variables (X : {RV P -> A}) (Y : {RV P -> B}). Variables (TX : {RV P -> A}) (TY : {RV P -> B}). @@ -803,11 +807,11 @@ End RV_domin. Local Open Scope vec_ext_scope. -Definition cast_RV_fdist_rV1 (U : finType) (P : R.-fdist U) (T : eqType) (X : {RV P -> T}) +Definition cast_RV_fdist_rV1 {R : realType} (U : finType) (P : R.-fdist U) (T : eqType) (X : {RV P -> T}) : {RV (P `^ 1) -> T} := fun x => X (x ``_ ord0). -Definition cast_RV_fdist_rV10 (U : finType) (P : R.-fdist U) (T : eqType) +Definition cast_RV_fdist_rV10 {R : realType} (U : finType) (P : R.-fdist U) (T : eqType) (Xs : 'rV[{RV P -> T}]_1) : {RV (P `^ 1) -> T} := cast_RV_fdist_rV1 (Xs ``_ ord0). @@ -820,20 +824,22 @@ Definition cast_fun_rV10 U (T : eqType) (Xs : 'rV[U -> T]_1) : 'rV[U]_1 -> T := Local Close Scope vec_ext_scope. Section expected_value_def. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (X : {RV P -> R}). Definition Ex := \sum_(u in U) X u * P u. Lemma Ex_ge0 : (forall u, 0 <= X u) -> 0 <= Ex. -Proof. move=> H; apply/RleP/sumr_ge0 => u _; rewrite mulr_ge0//; exact/RleP. Qed. +Proof. move=> H; apply/sumr_ge0 => u _; rewrite mulr_ge0//; exact/RleP. Qed. End expected_value_def. -Arguments Ex {U} _ _. +Arguments Ex {R U} _ _. -Notation "'`E'" := (@Ex _ _) : proba_scope. +Notation "'`E'" := (@Ex _ _ _) : proba_scope. (* Alternative definition of the expected value: *) Section Ex_alt. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (X : {RV P -> R}). Definition Ex_alt := \sum_(r <- fin_img X) r * `Pr[ X = r ]. @@ -850,25 +856,26 @@ Qed. End Ex_alt. Section expected_value_prop. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (X Y : {RV P -> R}). Lemma E_neg_RV : `E (`-- X) = - `E X. Proof. -by rewrite /Ex/= big_morph_oppR/=; apply: eq_bigr => u _; rewrite mulNR. +by rewrite /Ex/= big_morph_oppr/=; apply: eq_bigr => u _; rewrite mulNr. Qed. Lemma E_scalel_RV k : `E (k `cst* X) = k * `E X. Proof. -by rewrite /scalel_RV {2}/Ex big_distrr /=; apply eq_bigr => a _; rewrite mulRA. +by rewrite /scalel_RV {2}/Ex big_distrr /=; apply eq_bigr => a _; rewrite mulrA. Qed. Lemma E_scaler_RV k : `E (X `*cst k) = `E X * k. Proof. -by rewrite big_distrl /=; apply: eq_bigr => i Hi; rewrite mulRAC. +by rewrite big_distrl /=; apply: eq_bigr => i Hi; rewrite mulrAC. Qed. Lemma E_add_RV : `E (X `+ Y) = `E X + `E Y. -Proof. rewrite -big_split; apply eq_bigr => a _ /=; by rewrite -mulRDl. Qed. +Proof. rewrite -big_split; apply eq_bigr => a _ /=; by rewrite -mulrDl. Qed. Lemma E_sumR I r p (Z : I -> {RV P -> R}) : `E (sumR_RV r p Z) = \sum_(i <- r | p i) (`E (Z i)). @@ -881,35 +888,35 @@ Qed. Lemma E_sub_RV : `E (X `- Y) = `E X - `E Y. Proof. -rewrite {3}/Ex -addR_opp big_morph_oppR -big_split /=. -apply eq_bigr => u _; by rewrite -mulNR -mulRDl. +rewrite {3}/Ex big_morph_oppr -big_split /=. +by apply eq_bigr => u _; by rewrite -mulNr -mulrDl. Qed. Lemma E_const_RV k : `E (const_RV P k) = k. -Proof. by rewrite /Ex /const_RV /= -big_distrr /= FDist.f1 mulR1. Qed. +Proof. by rewrite /Ex /const_RV /= -big_distrr /= FDist.f1 mulr1. Qed. Lemma E_trans_add_RV m : `E (X `+cst m) = `E X + m. Proof. rewrite /trans_add_RV /=. transitivity (\sum_(u in U) (X u * P u + m * P u)). - by apply eq_bigr => u _ /=; rewrite mulRDl. -by rewrite big_split /= -big_distrr /= FDist.f1 mulR1. + by apply eq_bigr => u _ /=; rewrite mulrDl. +by rewrite big_split /= -big_distrr /= FDist.f1 mulr1. Qed. Lemma E_trans_min_RV m : `E (X `-cst m) = `E X - m. Proof. rewrite /trans_min_RV /=. transitivity (\sum_(u in U) (X u * P u + - m * P u)). - by apply eq_bigr => u _ /=; rewrite mulRDl. -by rewrite big_split /= -big_distrr /= FDist.f1 mulR1. + by apply eq_bigr => u _ /=; rewrite mulrDl. +by rewrite big_split /= -big_distrr /= FDist.f1 mulr1. Qed. Lemma E_trans_RV_id_rem m : - `E ((X `-cst m) `^2) = `E ((X `^2 `- (2 * m `cst* X)) `+cst m ^ 2). + `E ((X `-cst m) `^2) = `E ((X `^2 `- (2 * m `cst* X)) `+cst m ^+ 2). Proof. apply eq_bigr => a _. rewrite /sub_RV /trans_add_RV /trans_min_RV /sq_RV /= /comp_RV /scalel_RV /=. -by rewrite /ambient_dist ; field. +by rewrite /ambient_dist; lra. Qed. Lemma E_comp_RV f k : (forall x y, f (x * y) = f x * f y) -> @@ -921,7 +928,7 @@ Proof. move=> H; by rewrite /comp_RV /= H. Qed. End expected_value_prop. -Lemma E_cast_RV_fdist_rV1 (A : finType) (P : R.-fdist A) : +Lemma E_cast_RV_fdist_rV1 {R : realType} (A : finType) (P : R.-fdist A) : forall (X : {RV P -> R}), `E (cast_RV_fdist_rV1 X) = `E X. Proof. move=> f; rewrite /cast_RV_fdist_rV1 /=; apply big_rV_1 => // m. @@ -929,6 +936,7 @@ by rewrite -fdist_rV1. Qed. Section conditional_expectation_def. +Context {R : realType}. Variable (U : finType) (P : R.-fdist U) (X : {RV P -> R}) (F : {set U}). Definition cEx := @@ -938,6 +946,7 @@ End conditional_expectation_def. Notation "`E_[ X | F ]" := (cEx X F). Section conditional_expectation_prop. +Context {R : realType}. Variable (U I : finType) (P : R.-fdist U) (X : {RV P -> R}) (F : I -> {set U}). Hypothesis dis : forall i j, i != j -> [disjoint F i & F j]. Hypothesis cov : cover [set F i | i in I] = [set: U]. @@ -948,13 +957,13 @@ apply/esym; rewrite /cEx. evar (f : I -> R); rewrite (eq_bigr f); last first. move=> i _; rewrite big_distrl /f; reflexivity. rewrite {}/f /= (bigID (fun i => Pr P (F i) != 0)) /=. -rewrite [in X in _ + X = _]big1 ?addR0; last first. - move=> i; rewrite negbK => /eqP ->; rewrite big1 // => r _; by rewrite mulR0. +rewrite [in X in _ + X = _]big1 ?addr0; last first. + by move=> i; rewrite negbK => /eqP ->; rewrite big1 // => r _; rewrite mulr0. transitivity (\sum_(i in I | Pr P (F i) != 0) \sum_(j <- fin_img X) (j * Pr P (finset (X @^-1 j) :&: F i))). - apply eq_bigr => i Fi0; apply eq_bigr => r _. - by rewrite -!mulRA mulVR // mulR1. -rewrite -Ex_altE /Ex_alt exchange_big /=; apply eq_bigr => r _. + apply: eq_bigr => i Fi0; apply eq_bigr => r _. + by rewrite -mulrA mulVf ?mulr1. +rewrite -Ex_altE /Ex_alt exchange_big /=; apply: eq_bigr => r _. rewrite -big_distrr /=; congr (_ * _). transitivity (\sum_(i in I) Pr P (finset (X @^-1 r) :&: F i)). rewrite big_mkcond /=; apply eq_bigr => i _. @@ -977,29 +986,30 @@ End conditional_expectation_prop. (** *** A theory of indicator functions from [A : finType] to [R] *) Section Ind. +Context {R : realType}. Variable A : finType. -Definition Ind (s : {set A}) (x : A) : R := if x \in s then R1 else R0. +Definition Ind (s : {set A}) (x : A) : R := if x \in s then 1 else 0. Lemma Ind_set0 (x : A) : Ind set0 x = 0. Proof. by rewrite /Ind inE. Qed. -Lemma Ind_inP (s : {set A}) (x : A) : reflect (Ind s x = R1) (x \in s). +Lemma Ind_inP (s : {set A}) (x : A) : reflect (Ind s x = 1) (x \in s). Proof. apply: (iffP idP); rewrite /Ind; first by move->. -by case: ifP =>//; auto with real. +by case: ifPn => // _ /eqP; rewrite eq_sym oner_eq0. Qed. -Lemma Ind_notinP (s : {set A}) (x : A) : reflect (Ind s x = R0) (x \notin s). +Lemma Ind_notinP (s : {set A}) (x : A) : reflect (Ind s x = 0) (x \notin s). Proof. apply: (iffP idP); rewrite /Ind => Hmain. by rewrite ifF //; exact: negbTE. -by apply: negbT; case: ifP Hmain =>// _ H10; exfalso; auto with real. +by apply: negbT; case: ifP Hmain =>// _ /eqP; rewrite oner_eq0. Qed. Lemma Ind_cap (S1 S2 : {set A}) (x : A) : Ind (S1 :&: S2) x = Ind S1 x * Ind S2 x. -Proof. by rewrite /Ind inE; case: in_mem; case: in_mem=>/=; ring. Qed. +Proof. by rewrite /Ind inE; case: in_mem; case: in_mem=>/=; lra. Qed. Lemma Ind_bigcap I (e : I -> {set A}) (r : seq.seq I) (p : pred I) x : Ind (\bigcap_(j <- r | p j) e j) x = \prod_(j <- r | p j) (Ind (e j) x). @@ -1009,11 +1019,11 @@ apply (big_ind2 (R1 := {set A}) (R2 := R)); last by []. - by move=> sa a sb b Ha Hb; rewrite -Ha -Hb; apply: Ind_cap. Qed. -Lemma E_Ind (P : {fdist A}) s : `E (Ind s : {RV P -> R}) = Pr P s. +Lemma E_Ind (P : R.-fdist A) s : `E (Ind s : {RV P -> R}) = Pr P s. Proof. rewrite /Ex /Ind /Pr (bigID (mem s)) /=. -rewrite [X in _ + X = _]big1; last by move=> i /negbTE ->; rewrite mul0R. -by rewrite addR0; apply: eq_bigr => i ->; rewrite mul1R. +rewrite [X in _ + X = _]big1; last by move=> i /negbTE ->; rewrite mul0r. +by rewrite addr0; apply: eq_bigr => i ->; rewrite mul1r. Qed. End Ind. @@ -1022,54 +1032,56 @@ End Ind. contributed by Erik Martin-Dorel: the corresponding theorem is named [Pr_bigcup_incl_excl] and is more general than lemma [Pr_bigcup]. *) Section probability_inclusion_exclusion. +Context {R : realType}. Variables (A : finType) (P : R.-fdist A). -Let SumIndCap (n : nat) (S : 'I_n -> {set A}) (k : nat) (x : A) := +Let SumIndCap (n : nat) (S : 'I_n -> {set A}) (k : nat) (x : A) : R := \sum_(J in {set 'I_n} | #|J| == k) (Ind (\bigcap_(j in J) S j) x). Lemma Ind_bigcup_incl_excl (n : nat) (S : 'I_n -> {set A}) (x : A) : Ind (\bigcup_(i < n) S i) x = - (\sum_(1 <= k < n.+1) (-1) ^ (k - 1) * SumIndCap S k x). + (\sum_(1 <= k < n.+1) (-1) ^+ (k - 1) * SumIndCap S k x). Proof. case: n S => [|n] S; first by rewrite big_ord0 big_geq // Ind_set0. set Efull := \bigcup_(i < n.+1) S i. -have Halg : \prod_(i < n.+1) (Ind Efull x - Ind (S i) x) = 0. +have Halg : \prod_(i < n.+1) (Ind Efull x - Ind (S i) x) = 0 :> R. case Ex : (x \in Efull); last first. { have /Ind_notinP Ex0 := Ex. erewrite eq_bigr. (* to replace later with under *) 2: by rewrite Ex0. - have Ex00 : forall i : 'I_n.+1, Ind (S i) x = 0. + have Ex00 : forall i : 'I_n.+1, Ind (S i) x = 0 :> R. move=> i; apply/Ind_notinP. by move/negbT: Ex; rewrite -!in_setC setC_bigcup; move/bigcapP; apply. erewrite eq_bigr. (* to replace later with under *) 2: by move=> i _; rewrite Ex00. - rewrite subR0. - by apply/prodR_eq0; exists ord0. } + by rewrite subr0 big_ord_recl mul0r. } { rewrite /Efull in Ex. have /bigcupP [i Hi Hi0] := Ex. - apply/prodR_eq0; exists i =>//. - by rewrite /Efull (Ind_inP _ _ Ex) (Ind_inP _ _ Hi0) subRR. } + rewrite (bigD1 i)//= /Efull (Ind_inP _ _ Ex) (Ind_inP _ _ Hi0) subrr. + by rewrite mul0r. } rewrite bigA_distr in Halg. do [erewrite eq_bigr; last by move=> k _; (* to replace later with under *) erewrite eq_bigr; last by move=> J _; rewrite bigID2] in Halg. rewrite big_ltn //= in Halg. -rewrite -> addR_eq0 in Halg. +move/eqP in Halg. +rewrite addr_eq0 in Halg. rewrite cardT size_enum_ord (big_pred1 set0) in Halg; last first. by move=> i; rewrite pred1E [RHS]eq_sym; apply: cards_eq0. +move/eqP in Halg. rewrite [in X in _ * X = _]big_pred0 in Halg; last by move=> i; rewrite inE. do [erewrite eq_bigl; (* to replace later with under *) last by move=> j; rewrite !inE /negb /= ] in Halg. -rewrite mulR1 -Ind_bigcap big_const_ord iterSr iter_fix setIT ?setIid // in Halg. -rewrite {}Halg big_morph_oppR big_nat [RHS]big_nat. +rewrite mulr1 -Ind_bigcap big_const_ord iterSr iter_fix setIT ?setIid // in Halg. +rewrite {}Halg big_morph_oppr big_nat [RHS]big_nat. apply: eq_bigr => i Hi; rewrite /SumIndCap /Efull. rewrite m1powD; last first. by case/andP: Hi => Hi _ K0; rewrite K0 in Hi. -rewrite mulNR. -rewrite [in RHS](big_morph _ (morph_mulRDr _) (mulR0 _)). -congr Ropp; apply: eq_bigr => j Hj. -rewrite prodRN (eqP Hj). -rewrite (_ : ?[a] * ((-1)^i * ?[b]) = (-1)^i * (?a * ?b)); last by ring. -congr Rmult. +rewrite mulNr. +rewrite [in RHS](big_morph _ (morph_mulRDr _) (mulr0 _)). +congr -%R; apply: eq_bigr => j Hj. +rewrite prodrN (eqP Hj). +rewrite (_ : ?[a] * ((-1)^+i * ?[b]) = (-1)^+i * (?a * ?b)); last by lra. +congr *%R. have [Hlt|Hn1] := ltnP i n.+1; last first. { rewrite big1; last first. { move=> k Hk; rewrite inE in Hk. @@ -1077,7 +1089,7 @@ have [Hlt|Hn1] := ltnP i n.+1; last first. apply/setP/subset_cardP =>//. rewrite (eqP Hj) cardsT /= card_ord. by apply/anti_leq/andP; split; first by case/andP: Hi =>//. } - by rewrite mul1R Ind_bigcap. } + by rewrite mul1r Ind_bigcap. } rewrite -!Ind_bigcap big_const. rewrite cardsCs card_ord setCK (eqP Hj). have [m ->] : exists m, (n.+1 - i)%nat = m.+1. @@ -1108,7 +1120,7 @@ Qed. Theorem Pr_bigcup_incl_excl n (S : 'I_n -> {set A}) : Pr P (\bigcup_(i < n) S i) = - \sum_(1 <= k < n.+1) ((-1)^(k-1) * SumPrCap S k). + \sum_(1 <= k < n.+1) ((-1)^+(k-1) * SumPrCap S k). Proof. rewrite -E_Ind /=. rewrite /Ex. @@ -1125,25 +1137,28 @@ Qed. End probability_inclusion_exclusion. Section markov_inequality. -Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U) (X : {RV P -> R}). Hypothesis X_ge0 : forall u, 0 <= X u. Lemma Ex_lb (r : R) : r * `Pr[ X >= r] <= `E X. Proof. -rewrite /Ex (bigID [pred a' | (X a' >= r)%mcR]) /= -[a in a <= _]addR0. -apply leR_add; last first. - by apply/RleP/sumr_ge0 => a _; rewrite mulr_ge0//; exact/RleP/X_ge0. -apply (@leR_trans (\sum_(i | (X i >= r)%mcR) r * P i)). - by rewrite big_distrr /=; apply/Req_le/eq_bigl => a; rewrite inE. -by apply leR_sumR => u Xur; apply/leR_wpmul2r => //; exact/RleP. +rewrite /Ex (bigID [pred a' | (X a' >= r)%mcR]) /= -[a in a <= _]addr0. +rewrite lerD//; last first. + by apply/sumr_ge0 => a _; rewrite mulr_ge0//; exact/RleP/X_ge0. +apply (@le_trans _ _ (\sum_(i | (X i >= r)%mcR) r * P i)). + rewrite big_distrr /= le_eqVlt; apply/orP; left; apply/eqP. + by apply/eq_bigl => a; rewrite inE. +by apply: ler_sum => u Xur; exact/ler_wpM2r. Qed. Lemma markov (r : R) : 0 < r -> `Pr[ X >= r ] <= `E X / r. -Proof. by move=> r0; rewrite leR_pdivl_mulr // mulRC; exact/Ex_lb. Qed. +Proof. by move=> r0; rewrite ler_pdivlMr // mulrC; exact/Ex_lb. Qed. End markov_inequality. Section thm61. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (X : {RV P -> R}) (phi : R -> R). Lemma Ex_comp_RV : `E (phi `o X) = \sum_(r <- fin_img X) phi r * `Pr[ X = r ]. @@ -1159,6 +1174,7 @@ Qed. End thm61. Section variance_def. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (X : {RV P -> R}). (* Variance of a random variable (\sigma^2(X) = V(X) = E (X^2) - (E X)^2): *) @@ -1166,75 +1182,77 @@ Definition Var := let miu := `E X in `E ((X `-cst miu) `^2). (* Alternative form for computing the variance (V(X) = E(X^2) - E(X)^2 \cite[Theorem 6.6]{probook}): *) -Lemma VarE : Var = `E (X `^2) - (`E X) ^ 2. +Lemma VarE : Var = `E (X `^2) - (`E X) ^+ 2. Proof. -rewrite /Var E_trans_RV_id_rem E_trans_add_RV E_sub_RV E_scalel_RV; field. +by rewrite /Var E_trans_RV_id_rem E_trans_add_RV E_sub_RV E_scalel_RV; lra. Qed. End variance_def. -Arguments Var {U} _ _. +Arguments Var {R U} _ _. -Notation "'`V'" := (@Var _ _) : proba_scope. +Notation "'`V'" := (@Var _ _ _) : proba_scope. Section variance_prop. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (X : {RV P -> R}). (* The variance is not linear V (k X) = k^2 V (X) \cite[Theorem 6.7]{probook}: *) -Lemma Var_scale k : `V (k `cst* X) = k ^ 2 * `V X. +Lemma Var_scale k : `V (k `cst* X) = k ^+ 2 * `V X. Proof. rewrite {1}/`V [in X in X = _]/= E_scalel_RV. pose Y : {RV P -> R} := k `cst* (X `+cst - `E X). -rewrite (@E_comp_RV_ext _ P ((k `cst* X) `-cst k * `E X) Y) //; last first. +rewrite (@E_comp_RV_ext _ _ P ((k `cst* X) `-cst k * `E X) Y) //; last first. rewrite boolp.funeqE => /= x. - by rewrite /Y /scalel_RV /= /trans_min_RV /trans_add_RV; field. -by rewrite E_comp_RV ?E_scalel_RV // => *; field. + by rewrite /Y /scalel_RV /= /trans_min_RV /trans_add_RV; lra. +by rewrite E_comp_RV ?E_scalel_RV // => *; lra. Qed. Lemma Var_trans m : `V (X `+cst m) = `V X. Proof. rewrite /Var E_trans_add_RV; congr (`E (_ `^2)). -rewrite boolp.funeqE => /= u; rewrite /trans_add_RV /trans_min_RV /=; field. +by rewrite boolp.funeqE => /= u; rewrite /trans_add_RV /trans_min_RV /=; lra. Qed. End variance_prop. -Lemma Var_cast_RV_fdist_rV1 (A : finType) (P : {fdist A}) (X : {RV P -> R}) : - `V (@cast_RV_fdist_rV1 _ P _ X) = `V X. +Lemma Var_cast_RV_fdist_rV1 {R : realType} (A : finType) (P : R.-fdist A) (X : {RV P -> R}) : + `V (@cast_RV_fdist_rV1 _ _ P _ X) = `V X. Proof. rewrite !VarE !E_cast_RV_fdist_rV1; congr (_ - _). -apply: big_rV_1 => // v; by rewrite fdist_rV1. +by apply: big_rV_1 => // v; rewrite fdist_rV1. Qed. (* (Probabilistic statement.) In any data sample, "nearly all" the values are "close to" the mean value: Pr[ |X - E X| \geq \epsilon] \leq V(X) / \epsilon^2 *) Section chebyshev. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (X : {RV P -> R}). +Import Num.Def. + Lemma chebyshev_inequality epsilon : 0 < epsilon -> - `Pr[ (Rabs `o (X `-cst `E X)) >= epsilon] <= `V X / epsilon ^ 2. + `Pr[ (normr `o (X `-cst `E X)) >= epsilon] <= `V X / epsilon ^+ 2. Proof. -move=> He; rewrite leR_pdivl_mulr; last exact/expR_gt0. -rewrite mulRC /Var. -apply (@leR_trans (\sum_(a in U | (`| X a - `E X | >= epsilon)%mcR) +move=> He; rewrite ler_pdivlMr ?exprn_gt0//. +rewrite mulrC /Var. +apply (@le_trans _ _ (\sum_(a in U | (`| X a - `E X | >= epsilon)%mcR) (((X `-cst `E X) `^2) a * P a))); last first. - apply leR_sumRl_support with (Q := xpredT) => // a . - by apply mulR_ge0 => //; exact: sq_RV_ge0. -rewrite /Pr big_distrr. -rewrite [_ ^2]lock /= -!lock. -apply leR_sumRl => u; rewrite ?inE => Hu //=. -- rewrite -!/(_ ^ 2). - apply leR_wpmul2r => //. - apply (@leR_trans ((X u - `E X) ^ 2)); last by apply/RleP; rewrite lexx. - rewrite -(sqR_norm (X u - `E X)). - by apply/pow_incr; split => //; [exact/ltRW | exact/RleP]. -- by apply mulR_ge0 => //; exact: sq_RV_ge0. + rewrite /Ex big_mkcondr/=; apply: ler_sum => a _; case: ifPn => // _. + by apply mulr_ge0 => //; exact: sq_RV_ge0. +rewrite /Pr big_distrr/= [_ ^+ 2]lock /= -!lock big_mkcond/= [leRHS]big_mkcond/=. +apply: ler_sum => u _; rewrite inE/=; case: ifPn => //. +rewrite -!/(_ ^+ 2) => H. +apply: ler_wpM2r => //=. +apply (@le_trans _ _ ((X u - `E X) ^+ 2)); last by rewrite lexx. +by rewrite -real_normK ?num_real// -[leRHS]real_normK ?num_real// ler_sqr// gtr0_norm. Qed. End chebyshev. Section independent_events. +Context {R : realType}. Variables (A : finType) (d : R.-fdist A). Definition inde_events (E F : {set A}) := Pr d (E :&: F) = Pr d E * Pr d F. @@ -1243,18 +1261,20 @@ Lemma inde_events_cplt (E F : {set A}) : inde_events E F -> inde_events E (~: F). Proof. rewrite /inde_events => EF; have : Pr d E = Pr d (E :&: F) + Pr d (E :&: ~:F). - rewrite (total_prob d E (fun b => if b then F else ~:F)) /=; last 2 first. + rewrite (@total_prob _ _ d _ E (fun b => if b then F else ~:F)) /=; last 2 first. move=> i j ij; rewrite -setI_eq0. by case: ifPn ij => Hi; case: ifPn => //= Hj _; rewrite ?setICr // setIC setICr. by rewrite cover_imset big_bool /= setUC setUCr. - by rewrite big_bool addRC. -by rewrite addRC -subR_eq EF -{1}(mulR1 (Pr d E)) -mulRBr -Pr_setC. + by rewrite big_bool addrC. +move=> /eqP. +by rewrite addrC -subr_eq EF -{1}(mulr1 (Pr d E)) -mulrBr -Pr_setC => /eqP. Qed. End independent_events. Section k_wise_independence. +Context {R : realType}. Variables (A I : finType) (k : nat) (d : R.-fdist A) (E : I -> {set A}). Definition kwise_inde := forall (J : {set I}), (#|J| <= k)%nat -> @@ -1263,9 +1283,10 @@ Definition kwise_inde := forall (J : {set I}), (#|J| <= k)%nat -> End k_wise_independence. Section pairwise_independence. +Context {R : realType}. Variables (A I : finType) (d : R.-fdist A) (E : I -> {set A}). -Definition pairwise_inde := @kwise_inde A I 2%nat d E. +Definition pairwise_inde := @kwise_inde R A I 2%nat d E. Lemma pairwise_indeE : pairwise_inde <-> (forall i j, i != j -> inde_events d (E i) (E j)). @@ -1290,9 +1311,10 @@ Qed. End pairwise_independence. Section mutual_independence. +Context {R : realType}. Variables (A I : finType) (d : R.-fdist A) (E : I -> {set A}). -Definition mutual_inde := (forall k, @kwise_inde A I k.+1 d E). +Definition mutual_inde := (forall k, @kwise_inde R A I k.+1 d E). Lemma mutual_indeE : mutual_inde <-> (forall J : {set I}, J \subset I -> @@ -1318,6 +1340,7 @@ Qed. End mutual_independence. Section conditional_probablity. +Context {R : realType}. Variables (A : finType) (d : R.-fdist A). Implicit Types E F : {set A}. @@ -1327,15 +1350,17 @@ Local Notation "`Pr_[ E | F ]" := (cPr E F). Lemma cPr_ge0 E F : 0 <= `Pr_[E | F]. Proof. rewrite /cPr; have [PF0|PF0] := eqVneq (Pr d F) 0. - by rewrite setIC (Pr_domin_setI _ PF0) div0R. -by apply divR_ge0 => //; rewrite Pr_gt0P. + by rewrite setIC (Pr_domin_setI _ PF0) mul0r. +by apply divr_ge0 => //; rewrite Pr_gt0P. Qed. Local Hint Resolve cPr_ge0 : core. Lemma cPr_eq0P E F : `Pr_[E | F] = 0 <-> Pr d (E :&: F) = 0. Proof. -split; rewrite /cPr; last by move=> ->; rewrite div0R. -rewrite /cPr /Rdiv mulR_eq0 => -[//|/invR_eq0]. +split; rewrite /cPr; last by move=> ->; rewrite mul0r. +move=> /eqP. +rewrite /cPr mulf_eq0 => -/predU1P[//|]. +rewrite invr_eq0 => /eqP. by rewrite setIC; exact: Pr_domin_setI. Qed. @@ -1343,70 +1368,70 @@ Lemma cPr_le1 E F : `Pr_[E | F] <= 1. Proof. rewrite /cPr. have [PF0|PF0] := eqVneq (Pr d F) 0. - by rewrite setIC (Pr_domin_setI E PF0) div0R. -apply leR_pdivr_mulr; first by rewrite Pr_gt0P. -rewrite mul1R /Pr; apply leR_sumRl => //. - by move=> a _; apply/RleP; rewrite lexx. -by move=> a; rewrite inE => /andP[]. + by rewrite setIC (Pr_domin_setI E PF0) mul0r. +rewrite ler_pdivrMr//; last by rewrite Pr_gt0P. +rewrite mul1r /Pr big_mkcond/= [leRHS]big_mkcond/=. +apply: ler_sum => // a _; rewrite inE. +have [aF|aF] := boolP (a \in F). + rewrite andbT. + by case: ifPn. +by rewrite andbF. Qed. Lemma cPrET E : `Pr_[E | setT] = Pr d E. -Proof. by rewrite /cPr setIT Pr_setT divR1. Qed. +Proof. by rewrite /cPr setIT Pr_setT divr1. Qed. Lemma cPrE0 E : `Pr_[E | set0] = 0. -Proof. by rewrite /cPr setI0 Pr_set0 div0R. Qed. +Proof. by rewrite /cPr setI0 Pr_set0 mul0r. Qed. Lemma cPr_gt0P E F : 0 < `Pr_[E | F] <-> `Pr_[E | F] != 0. -Proof. -split; rewrite /cPr; first by rewrite ltR_neqAle => -[/eqP H1 _]; rewrite eq_sym. -by rewrite ltR_neqAle eq_sym => /eqP H; split => //; exact: cPr_ge0. -Qed. +Proof. by rewrite lt_neqAle cPr_ge0 andbT eq_sym. Qed. Lemma Pr_cPr_gt0 E F : 0 < Pr d (E :&: F) <-> 0 < `Pr_[E | F]. Proof. rewrite Pr_gt0P; split => H; last first. - by move/cPr_gt0P : H; apply: contra => /eqP; rewrite /cPr => ->; rewrite div0R. -rewrite /cPr; apply/divR_gt0; rewrite Pr_gt0P //. + by move/cPr_gt0P : H; apply: contra => /eqP; rewrite /cPr => ->; rewrite mul0r. +rewrite /cPr; apply/divr_gt0; rewrite Pr_gt0P //. by apply: contra H; rewrite setIC => /eqP F0; apply/eqP/Pr_domin_setI. Qed. Lemma cPr_setD F1 F2 E : `Pr_[F1 :\: F2 | E] = `Pr_[F1 | E] - `Pr_[F1 :&: F2 | E]. -Proof. by rewrite /cPr -divRBl setIDAC Pr_setD setIAC. Qed. +Proof. by rewrite /cPr -mulrBl setIDAC Pr_setD setIAC. Qed. Lemma cPr_setU F1 F2 E : `Pr_[F1 :|: F2 | E] = `Pr_[F1 | E] + `Pr_[F2 | E] - `Pr_[F1 :&: F2 | E]. -Proof. by rewrite /cPr -divRDl -divRBl setIUl Pr_setU setIACA setIid. Qed. +Proof. by rewrite /cPr -mulrDl -mulrBl setIUl Pr_setU setIACA setIid. Qed. Lemma Bayes E F : `Pr_[E | F] = `Pr_[F | E] * Pr d E / Pr d F. Proof. have [PE0|PE0] := eqVneq (Pr d E) 0. - by rewrite /cPr [in RHS]setIC !(Pr_domin_setI F PE0) !(div0R,mul0R). -by rewrite /cPr -mulRA mulVR // mulR1 setIC. + by rewrite /cPr [in RHS]setIC !(Pr_domin_setI F PE0) !mul0r. +by rewrite /cPr setIC -(mulrA _ _ (Pr d E)) mulVf// mulr1. Qed. Lemma product_rule E F : Pr d (E :&: F) = `Pr_[E | F] * Pr d F. Proof. rewrite /cPr; have [PF0|PF0] := eqVneq (Pr d F) 0. - by rewrite setIC (Pr_domin_setI E PF0) div0R mul0R. -by rewrite -mulRA mulVR ?mulR1. + by rewrite setIC (Pr_domin_setI E PF0) 2!mul0r. +by rewrite -mulrA mulVf ?mulr1. Qed. Lemma product_rule_cond E F G : `Pr_[E :&: F | G] = `Pr_[E | F :&: G] * `Pr_[F | G]. -Proof. by rewrite /cPr mulRA -setIA {1}product_rule. Qed. +Proof. by rewrite /cPr mulrA -setIA {1}product_rule. Qed. Lemma cPr_cplt E F : Pr d E != 0 -> `Pr_[ ~: F | E] = 1 - `Pr_[F | E]. Proof. -move=> PE0; rewrite /cPr -(divRR _ PE0) -divRBl; congr (_ / _). -apply/esym; rewrite subR_eq addRC. +move=> PE0; rewrite /cPr -(@divff _ (Pr d E))// -mulrBl; congr (_ / _). +apply/eqP; rewrite -subr_eq opprK addrC eq_sym. rewrite -{1}(@setIT _ E) -(setUCr F) setIC setIUl disjoint_Pr_setU //. by rewrite -setI_eq0 setIACA setICr set0I. Qed. Lemma inde_events_cPr E F : Pr d F != 0 -> inde_events d E F -> `Pr_[E | F] = Pr d E. -Proof. by move=> F0 EF; rewrite /cPr EF /Rdiv -mulRA mulRV ?mulR1. Qed. +Proof. by move=> F0 EF; rewrite /cPr EF -mulrA mulfV ?mulr1. Qed. Section bayes_extended. Variables (I : finType) (E : {set A}) (F : I -> {set A}). @@ -1416,7 +1441,7 @@ Hypothesis cov : cover (F @: I) = [set: A]. Lemma total_prob_cond : Pr d E = \sum_(i in I) `Pr_[E | F i] * Pr d (F i). Proof. -rewrite (total_prob _ _ _ dis cov); apply eq_bigr; move=> i _. +rewrite (@total_prob _ _ _ _ _ _ dis cov); apply eq_bigr; move=> i _. by rewrite product_rule. Qed. @@ -1424,11 +1449,11 @@ Lemma Bayes_extended j : `Pr_[F j | E] = `Pr_[E | F j] * Pr d (F j) / \sum_(i in I) `Pr_[E | F i] * Pr d (F i). Proof. have [PE0|PE0] := eqVneq (Pr d E) 0. - by rewrite {1 2}/cPr setIC (Pr_domin_setI (F j) PE0) !(div0R,mul0R). -rewrite -total_prob_cond /cPr -!mulRA; congr (_ / _). + by rewrite {1 2}/cPr setIC (Pr_domin_setI (F j) PE0) !mul0r. +rewrite -total_prob_cond /cPr -(mulrA _ _ (Pr _ (F j))); congr (_ / _). have [Fj0|Fj0] := eqVneq (Pr d (F j)) 0. - by rewrite Fj0 !mulR0 (Pr_domin_setI E Fj0). -by rewrite setIC mulVR ?mulR1. + by rewrite Fj0 !mulr0 (Pr_domin_setI E Fj0). +by rewrite setIC mulVf ?mulr1. Qed. End bayes_extended. @@ -1449,31 +1474,33 @@ Notation cPr_diff := cPr_setD (only parsing). Notation cPr_union_eq := cPr_setU (only parsing). Section fdist_cond. +Context {R : realType}. Variables (A : finType) (P : R.-fdist A) (E : {set A}). Hypothesis E0 : Pr P E != 0. Let f := [ffun a => `Pr_P [[set a] | E]]. -Let f0 a : (0 <= f a)%O. Proof. by apply/RleP; rewrite ffunE. Qed. +Let f0 a : (0 <= f a)%O. Proof. by rewrite ffunE. Qed. Let f1 : \sum_(a in A) f a = 1. Proof. rewrite /f. under eq_bigr do rewrite ffunE. -rewrite /cPr -big_distrl /= -divRE eqR_divr_mulr // mul1R. -rewrite (total_prob P E (fun i => [set i])); last 2 first. +rewrite /cPr -big_distrl /= eqr_divr_mulr // mul1r. +rewrite (@total_prob _ _ P _ E (fun i => [set i])); last 2 first. move=> i j ij; rewrite -setI_eq0; apply/eqP/setP => // a. by rewrite !inE; apply/negbTE; apply: contra ij => /andP[/eqP ->]. apply/setP => // a; rewrite !inE; apply/bigcupP. by exists [set a]; rewrite ?inE //; apply/imsetP; exists a. -by apply eq_bigr => a _; rewrite setIC. +by apply: eq_bigr => a _; rewrite setIC. Qed. -Definition fdist_cond : {fdist A} := locked (FDist.make f0 f1). +Definition fdist_cond : R.-fdist A := locked (FDist.make f0 f1). End fdist_cond. Section fdist_cond_prop. +Context {R : realType}. Variables (A : finType) (P : R.-fdist A) (E : {set A}). Hypothesis E0 : Pr P E != 0. @@ -1496,32 +1523,32 @@ Qed. End fdist_cond_prop. -Lemma Pr_fdistX (A B : finType) (P : {fdist A * B}) (E : {set A}) (F : {set B}) : +Lemma Pr_fdistX {R : realType} (A B : finType) (P : R.-fdist (A * B)) (E : {set A}) (F : {set B}) : Pr (fdistX P) (F `* E) = Pr P (E `* F). Proof. rewrite /Pr !big_setX exchange_big /=; apply eq_bigr => b _. by apply eq_bigr => a _; rewrite fdistXE. Qed. -Lemma Pr_fdistA (A B C : finType) (P : {fdist A * B * C}) E F G : +Lemma Pr_fdistA {R : realType} (A B C : finType) (P : R.-fdist (A * B * C)) E F G : Pr (fdistA P) (E `* (F `* G)) = Pr P (E `* F `* G). Proof. -rewrite /fdistA (@Pr_fdistmap _ _ (@prodA A B C))// ?imsetA//. +rewrite /fdistA (@Pr_fdistmap _ _ _ (@prodA A B C))// ?imsetA//. exact: inj_prodA. Qed. -Lemma Pr_fdistC12 (A B C : finType) (P : {fdist A * B * C}) E F G : +Lemma Pr_fdistC12 {R : realType} (A B C : finType) (P : R.-fdist (A * B * C)) E F G : Pr (fdistC12 P) (E `* F `* G) = Pr P (F `* E `* G). Proof. rewrite /Pr !big_setX /= exchange_big; apply eq_bigr => a aF. by apply eq_bigr => b bE; apply eq_bigr => c cG; rewrite fdistC12E. Qed. -Lemma Pr_fdistAC (A B C : finType) (P : {fdist A * B * C}) E F G : +Lemma Pr_fdistAC {R : realType} (A B C : finType) (P : R.-fdist (A * B * C)) E F G : Pr (fdistAC P) (E `* G `* F) = Pr P (E `* F `* G). Proof. by rewrite /fdistAC Pr_fdistX Pr_fdistA Pr_fdistC12. Qed. -Lemma Pr_fdist_proj23_domin (A B C : finType) (P : {fdist A * B * C})E F G : +Lemma Pr_fdist_proj23_domin {R : realType} (A B C : finType) (P : R.-fdist (A * B * C)) E F G : Pr (fdist_proj23 P) (F `* G) = 0 -> Pr P (E `* F `* G) = 0. Proof. move/Pr_set0P => H; apply/Pr_set0P => -[[? ?] ?]. @@ -1530,6 +1557,7 @@ by apply/fdist_proj23_domin/H; rewrite inE /= bF cG. Qed. Section conditionally_independent_events. +Context {R : realType}. Variables (A : finType) (d : R.-fdist A). Definition cinde_events (E F G : {set A}) := @@ -1542,9 +1570,9 @@ split=> [|[|FG0]]; rewrite /cinde_events. - rewrite product_rule_cond => H. have [/cPr_eq0P EG0|EG0] := eqVneq (`Pr_d[F | G]) 0. by rewrite /cPr EG0; right. - by left; move/eqR_mul2r : H ; apply; apply/eqP. + by left; move: H => /mulIf; apply. - by rewrite product_rule_cond => ->. -- by rewrite /cPr -setIA setIC Pr_domin_setI // div0R FG0 div0R mulR0. +- by rewrite /cPr -setIA setIC Pr_domin_setI // !mul0r FG0 mul0r mulr0. Qed. Lemma cinde_events_unit (E F : {set A}) : inde_events d E F <-> @@ -1554,6 +1582,7 @@ Proof. by split; rewrite /cinde_events /inde_events !cPrET. Qed. End conditionally_independent_events. Section crandom_variable_eqType. +Context {R : realType}. Variables (U : finType) (A B : eqType) (P : R.-fdist U). Definition cPr_eq (X : {RV P -> A}) (a : A) (Y : {RV P -> B}) (b : B) := @@ -1572,12 +1601,13 @@ Notation cpr_eq0 := cPr_eq (only parsing). #[deprecated(since="infotheo 0.7.2", note="renamed to `cPr_eq_def`")] Notation cpr_eqE' := cPr_eq_def (only parsing). -Lemma cpr_eq_unit_RV (U : finType) (A : eqType) (P : {fdist U}) +(* TODO: sect *) +Lemma cpr_eq_unit_RV {R : realType} (U : finType) (A : eqType) (P : R.-fdist U) (X : {RV P -> A}) (a : A) : `Pr[ X = a | (unit_RV P) = tt ] = `Pr[ X = a ]. Proof. by rewrite cPr_eq_def cPrET pr_eqE. Qed. -Lemma cpr_eqE (U : finType) (P : {fdist U}) (TA TB : eqType) +Lemma cpr_eqE {R : realType} (U : finType) (P : R.-fdist U) (TA TB : eqType) (X : {RV P -> TA}) (Y : {RV P -> TB}) a b : `Pr[ X = a | Y = b ] = `Pr[ [% X, Y] = (a, b) ] / `Pr[Y = b]. Proof. @@ -1586,6 +1616,7 @@ by apply/setP => u; rewrite !inE xpair_eqE. Qed. Section crandom_variable_finType. +Context {R : realType}. Variables (U A B : finType) (P : R.-fdist U). Implicit Types X : {RV P -> A}. @@ -1610,7 +1641,7 @@ Notation "`Pr[ X '\in' E | Y = b ]" := Notation "`Pr[ X = a | Y '\in' F ]" := (`Pr[ X \in [set a] | Y \in F]) : proba_scope. -Lemma cpr_in_unit_RV (U A : finType) (P : {fdist U}) (X : {RV P -> A}) +Lemma cpr_in_unit_RV {R : realType} (U A : finType) (P : R.-fdist U) (X : {RV P -> A}) (E : {set A}) : `Pr[ X \in E | (unit_RV P) = tt ] = `Pr[ X \in E ]. Proof. @@ -1619,7 +1650,7 @@ rewrite cpr_eq_setE (_ : _ @^-1: [set tt] = setT); last first. by rewrite cPrET pr_eq_setE. Qed. -Lemma cpr_inE (U : finType) (P : {fdist U}) (A B : finType) +Lemma cpr_inE {R : realType} (U : finType) (P : R.-fdist U) (A B : finType) (X : {RV P -> A}) (Z : {RV P -> B}) E F : `Pr[X \in E | Z \in F] = `Pr[ [%X, Z] \in E `* F] / `Pr[Z \in F]. Proof. @@ -1628,7 +1659,7 @@ rewrite !pr_eq_setE /cPr; congr (Pr _ _ * _). by apply/setP => u; rewrite !inE. Qed. -Lemma cpr_inE' (U : finType) (P : {fdist U}) (A B : finType) +Lemma cpr_inE' {R : realType} (U : finType) (P : R.-fdist U) (A B : finType) (X : {RV P -> A}) (Y : {RV P -> B}) (E : {set A}) (F : {set B}) : `Pr[ X \in E | Y \in F ] = `Pr_(`p_ [% X, Y]) [E `*T | T`* F]. Proof. @@ -1639,6 +1670,7 @@ by rewrite setTE Pr_fdistmap_RV2; congr Pr; apply/setP => u; rewrite !inE. Qed. Section cpr_pair. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (A B C D : finType) (TA TB TC TD : eqType). Variables (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}) (W : {RV P -> D}). Variables (TX : {RV P -> TA}) (TY : {RV P -> TB}) (TZ : {RV P -> TC}) (TW : {RV P -> TD}). @@ -1755,7 +1787,7 @@ Qed. End cpr_pair. -Lemma cpr_eq_product_rule (U : finType) (P : {fdist U}) (A B C : eqType) +Lemma cpr_eq_product_rule {R : realType} (U : finType) (P : R.-fdist U) (A B C : eqType) (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}) a b c : `Pr[ [% X, Y] = (a, b) | Z = c ] = `Pr[ X = a | [% Y, Z] = (b, c) ] * `Pr[ Y = b | Z = c ]. @@ -1769,7 +1801,7 @@ rewrite product_rule_cond cPr_eq_def; congr (cPr _ _ _ * _). - by rewrite cPr_eq_def. Qed. -Lemma reasoning_by_cases (U : finType) (P : {fdist U}) +Lemma reasoning_by_cases {R : realType} (U : finType) (P : R.-fdist U) (A B : finType) (X : {RV P -> A}) (Y : {RV P -> B}) E : `Pr[ X \in E ] = \sum_(b <- fin_img Y) `Pr[ [% X, Y] \in (E `* [set b])]. Proof. @@ -1785,13 +1817,13 @@ rewrite partition_disjoint_bigcup /=; last first. apply/esym; set F := BIG_F. transitivity (\sum_(b in B) F b). rewrite [in RHS](bigID (mem (fin_img Y))) /=. - rewrite [X in _ = _ + X]big1 ?addR0 //. + rewrite [X in _ = _ + X]big1 ?addr0 //. by rewrite big_uniq // undup_uniq. by move=> b bY; rewrite {}/F pr_in_pairC pr_in_domin_RV2 // pr_eq_set1 pr_eq0. by apply eq_bigr => b _; rewrite /F pr_eq_setE /Pr partition_big_preimset. Qed. -Lemma creasoning_by_cases (U : finType) (P : {fdist U}) +Lemma creasoning_by_cases {R : realType} (U : finType) (P : R.-fdist U) (A B C : finType) (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}) E F : `Pr[ X \in E | Z \in F ] = \sum_(b <- fin_img Y) `Pr[ [% X, Y] \in (E `* [set b]) | Z \in F]. Proof. @@ -1801,6 +1833,7 @@ by apply eq_bigr => b _; rewrite pr_in_pairAC. Qed. Section conditionnally_independent_discrete_random_variables. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (A B C : eqType). Variables (X : {RV P -> A}) (Y : {RV P -> B}) (Z : {RV P -> C}). @@ -1819,10 +1852,11 @@ Qed. End conditionnally_independent_discrete_random_variables. -Notation "P |= X _|_ Y | Z" := (@cinde_rv _ P _ _ _ X Y Z) : proba_scope. +Notation "P |= X _|_ Y | Z" := (@cinde_rv _ _ P _ _ _ X Y Z) : proba_scope. Notation "X _|_ Y | Z" := (cinde_rv X Y Z) : proba_scope. Section independent_rv. +Context {R : realType}. Variables (A : finType) (P : R.-fdist A) (TA TB : eqType). Variables (X : {RV P -> TA}) (Y : {RV P -> TB}). @@ -1845,22 +1879,25 @@ Qed. End independent_rv. -Notation "P |= X _|_ Y" := (@inde_rv _ P _ _ X Y) : proba_scope. +Notation "P |= X _|_ Y" := (@inde_rv _ _ P _ _ X Y) : proba_scope. -Lemma cinde_alt (U : finType) (P : {fdist U}) (A B C : finType) (X : {RV P -> A}) (Y : {RV P -> B}) {Z : {RV P -> C}} a b c : +Lemma cinde_alt {R : realType} (U : finType) (P : R.-fdist U) (A B C : finType) (X : {RV P -> A}) (Y : {RV P -> B}) {Z : {RV P -> C}} a b c : P |= X _|_ Y | Z -> `Pr[ [% Y, Z] = (b, c)] != 0 -> `Pr[ X = a | [% Y, Z] = (b, c)] = `Pr[X = a | Z = c]. Proof. -move=> K /eqP H0. -rewrite [in LHS]cpr_eqE -(eqR_mul2r H0) -mulRA mulVR ?mulR1; last by apply/eqP. -have H1 : / (`Pr[ Z = c ]) <> 0. - by apply invR_neq0; rewrite pr_eq_pairC in H0; move/(pr_eq_domin_RV2 Y b). -by rewrite pr_eq_pairA -(eqR_mul2r H1) -mulRA -!divRE -!cpr_eqE K. +move=> K H0. +rewrite [in LHS]cpr_eqE; apply: (@mulIf _ _ H0). +rewrite -mulrA mulVf ?mulr1//. +have H1 : (`Pr[ Z = c ])^-1 != 0. + apply invr_neq0; rewrite pr_eq_pairC in H0. + by apply: contra H0 => /eqP/(pr_eq_domin_RV2 Y b)/eqP. +rewrite pr_eq_pairA; apply: (@mulIf _ _ H1). +by rewrite -mulrA -!cpr_eqE K. Qed. Section sum_two_rand_var_def. - +Context {R : realType}. Variables (A : finType) (n : nat). Variables (X : 'rV[A]_n.+2 -> R) (X1 : A -> R) (X2 : 'rV[A]_n.+1 -> R). @@ -1873,10 +1910,10 @@ End sum_two_rand_var_def. Notation "Z \= X '@+' Y" := (sum_2 Z X Y) : proba_scope. Section sum_two_rand_var. - +Context {R : realType}. Local Open Scope vec_ext_scope. -Variables (A : finType) (n : nat) (P : {fdist 'rV[A]_n.+2}) (X : {RV P -> R}). +Variables (A : finType) (n : nat) (P : R.-fdist 'rV[A]_n.+2) (X : {RV P -> R}). Let P1 := head_of_fdist_rV P. Let P2 := tail_of_fdist_rV P. Variables (X1 : {RV P1 -> R}) (X2 : {RV P2 -> R}). @@ -1888,7 +1925,7 @@ Lemma E_sum_2 : X \= X1 @+ X2 -> `E X = `E X1 + `E X2. Proof. move=> Hsum; transitivity (\sum_(ta in 'rV[A]_n.+2) (X1 (ta ``_ ord0) * P ta + X2 (rbehead ta) * P ta)). - by apply eq_bigr => ta _; rewrite Hsum mulRDl. + by apply eq_bigr => ta _; rewrite Hsum mulrDl. rewrite big_split => //=; congr (_ + _). - transitivity (\sum_(a in A) (X1 a * \sum_(ta in 'rV_n.+1) (fdist_prod_of_rV P (a, ta)))). @@ -1913,10 +1950,10 @@ move=> Hsum Hinde. rewrite -!Ex_altE. apply trans_eq with (\sum_(r <- undup (map X1 (enum A))) \sum_(r' <- undup (map X2 (enum ('rV[A]_n.+1)))) - ( r * r' * @pr_eq _ _ P1 X1 r * @pr_eq _ _ P2 X2 r')); last first. + ( r * r' * @pr_eq _ _ _ P1 X1 r * @pr_eq _ _ _ P2 X2 r')); last first. rewrite [in RHS]big_distrl /=; apply eq_bigr => i _. rewrite big_distrr /=; apply eq_bigr => j _. - by rewrite -!mulRA [in RHS](mulRCA _ j). + by rewrite -!mulrA [in RHS](mulrCA _ j). rewrite -(big_rV_cons_behead _ xpredT xpredT) /=. apply trans_eq with (\sum_(a in A) \sum_(j in 'rV[A]_n.+1) (X1 a * X2 j * P (row_mx (\row_(k < 1) a) j))). @@ -1935,7 +1972,7 @@ apply trans_eq with (r * r' * \sum_(i0 | X2 i0 == r') \sum_(i1 | X1 i1 == r) rewrite big_distrr /=; apply eq_bigr => a a_l. move/eqP : ta_r' => <-. by move/eqP : a_l => <-. -rewrite -[RHS]mulRA; congr (_ * _). +rewrite -[RHS]mulrA; congr (_ * _). rewrite exchange_big /=. have {}Hinde := Hinde r r'. have -> : `Pr[ X1 = r ] = `Pr[ X1' = r ]. @@ -1959,29 +1996,29 @@ Proof. move=> Hsum Hinde. rewrite -![in RHS]Ex_altE. transitivity (\sum_(i in 'rV_n.+2) - ((X1 (i ``_ ord0) + X2 (rbehead i)) ^ 2%N * P i)). + ((X1 (i ``_ ord0) + X2 (rbehead i)) ^+ 2%N * P i)). apply eq_bigr => i _; rewrite /sq_RV /=. by rewrite /comp_RV Hsum. -transitivity (\sum_(i in 'rV_n.+2) ((X1 (i ``_ ord0)) ^ 2 + - 2 * X1 (i ``_ ord0) * X2 (rbehead i) + (X2 (rbehead i)) ^ 2) * P i). - apply eq_bigr => ? _; by rewrite sqrRD. -transitivity (\sum_(i in 'rV_n.+2) ((X1 (i ``_ ord0)) ^ 2 * P i + 2 * - X1 (i ``_ ord0) * X2 (rbehead i) * P i + (X2 (rbehead i)) ^ 2 * P i)). - apply eq_bigr => ? ?; by field. +transitivity (\sum_(i in 'rV_n.+2) ((X1 (i ``_ ord0)) ^+ 2 + + 2 * X1 (i ``_ ord0) * X2 (rbehead i) + (X2 (rbehead i)) ^+ 2) * P i). + by apply eq_bigr => ? _; rewrite sqrrD -mulrA mulr_natl. +transitivity (\sum_(i in 'rV_n.+2) ((X1 (i ``_ ord0)) ^+ 2 * P i + 2 * + X1 (i ``_ ord0) * X2 (rbehead i) * P i + (X2 (rbehead i)) ^+ 2 * P i)). + by apply eq_bigr => ? ?; lra. rewrite !big_split /=; congr (_ + _ + _). - rewrite Ex_altE -(big_rV_cons_behead _ xpredT xpredT) /=. apply eq_bigr => i _. - transitivity (X1 i ^ 2 * \sum_(j in 'rV_n.+1) (fdist_prod_of_rV P) (i, j)). + transitivity (X1 i ^+ 2 * \sum_(j in 'rV_n.+1) (fdist_prod_of_rV P) (i, j)). + rewrite big_distrr /=; apply eq_bigr => i0 _. by rewrite row_mx_row_ord0 fdist_prod_of_rVE. + by rewrite fdist_fstE. -- rewrite -mulRA. +- rewrite -mulrA. rewrite !Ex_altE. rewrite -E_id_rem_helper // big_distrr /=. - apply eq_bigr => i _; field. + by apply eq_bigr => i _; lra. - rewrite Ex_altE -(big_rV_cons_behead _ xpredT xpredT) exchange_big /=. apply eq_bigr => t _. - transitivity (X2 t ^ 2 * \sum_(i in A) (fdist_prod_of_rV P) (i, t)). + transitivity (X2 t ^+ 2 * \sum_(i in A) (fdist_prod_of_rV P) (i, t)). + rewrite big_distrr /=; apply eq_bigr => i _. by rewrite rbehead_row_mx fdist_prod_of_rVE. + by congr (_ * _); rewrite fdist_sndE. @@ -1990,8 +2027,8 @@ Qed. Lemma V_sum_2 : X \= X1 @+ X2 -> P |= X1' _|_ X2' -> `V X = `V X1 + `V X2. Proof. -move=> H ?; rewrite !VarE E_id_rem // (E_sum_2 H) sqrRD. -by rewrite /Ex /= -/P1 -/P2; field. +move=> H ?; rewrite !VarE E_id_rem // (E_sum_2 H) sqrrD. +by rewrite /Ex /= -/P1 -/P2; lra. Qed. End sum_two_rand_var. @@ -1999,6 +2036,7 @@ End sum_two_rand_var. Section expected_value_of_the_product. Section thm64. +Context {R : realType}. Variables (A B : finType) (P : R.-fdist (A * B)). Variables (X : {RV (P`1) -> R}) (Y : {RV (P`2) -> R}). @@ -2024,7 +2062,7 @@ transitivity (\sum_(x <- fin_img X) \sum_(y <- fin_img Y) transitivity (\sum_(x <- fin_img X) \sum_(y <- fin_img Y) x * y * `Pr[ X = x ] * `Pr[ Y = y ]). apply eq_bigr => x _; apply eq_bigr => y _. - rewrite -!mulRA. + rewrite -!mulrA. have {}Hinde := Hinde x y. congr (_ * (_ * _)). transitivity (`Pr[ X' = x ] * `Pr[ Y' = y ]); last first. @@ -2037,7 +2075,7 @@ transitivity (\sum_(x <- fin_img X) \sum_(y <- fin_img Y) rewrite -!Ex_altE. rewrite /Ex_alt big_distrl; apply eq_bigr => x _ /=; rewrite big_distrr /=. apply eq_bigr=> y _. -by rewrite -!mulRA; congr (_ * _); rewrite mulRCA. +by rewrite -!mulrA; congr (_ * _); rewrite mulrCA. Qed. End thm64. @@ -2045,6 +2083,7 @@ End thm64. End expected_value_of_the_product. Section sum_n_rand_var_def. +Context {R : realType}. Variables (A : finType) (P : R.-fdist A). Inductive sum_n : forall n, {RV (P `^ n) -> R} -> 'rV[{RV P -> R}]_n -> Prop := @@ -2058,6 +2097,7 @@ End sum_n_rand_var_def. Notation "X '\=sum' Xs" := (sum_n X Xs) : proba_scope. Section independent_rv_lemma. +Context {R : realType}. Variables (A B : finType) (P1 : R.-fdist A) (P2 : R.-fdist B) (TA TB : eqType). Variable (X : {RV P1 -> TA}) (Y : {RV P2 -> TB}). Let P := P1 `x P2. @@ -2078,14 +2118,14 @@ Qed. End independent_rv_lemma. Local Open Scope vec_ext_scope. -Lemma prod_dist_inde_rv_vec (A : finType) (P : {fdist A}) +Lemma prod_dist_inde_rv_vec {R : realType} (A : finType) (P : R.-fdist A) n (X : A -> R) (Y : {RV (P `^ n) -> R}) x y : `Pr[ ([% (fun v => X v ``_ ord0) : {RV (P`^n.+1) -> _}, (fun v => Y (rbehead v) : _ )]) = (x, y) ] = `Pr[ ((fun v => X v ``_ ord0) : {RV (P`^n.+1) -> _}) = x ] * `Pr[ ((fun v => Y (rbehead v)) : {RV (P`^n.+1) -> _}) = y ]. Proof. -have /= := @prod_dist_inde_rv _ _ P (P `^ n) _ _ X Y x y. +have /= := @prod_dist_inde_rv _ _ _ P (P `^ n) _ _ X Y x y. rewrite !pr_eqE -!fdist_prod_of_fdist_rV. rewrite (_ : [set x0 | _] = (finset (X @^-1 x)) `* (finset (Y @^-1 y))); last first. by apply/setP => -[a b]; rewrite !inE /= xpair_eqE. @@ -2103,6 +2143,7 @@ Qed. Local Close Scope vec_ext_scope. Section sum_n_rand_var. +Context {R : realType}. Variable (A : finType) (P : R.-fdist A). Local Open Scope vec_ext_scope. @@ -2113,13 +2154,13 @@ Proof. elim => [Xs Xbar | [_ Xs Xbar | n IHn Xs Xbar] ]. - by inversion 1. - inversion 1; subst. - apply Eqdep_dec.inj_pair2_eq_dec in H0; last exact eq_nat_dec. - apply Eqdep_dec.inj_pair2_eq_dec in H1; last exact eq_nat_dec. + apply Eqdep_dec.inj_pair2_eq_dec in H0; last exact Peano_dec.eq_nat_dec. + apply Eqdep_dec.inj_pair2_eq_dec in H1; last exact Peano_dec.eq_nat_dec. subst Xs Xbar. - by rewrite big_ord_recl big_ord0 addR0 E_cast_RV_fdist_rV1. + by rewrite big_ord_recl big_ord0 addr0 E_cast_RV_fdist_rV1. - inversion 1; subst. - apply Eqdep_dec.inj_pair2_eq_dec in H1; last exact eq_nat_dec. - apply Eqdep_dec.inj_pair2_eq_dec in H2; last exact eq_nat_dec. + apply Eqdep_dec.inj_pair2_eq_dec in H1; last exact Peano_dec.eq_nat_dec. + apply Eqdep_dec.inj_pair2_eq_dec in H2; last exact Peano_dec.eq_nat_dec. subst Z Xs. rewrite big_ord_recl. rewrite [X in _ = _ + X](_ : _ = \sum_(i < n.+1) `E (Xs0 ``_ i)); last first. @@ -2140,17 +2181,17 @@ elim=> [X Xs X_Xs sigma2 Hsigma2|]. by inversion X_Xs. case=> [_ | n IH] Xsum Xs Hsum s Hs. - inversion Hsum. - apply Eqdep_dec.inj_pair2_eq_dec in H; last exact eq_nat_dec. - apply Eqdep_dec.inj_pair2_eq_dec in H0; last exact eq_nat_dec. + apply Eqdep_dec.inj_pair2_eq_dec in H; last exact Peano_dec.eq_nat_dec. + apply Eqdep_dec.inj_pair2_eq_dec in H0; last exact Peano_dec.eq_nat_dec. subst Xs Xsum. - by rewrite Var_cast_RV_fdist_rV1 mul1R. + by rewrite Var_cast_RV_fdist_rV1 mul1r. - move: Hsum; inversion 1. - apply Eqdep_dec.inj_pair2_eq_dec in H0; last exact eq_nat_dec. - apply Eqdep_dec.inj_pair2_eq_dec in H1; last exact eq_nat_dec. + apply Eqdep_dec.inj_pair2_eq_dec in H0; last exact Peano_dec.eq_nat_dec. + apply Eqdep_dec.inj_pair2_eq_dec in H1; last exact Peano_dec.eq_nat_dec. subst Z n0 Xs. move: {IH}(IH Y _ H2) => IH. - rewrite S_INR mulRDl -IH. - + rewrite mul1R addRC (V_sum_2 H3) //; last exact: prod_dist_inde_rv_vec. + rewrite -[in RHS](add2n n) mulrDl -IH. + + rewrite mul1r (V_sum_2 H3) //; last exact: prod_dist_inde_rv_vec. by rewrite -(Hs ord0) /= row_mx_row_ord0 // head_of_fdist_rV_fdist_rV tail_of_fdist_rV_fdist_rV. + move=> i; rewrite -(Hs (lift ord0 i)). congr (`V _). @@ -2163,12 +2204,15 @@ Lemma Var_average n (X : {RV (P `^ n) -> R}) Xs (sum_Xs : X \=sum Xs) : n%:R * `V (X `/ n) = sigma2. Proof. move=> s Hs; destruct n; first by inversion sum_Xs. -by rewrite (Var_scale X) // (V_sum_n sum_Xs Hs) //; field; exact/INR_eq0. +rewrite (Var_scale X) // (V_sum_n sum_Xs Hs) //. +rewrite div1r mulrCA (mulrA _ _ s) -expr2. +by rewrite exprVn mulrA mulVf ?mul1r// sqrf_eq0 pnatr_eq0. Qed. End sum_n_rand_var. Section weak_law_of_large_numbers. +Context {R : realType}. Local Open Scope vec_ext_scope. Variables (A : finType) (P : R.-fdist A) (n : nat). @@ -2180,26 +2224,31 @@ Hypothesis V_Xs : forall i, `V (Xs ``_ i) = sigma2. Variable X : {RV (P `^ n.+1) -> R}. Variable X_Xs : X \=sum Xs. +Import Num.Def. + Lemma wlln epsilon : 0 < epsilon -> - `Pr[ (Rabs `o ((X `/ n.+1) `-cst miu)) >= epsilon ] <= - sigma2 / (n.+1%:R * epsilon ^ 2). + `Pr[ (normr `o ((X `/ n.+1) `-cst miu)) >= epsilon ] <= + sigma2 / (n.+1%:R * epsilon ^+ 2). Proof. move=> e0. -rewrite divRM ?INR_eq0' //; last exact/gtR_eqF/expR_gt0. +rewrite invfM//. +rewrite mulrA. have <- : `V (X `/ n.+1) = sigma2 / n.+1%:R. - by rewrite -(Var_average X_Xs V_Xs) Var_scale //; field; exact/INR_eq0. + rewrite -(Var_average X_Xs V_Xs) Var_scale // mul1r. + by rewrite [RHS]mulrC (mulrA _ n.+1%:R) mulVf ?pnatr_eq0// mul1r. have <- : `E (X `/ n.+1) = miu. rewrite E_scalel_RV (E_sum_n X_Xs). - rewrite div1R mulRC eqR_divr_mulr ?INR_eq0' // (eq_bigr (fun=> miu)) //. - by rewrite big_const /= iter_addR cardE /= size_enum_ord mulRC. -move/leR_trans: (chebyshev_inequality (X `/ n.+1) e0); apply. -by apply/RleP; rewrite lexx. + rewrite mul1r mulrC eqr_divr_mulr ?pnatr_eq0// (eq_bigr (fun=> miu)) //. + by rewrite big_const /= iter_addr cardE /= size_enum_ord addr0 mulr_natr. +move/le_trans: (chebyshev_inequality (X `/ n.+1) e0); apply. +by rewrite lexx. Qed. End weak_law_of_large_numbers. (* wip*) Section vector_of_RVs. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U). Variables (A : finType) (n : nat) (X : 'rV[{RV P -> A}]_n). Local Open Scope ring_scope. @@ -2208,6 +2257,7 @@ Definition RVn : {RV P -> 'rV[A]_n} := fun x => \row_(i < n) (X ``_ i) x. End vector_of_RVs. Section prob_chain_rule. +Context {R : realType}. Variables (U : finType) (P : R.-fdist U) (A : finType). Local Open Scope vec_ext_scope. @@ -2221,7 +2271,7 @@ Lemma prob_chain_rule : forall (n : nat) (X : 'rV[{RV P -> A}]_n.+1) x, (RVn (row_drop (inord (n - i.+1)) X)) = (row_drop (inord (n - i.+1)) x) ]. Proof. elim => [X /= x|n ih X /= x]. - rewrite big_ord_recl big_ord0 mulR1. + rewrite big_ord_recl big_ord0 mulr1. rewrite /pr_eq; unlock. apply eq_bigl => u. rewrite !inE /RVn. diff --git a/probability/variation_dist.v b/probability/variation_dist.v index 7ea25065..eff63800 100644 --- a/probability/variation_dist.v +++ b/probability/variation_dist.v @@ -1,9 +1,8 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum. -Require Import Reals. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext Ranalysis_ext logb fdist ln_facts. +From mathcomp Require Import reals. +Require Import fdist. (******************************************************************************) (* The Variation Distance *) @@ -19,37 +18,38 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. +Local Open Scope ring_scope. Local Open Scope fdist_scope. -Import Num.Theory. +Import GRing.Theory Num.Theory. Section variation_distance. +Context {R : realType}. Variable A : finType. -Definition var_dist (P Q : {fdist A}) := \sum_(a : A) `| P a - Q a |. +Definition var_dist (P Q : R.-fdist A) := \sum_(a : A) `| P a - Q a |. Local Notation "'d(' P ',' Q ')' " := (var_dist P Q). Lemma symmetric_var_dist p q : d(p , q) = d(q , p). -Proof. rewrite /var_dist; apply eq_bigr => ? _; by rewrite distRC. Qed. +Proof. rewrite /var_dist; apply eq_bigr => ? _; by rewrite distrC. Qed. Lemma pos_var_dist p q : 0 <= d(p , q). -Proof. by apply/RleP/sumr_ge0 => ? _; apply/RleP/normR_ge0. Qed. +Proof. by apply/sumr_ge0 => ? _; apply/normr_ge0. Qed. Lemma def_var_dist p q : d( p , q) = 0 -> p = q. Proof. rewrite /var_dist => H; apply/fdist_ext => a. -rewrite -subR_eq0; apply/normR0_eq0; move: H. -rewrite (bigD1 a) //= paddR_eq0 => [[] // | | ]; first exact/normR_ge0. -by apply/RleP/sumr_ge0 => ? _; apply/RleP/normR_ge0. +apply/eqP; rewrite -subr_eq0; apply/eqP/normr0_eq0; move: H. +move/eqP; rewrite (bigD1 a) //= paddr_eq0 //; first by case/andP=> /eqP->. +by apply/sumr_ge0 => ? _; apply/normr_ge0. Qed. -Lemma leq_var_dist (p q : {fdist A}) x : `| p x - q x | <= d( p , q ). +Lemma leq_var_dist (p q : R.-fdist A) x : `| p x - q x | <= d( p , q ). Proof. -rewrite /var_dist (bigD1 x) //= -{1}(addR0 `| p x - q x |). -by apply/leR_add2l/RleP/sumr_ge0 => ? _; apply/RleP/normR_ge0. +rewrite /var_dist (bigD1 x) //= -{1}(addr0 `| p x - q x |). +by rewrite lerD2l sumr_ge0. Qed. End variation_distance. diff --git a/robust/robustmean.v b/robust/robustmean.v index 146d8708..c47b758b 100644 --- a/robust/robustmean.v +++ b/robust/robustmean.v @@ -1,15 +1,16 @@ -From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. +From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp Require Import lra ring. From mathcomp Require boolp. -From mathcomp Require Import Rstruct reals. -Require Import Reals Lra. -From infotheo Require Import ssrR Reals_ext realType_ext logb ssr_ext ssralg_ext. -From infotheo Require Import bigop_ext fdist proba. +From mathcomp Require Import mathcomp_extra Rstruct reals. +From infotheo Require Import ssr_ext ssralg_ext bigop_ext. +From infotheo Require Import realType_ext fdist proba. +From HB Require Import structures. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Local Open Scope R_scope. +Local Open Scope ring_scope. Local Open Scope reals_ext_scope. Local Open Scope fdist_scope. Local Open Scope proba_scope. @@ -27,11 +28,62 @@ Import Order.POrderTheory Order.Theory Num.Theory GRing.Theory. (* *) (******************************************************************************) -Definition mul_RV (U : finType) (P : {fdist U}) (X Y : {RV P -> R}) - : {RV P -> R} := fun x => X x * Y x. +(* TODO: define RV_ringType mimicking fct_ringType *) +Section mul_RV. +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U). +Definition mul_RV (X Y : {RV P -> R}) : {RV P -> R} := fun x => X x * Y x. Notation "X `* Y" := (mul_RV X Y) : proba_scope. Arguments mul_RV /. +Lemma mul_RVA : associative mul_RV. +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite mulrA. Qed. +Lemma mul_RVC : commutative mul_RV. +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite mulrC. Qed. +Lemma mul_RVAC : right_commutative mul_RV. +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite mulrAC. Qed. +Lemma mul_RVCA : left_commutative mul_RV. +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite mulrCA. Qed. +Lemma mul_RVACA : interchange mul_RV mul_RV. +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite mulrACA. Qed. +Lemma mul_RVDr : right_distributive mul_RV (@add_RV _ U P). +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite mulrDr. Qed. +Lemma mul_RVDl : left_distributive mul_RV (@add_RV _ U P). +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite mulrDl. Qed. +Lemma mul_RVBr (f g h : {RV (P) -> (R)}) : f `* (g `- h) = f `* g `- f `* h. +Proof. by apply: boolp.funext=> u /=; rewrite mulrBr. Qed. +Lemma mul_RVBl (f g h : {RV (P) -> (R)}) : (f `- g) `* h = f `* h `- g `* h. +Proof. by apply: boolp.funext=> u /=; rewrite mulrBl. Qed. +End mul_RV. +Notation "X `* Y" := (mul_RV X Y) : proba_scope. +Arguments mul_RV /. + +Section add_RV. +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U). +Arguments add_RV /. +Lemma add_RVA : associative (@add_RV _ U P). +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite addrA. Qed. +Lemma add_RVC : commutative (@add_RV _ U P). +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite addrC. Qed. +Lemma add_RVAC : right_commutative (@add_RV _ U P). +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite addrAC. Qed. +Lemma add_RVCA : left_commutative (@add_RV _ U P). +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite addrCA. Qed. +Lemma add_RVACA : interchange (@add_RV _ U P) (@add_RV _ U P). +Proof. by move=> *; apply: boolp.funext=> u /=; rewrite addrACA. Qed. +End add_RV. + +Section scalelr. +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U). +Lemma scalel_RVE m (X : {RV P -> R}) : scalel_RV m X = const_RV P m `* X. +Proof. by apply: boolp.funext=> ? /=; rewrite /scalel_RV /const_RV. Qed. +Lemma scaler_RVE m (X : {RV P -> R}) : scaler_RV X m = X `* const_RV P m. +Proof. by apply: boolp.funext=> ? /=; rewrite /scaler_RV /const_RV. Qed. +End scalelr. + + Section conj_intro_pattern. (* /[conj] by Cyril Cohen : *) (* https://coq.zulipchat.com/#narrow/stream/237664-math-comp-users/topic/how.20to.20combine.20two.20top.20assumptions.20with.20.60conj.60 *) @@ -41,7 +93,9 @@ End conj_intro_pattern. Notation "[conj]" := (ltac:(apply and_curry)) (only parsing) : ssripat_scope. Section RV_ring. -Variables (U : finType) (P : {fdist U}). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U). + (* Import topology.*) (* Lemma add_RV_addr (X Y : {RV P -> R}) : X `+ Y = (X + Y)%mcR. *) @@ -92,66 +146,67 @@ Proof. by move: H=> /[swap] /in_preim1 ->; rewrite eqxx. Qed. -Lemma Ind_subset (A : finType) (X Y : {set A}) : - X \subset Y <-> forall a, Ind X a <= Ind Y a. +Lemma Ind_subset {R : realType} (A : finType) (X Y : {set A}) : + X \subset Y <-> forall a, Ind X a <= Ind Y a :> R. Proof. rewrite /Ind; split => H. move=> a; case: ifPn. - - by move/(subsetP H) ->; apply/RleP. - - by case: (a \in Y) => _ //; apply/RleP. + - by move/subsetP ->. + - by case: (a \in Y). apply/subsetP => a aX. -by move: (H a); rewrite aX; case: (a \in Y) => //; move/RleP; rewrite ler10. +by move: (H a); rewrite aX; case: (a \in Y) => //; rewrite ler10. Qed. End sets_functions. Section probability. -Variables (U : finType) (P : {fdist U}). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U). Lemma sq_RVE (X : {RV P -> R}) : X `^2 = X `* X. -Proof. by rewrite /sq_RV/comp_RV/=; apply: boolp.funext => x; rewrite mulR1. Qed. +Proof. by []. Qed. -Lemma Ind_ge0 (X : {set U}) (x : U) : 0 <= Ind X x. -Proof. by rewrite /Ind; case: ifPn => // _; apply Rle_refl. Qed. +Lemma Ind_ge0 (X : {set U}) (x : U) : 0 <= Ind X x:> R. +Proof. by rewrite /Ind; case: ifPn. Qed. Lemma Ind_setD (X Y : {set U}) : Y \subset X -> Ind (X :\: Y) = Ind X `- Ind Y :> {RV P -> R}. Proof. move/subsetP=> YsubX; rewrite /Ind /sub_RV. apply boolp.funext => u /=. case: ifPn; rewrite inE ?negb_and; - first by case/andP => /negbTE -> ->; rewrite subR0. -case/orP; first by move => /negbNE /[dup] /YsubX -> ->; rewrite subRR. + first by case/andP => /negbTE -> ->; rewrite subr0. +case/orP; first by move => /negbNE /[dup] /YsubX -> ->; rewrite subrr. move/contraNN: (YsubX u) => YsubX'. move=> /[dup] /YsubX' /negbTE -> /negbTE ->. -by rewrite subRR. +by rewrite subrr. Qed. Lemma cEx_ExInd (X : {RV P -> R}) F : `E_[X | F] = `E (X `* Ind (A:=U) F : {RV P -> R}) / Pr P F. Proof. rewrite /Pr /cEx (* need some lemmas to avoid unfolds *) -big_distrl /=. -apply: congr2 => //. +apply: congr2=> //. under eq_bigr => i _. rewrite big_distrr. have -> : \sum_(i0 in finset (preim X (pred1 i)) :&: F) (i * P i0) = \sum_(i0 in finset (preim X (pred1 i)) :&: F) - (X i0 * @Ind U F i0 * P i0). + (X i0 * @Ind _ U F i0 * P i0). apply congr_big => // i0. rewrite in_setI /Ind => /andP[] /in_preim1 -> ->. - by rewrite !coqRE mulr1. + by rewrite mulr1. have H1 : \sum_(i0 in finset (preim X (pred1 i)) :\: F) X i0 * Ind F i0 * P i0 = 0. (* This should be true because all elements of the sum are 0 *) rewrite big1 // => i1. rewrite in_setD => /andP [H2 H3]. - by rewrite !coqRE /Ind (negbTE H2) mulr0 mul0r. + by rewrite /Ind (negbTE H2) mulr0 mul0r. have : \sum_(i0 in finset (preim X (pred1 i))) X i0 * Ind F i0 * P i0 = \sum_(i0 in finset (preim X (pred1 i)) :&: F) X i0 * Ind F i0 * P i0 + \sum_(i0 in finset (preim X (pred1 i)) :\: F) X i0 * Ind F i0 * P i0 by apply big_setID. - rewrite !coqRE H1 addr0 => <-. + rewrite H1 addr0 => <-. under eq_bigl do rewrite in_preim1'. by over. by rewrite -partition_big_fin_img. @@ -162,7 +217,7 @@ Proof. rewrite cEx_ExInd. congr (_ / _). rewrite /Ex /ambient_dist /Ind. -under eq_bigr => i _ do rewrite /mul_RV 2!fun_if if_arg mulR0 mul0R mulR1. +under eq_bigr do rewrite /mul_RV 2!fun_if if_arg mulr0 mul0r mulr1. rewrite [in RHS]big_mkcond /=. exact: eq_bigr. Qed. @@ -177,7 +232,8 @@ suff : `E ((a `cst* X `+ b `cst* Y) `^2) = by rewrite !E_add_RV !E_scalel_RV. apply eq_bigr => i H. unfold ambient_dist, "`cst*", "`+", "`^2", "`o", "^", "`*". -nra. +rewrite !expr2 /=. +lra. Qed. Lemma Ex_square_eq0 X : @@ -185,72 +241,62 @@ Lemma Ex_square_eq0 X : Proof. split=> [XP|EX20]. - rewrite /Ex big1// => u _. - have [|->] := XP u; last by rewrite mulR0. - by rewrite /sq_RV /comp_RV /= => ->; rewrite !mul0R. -- have XP : forall x, x \in U -> (X `^2: {RV P -> R}) x * P x = 0. - move=> x Ux. - apply: (psumr_eq0P _ EX20) => // i Ui. - rewrite mulr_ge0//. - apply/RleP. - by apply: sq_RV_ge0. - move=> x. - have := XP x. - rewrite inE => /(_ erefl) /mulR_eq0[|->]; last by right. - by rewrite /sq_RV /comp_RV /= mulR1 => /mulR_eq0[|] ->; left. + have [|->] := XP u; last by rewrite mulr0. + by rewrite sq_RVE /mul_RV=> ->; rewrite !mul0r. +- move=> x; rewrite !(rwP eqP); apply/orP. + rewrite -(sqrf_eq0 (X x)) (_ : _ ^+ 2 = (X `^2: {RV P -> R}) x) // -mulf_eq0. + have -> // := psumr_eq0P _ EX20 => *. + by rewrite mulr_ge0 // sq_RV_ge0. Qed. Lemma Cauchy_Schwarz_proba (X Y : {RV P -> R}): - Rsqr (`E (X `* Y : {RV P -> R})) <= `E (X `^2) * `E (Y `^2). + (`E (X `* Y : {RV P -> R})) ^+ 2 <= `E (X `^2) * `E (Y `^2). Proof. -pose a := sqrt (`E (Y `^2)). -pose b := sqrt (`E (X `^2)). -have ? : 0 <= `E (X `^2) by apply: Ex_ge0; exact: sq_RV_ge0. -have ? : 0 <= `E (Y `^2) by apply: Ex_ge0; exact: sq_RV_ge0. +pose a : R := Num.sqrt (`E (Y `^2)). +pose b : R := Num.sqrt (`E (X `^2)). +have EXge0 : 0 <= `E (X `^2) by exact/Ex_ge0/sq_RV_ge0. +have EYge0 : 0 <= `E (Y `^2) by exact/Ex_ge0/sq_RV_ge0. have H2ab : 2 * a * b * (b * a) = a * a * `E (X `^2) + b * b * `E (Y `^2). - rewrite -(Rsqr_sqrt (`E (X `^2)))//. - rewrite -(Rsqr_sqrt (`E (Y `^2)))//. - by rewrite -/a -/b /Rsqr; nra. -have [a0|a0] := Req_dec a 0. - apply sqrt_eq_0 in a0 => //. + by rewrite -(sqr_sqrtr EXge0) -/b -(sqr_sqrtr EYge0) -/a !expr2; lra. +have [|a0] := eqVneq a 0. + move/eqP; rewrite sqrtr_eq0. move/(conj EYge0)/andP/le_anti/esym=> a0. have HY : forall y, Y y = 0 \/ P y = 0 by apply/Ex_square_eq0/a0. have -> : `E (X `* Y: {RV P -> R}) = 0. apply/eqP. rewrite psumr_eq0. apply/allP => u _; rewrite inE /=. - by case : (HY u) => -> ; rewrite mulR0 ?mul0R. + by case: (HY u) => ->; rewrite ?mulr0 ?mul0r. move => u _; rewrite /= . - by case : (HY u) => -> ; rewrite mulR0 ?mul0R. - by rewrite Rsqr_0; apply/mulR_ge0. -have [b0|b0] := Req_dec b 0. (* todo: replace with eqVneq.. *) - apply sqrt_eq_0 in b0 => //. + by case : (HY u) => -> ; rewrite ?mulr0 ?mul0r. + by rewrite expr0n; exact/mulr_ge0. +have [|b0] := eqVneq b 0. + move/eqP; rewrite sqrtr_eq0. move/(conj EXge0)/andP/le_anti/esym=> b0. have HX : forall x, X x = 0 \/ P x = 0 by apply /Ex_square_eq0/b0. have -> : `E (X `* Y: {RV P -> R}) = 0. apply/eqP; rewrite psumr_eq0 /mul_RV; last first. - by move=> u _; case : (HX u) => -> ; rewrite ?mulR0 ?mul0R. + by move=> u _; case : (HX u) => -> ; rewrite ?mulr0 ?mul0r. apply/allP => u _; rewrite inE/=. - by case : (HX u) => -> ; rewrite ?mulR0 ?mul0R. - by rewrite Rsqr_0; apply/mulR_ge0. -have {}a0 : 0 < a (*removes a0 hypothesis and reuse it*) - by apply/ltR_neqAle; split; [exact/nesym|exact/sqrt_pos]. -have {}b0 : 0 < b - by apply/ltR_neqAle; split; [exact/nesym|exact/sqrt_pos]. -rewrite -(Rsqr_sqrt (_ * _)); last by apply/mulR_ge0. -rewrite sqrt_mult// -/a -/b. -apply: neg_pos_Rsqr_le. -- rewrite -(@leR_pmul2r (2 * a * b)); last first. - by apply mulR_gt0 => //; apply mulR_gt0. - rewrite -subR_ge0 mulNR subR_opp addRC mulRC H2ab. - rewrite (mulRC (`E (X `* Y))) -Ex_square_expansion. - by apply: Ex_ge0; exact: sq_RV_ge0. -- apply/(@leR_pmul2l (2 * a * b)); first by do 2 apply: mulR_gt0 => //. - apply/subR_ge0; rewrite H2ab -(Rmult_opp_opp b) -addR_opp -mulNR -mulRN. - by rewrite -Ex_square_expansion; apply: Ex_ge0; exact: sq_RV_ge0. + by case : (HX u) => -> ; rewrite ?mulr0 ?mul0r. + by rewrite expr0n; exact/mulr_ge0. +have {}a0 : 0 < a. (*removes a0 hypothesis and reuse it*) + by rewrite lt_neqAle eq_sym; apply/andP; split=> //; exact/sqrtr_ge0. +have {}b0 : 0 < b. + by rewrite lt_neqAle eq_sym; apply/andP; split=> //; exact/sqrtr_ge0. +rewrite -[leRHS]sqr_sqrtr ?mulr_ge0 // sqrtrM // -/a -/b. +rewrite -subr_le0 -oppr_ge0 opprB subr_sqr. +rewrite mulr_ge0 // -[X in _ + X]opprK subr_ge0 ?opprK. +- rewrite -(@ler_pM2l _ (2 * a * b)); last by do 2 apply: mulr_gt0 => //. + rewrite -subr_ge0 H2ab -2!mulNr -mulrN -(mulrNN a a) -Ex_square_expansion. + exact/Ex_ge0/sq_RV_ge0. +- rewrite -(@ler_pM2l _ (2 * a * b)); last by do 2 apply: mulr_gt0 => //. + rewrite -subr_ge0 -mulrN opprK H2ab -Ex_square_expansion. + exact/Ex_ge0/sq_RV_ge0. Qed. Lemma I_square F : Ind F = ((Ind F) `^2 : {RV P -> R}). Proof. rewrite sq_RVE boolp.funeqE /Ind /mul_RV => x. -by case: ifPn; rewrite ?mulR0 ?mulR1. +by case: ifPn; rewrite ?mulr0 ?mulr1. Qed. Lemma I_double (F : {set U}) : Ind F = (Ind F) `* (Ind F) :> {RV P -> R}. @@ -265,9 +311,9 @@ Lemma cEx_trans_min_RV (X : {RV P -> R}) m F : Pr P F != 0 -> Proof. move=> PF0. rewrite !cExE. -under eq_bigr do rewrite /trans_min_RV mulRDl. -rewrite big_split/= divRDl; congr (_ + _). -by rewrite -big_distrr/= -Rmult_div_assoc divRR ?mulR1. +under eq_bigr do rewrite /trans_min_RV mulrDl. +rewrite big_split/= mulrDl; congr (_ + _). +by rewrite -big_distrr /= -mulrA divff // mulr1. Qed. Lemma cEx_sub (X : {RV P -> R}) (F G: {set U}) : @@ -276,16 +322,15 @@ Lemma cEx_sub (X : {RV P -> R}) (F G: {set U}) : `| `E_[ X | F ] - `E_[X | G] | = `| `E ((X `-cst `E_[X | G]) `* Ind F : {RV P -> R}) | / Pr P F. Proof. -move=> /[dup] /Pr_gt0P PrPF_neq0 /invR_gt0 /ltRW PrPFV_ge0 FsubG. -rewrite divRE -(geR0_norm (/Pr P F)) // -normRM. -apply: congr1. -by rewrite -[RHS]cEx_ExInd cEx_trans_min_RV. +move=> PrPF_gt0 FsubG. +rewrite -[X in _ / X]ger0_norm ?ltW // -normf_div. +by rewrite -cEx_ExInd cEx_trans_min_RV // lt0r_neq0 // PrPF_gt0. Qed. Lemma Ex_cExT (X : {RV P -> R}) : `E X = `E_[X | [set: U]]. Proof. rewrite /cEx. -under eq_bigr do rewrite setIT Pr_setT divR1 -pr_eqE. +under eq_bigr do rewrite setIT Pr_setT divr1 -pr_eqE. (* The names of lemmas for Pr are inconsistent: some begin with "Pr" while others "pr" *) by rewrite -Ex_comp_RV; congr `E. @@ -299,112 +344,111 @@ Local Notation "`V_[ X | F ]" := (cVar X F). Lemma Var_cVarT (X : {RV P -> R}) : `V X = `V_[X | [set: U]]. Proof. by rewrite /cVar -!Ex_cExT. Qed. +Lemma cvariance_ge0 (X : {RV P -> R}) F : 0 <= `V_[X | F]. +Proof. +have [H|] := boolP (0 < Pr P F)%mcR; last first. + rewrite -leNgt. + have:= Pr_ge0 P F => /[conj] /andP /le_anti H. + rewrite /cVar /cEx; apply big_ind; [by []|exact: addr_ge0|move=> i _]. + by rewrite setIC Pr_domin_setI // mulr0 mul0r. +rewrite /cVar cEx_ExInd mulr_ge0 ?invr_ge0 ?(ltW H) //. +apply/Ex_ge0=> u /=. +by rewrite mulr_ge0 ?Ind_ge0 // sq_RV_ge0. +Qed. + +Lemma variance_ge0 (X : {RV P -> R}) : 0 <= `V X. +Proof. by have := cvariance_ge0 X setT; rewrite -Var_cVarT. Qed. + Lemma cEx_cVar (X : {RV P -> R}) (F G: {set U}) : 0 < Pr P F -> F \subset G -> let mu := `E_[X | G] in let var := `V_[X | G] in - `| `E_[ X | F ] - mu | <= sqrt (var * Pr P G / Pr P F ). -Proof. -move=> /[dup] /invR_gt0 /ltRW PrPFV_nneg /[dup] /invR_gt0 - PrPFV_pos /[dup] /Pr_gt0P PrPF_neq0 PrPF_pos - /[dup] /(subset_Pr P) /(ltR_leR_trans PrPF_pos) - /[dup] /Pr_gt0P PrPG_neq0 PrPG_pos FsubG mu var. + `| `E_[ X | F ] - mu | <= Num.sqrt (var * Pr P G / Pr P F ). +Proof. +move=> PrPF_pos. +move=> /[dup] /(subset_Pr P) /(lt_le_trans PrPF_pos)=> PrPG_pos. +move=> FsubG /=. +set mu:= `E_[X | G]. +set var:= `V_[X | G]. +have EG_ge0 : 0 <= `E (((X `-cst mu) `^2) `* Ind G). + by apply:Ex_ge0=>*; apply:mulr_ge0; [exact:sq_RV_ge0|exact:Ind_ge0]. +have EF_ge0 : 0 <= `E (((X `-cst mu) `^2) `* Ind F). + by apply:Ex_ge0=>*; apply:mulr_ge0; [exact:sq_RV_ge0|exact:Ind_ge0]. rewrite cEx_sub //. -pose y := sqrt (Ex P (((X `-cst mu) `^2) `* Ind F) * Ex P (Ind F)) / Pr P F. -apply leR_trans with (y := y). - rewrite divRE leR_pmul2r // -sqrt_Rsqr_abs. - apply sqrt_le_1_alt. - have -> : (X `-cst mu) `* Ind F = (X `-cst mu) `* Ind F `* Ind F. - by rewrite {1}I_double boolp.funeqE=> u; rewrite /mul_RV mulRA. - apply/(leR_trans (Cauchy_Schwarz_proba _ _))/leR_eqVlt; left. - congr (_ * _); congr (`E _); last by rewrite -I_square. - apply: boolp.funext => x/=. - rewrite [in RHS]I_square. - by rewrite /sq_RV/=/comp_RV/mul_RV !mulR1 -mulRA [in LHS](mulRC (Ind F x)) !mulRA. -rewrite /y divRE -(sqrt_Rsqr (/ Pr P F)) // -sqrt_mult_alt; last first. - move=> *; apply mulR_ge0; last by rewrite E_Ind. - by apply: Ex_ge0 => u; apply: mulR_ge0; [apply pow2_ge_0 | apply Ind_ge0]. -apply sqrt_le_1_alt. -rewrite /var /cVar -/mu cEx_ExInd !E_Ind /Rsqr. -rewrite mulRCA -!mulRA mulRV // mulR1 mulRC. -rewrite [X in _ * X / _]mulRC mulRV // mulR1 divRE. -apply leR_wpmul2r => //. -apply leR_sumR=> i iU. -rewrite -mulRA -[X in _ <= X]mulRA; apply leR_wpmul2l; first exact: sq_RV_ge0. -by apply leR_pmul => //; [exact: Ind_ge0 | move/Ind_subset: FsubG; apply | apply/RleP]. +pose y := Num.sqrt (Ex P (((X `-cst mu) `^2) `* Ind F) * Ex P (Ind F)) / Pr P F. +apply: (@le_trans _ _ y). + rewrite ler_pM2r ?invr_gt0 // -sqrtr_sqr. + apply: ler_wsqrtr. + rewrite [in leLHS]I_double mul_RVA. + apply/(le_trans (Cauchy_Schwarz_proba _ _)). + rewrite sq_RVE -![in leLHS]mul_RVA (mul_RVC (Ind F)) -![in leLHS]mul_RVA. + by rewrite -I_double !mul_RVA -I_square -sq_RVE le_refl. +rewrite /y /var /cVar -/mu cEx_ExInd. +rewrite -!mulrA !sqrtrM ?invr_ge0 ?(ltW PrPG_pos) //. +rewrite -[in leLHS](sqr_sqrtr (ltW PrPF_pos)) invfM !mulrA. +rewrite -!sqrtrV ?(@ltW _ _ 0) // ler_pM2r ?sqrtr_gt0 ?invr_gt0//. +rewrite E_Ind -![in leLHS]mulrA -[in leLHS]sqrtrM ?(@ltW _ _ 0) //. +rewrite mulfV ?lt0r_neq0 //. +rewrite -![in leRHS]mulrA -[in leRHS]sqrtrM ?invr_ge0 ?(@ltW _ _ 0) //. +rewrite mulVf ?lt0r_neq0 //. +rewrite !sqrtr1 !mulr1 ler_sqrt //. +apply: ler_sum=> u uU; rewrite ler_pM 1?mulr_ge0 ?sq_RV_ge0 ?Ind_ge0 //. +rewrite ler_pM ?sq_RV_ge0 ?Ind_ge0 //. +by have/Ind_subset := FsubG; apply. Qed. (*prove A1 and A3 for later use*) Lemma cEx_Var (X : {RV P -> R}) F : 0 < Pr P F -> - `| `E_[ X | F ] - `E X | <= sqrt (`V X / Pr P F ). + `| `E_[ X | F ] - `E X | <= Num.sqrt (`V X / Pr P F ). Proof. move=> H; rewrite Ex_cExT Var_cVarT. move: (@cEx_cVar X F [set: U] H) => /=. -by rewrite Pr_setT mulR1 subsetT; apply. +by rewrite Pr_setT mulr1 subsetT; apply. Qed. Lemma cEx_cptl (X: {RV P -> R}) F: 0 < Pr P F -> Pr P F < 1 -> `E_[X | F] * Pr P F + `E_[X | (~: F)] * Pr P (~: F) = `E X. Proof. - move => PrFgt0 PrFlt1. - repeat rewrite cEx_ExInd. - unfold Rdiv. - repeat rewrite big_distrl. - rewrite -big_split. - apply congr_big; auto. - move => i HiU. simpl. - unfold "`p_", Ind. - repeat rewrite -mulRA. - repeat rewrite mulVR. - repeat rewrite mulR1. - rewrite in_setC. - destruct (i \in F); simpl; lra. - all: apply Pr_gt0P; try rewrite Pr_setC; lra. +move => PrFgt0 PrFlt1. +rewrite !cEx_ExInd. +rewrite -!mulrA [in LHS]mulVf ?lt0r_neq0 //. +rewrite mulVf ?Pr_setC ?subr_eq0 1?eq_sym ?neq_lt ?PrFlt1 // !mulr1. +rewrite /Ex -big_split /=. +apply: eq_bigr=> i _. +rewrite /Ind inE. +by case: ifP=> _ /=; rewrite mulr1 mulr0 mul0r ?addr0 ?add0r. Qed. Lemma cEx_Inv_int (X: {RV P -> R}) F: 0 < Pr P F -> Pr P F < 1 -> Pr P F * (`E_[X | F] - `E X) = Pr P (~: F) * - (`E_[X | (~: F)] - `E X). Proof. - move => H H0. - rewrite mulRDr oppRD mulRDr oppRK mulRN mulRN. - repeat rewrite cEx_ExInd. - (repeat have ->: forall x y, x != 0 -> x * (y / x) = y - by move => x y Hz; rewrite mulRC -mulRA mulVR; last by []; rewrite mulR1); - try apply Pr_gt0P; try rewrite Pr_setC; try lra. - apply Rplus_eq_reg_r with (r:= Pr P F * `E X). - rewrite -addRA Rplus_opp_l addR0 -addRA addRC. - apply Rplus_eq_reg_r with (r:=`E (X `* Ind (~: F):{RV P -> R})). - rewrite -addRA Rplus_opp_l addR0 -big_split. - rewrite mulRDl -addRA mulNR Rplus_opp_l addR0 mul1R. - apply congr_big; auto. - move => i HiU. simpl. - unfold "`p_". - rewrite -mulRDl. - congr (_ * _). - rewrite /Ind/mul_RV in_setC. - elim (i \in F); simpl; lra. +move => H H0. +apply/eqP; rewrite -subr_eq0. +rewrite opprD opprK !mulrDr addrAC. +rewrite opprD !mulrN opprK addrA. +rewrite !(mulrC (Pr _ _)) cEx_cptl //. +rewrite Pr_setC mulrDr mulr1 opprD mulrN opprK !addrA. +by rewrite subrr add0r subrr. Qed. Lemma cEx_Inv' (X: {RV P -> R}) (F G : {set U}) : 0 < Pr P F -> F \subset G -> Pr P F < Pr P G -> `| `E_[X | F] - `E_[X | G]| = (Pr P (G :\: F)) / (Pr P F) * `| `E_[X | (G :\: F)] - `E_[X | G]|. Proof. -move=> PrPF_gt0 /[dup] /setIidPr GIFF FsubG /[dup] /(ltR_trans PrPF_gt0) - /[dup] /Pr_gt0P /invR_neq0' /eqP PrPG_neq0 PrPG_gt0 PrPF_PrPG. -have : 0 < Pr P (G :\: F) by rewrite Pr_setD subR_gt0 GIFF. +move=> PrPF_gt0 /[dup] /setIidPr GIFF FsubG /[dup] /(lt_trans PrPF_gt0) + /[dup] /Pr_gt0P /invr_neq0 PrPG_neq0 PrPG_gt0 PrPF_PrPG. +have : 0 < Pr P (G :\: F) by rewrite Pr_setD subr_gt0 GIFF. move => /[dup] /Pr_gt0P PrPGF_neq0 PrPGF_gt0. -rewrite !cEx_sub ?subsetDl // !divRE mulRCA. -rewrite Ind_setD//. -rewrite !coqRE mulrAC divff// mul1r -!coqRE. -rewrite (_ : _ `* (_ `- _) = (X `-cst `E_[X | G]) `* Ind G `- (X `-cst `E_[X | G]) `* Ind F); last first. (* TODO: use ring_RV *) - by rewrite /mul_RV/sub_RV; apply: boolp.funext => u /=; rewrite mulRBr. -rewrite E_sub_RV. -have -> : Ex P ((X `-cst `E_[X | G]) `* Ind G) = 0. - apply normR0_eq0. - by rewrite -(@eqR_mul2r (/ Pr P G)) // -divRE -cEx_sub // subRR normR0 mul0R. -by rewrite sub0R normRN. +rewrite !cEx_sub ?subsetDl // mulrCA. +rewrite Ind_setD // mulrAC divff// mul1r. +congr (_ / _); apply/eqP. +rewrite mul_RVBr E_sub_RV -subr_eq0 -normr_le0. +apply: le_trans; first exact: ler_dist_normD. +rewrite addrCA subrr addr0 normr_le0. +apply/eqP/normr0_eq0/(divIf (lt0r_neq0 PrPG_gt0)). +by rewrite mul0r -cEx_sub // subrr normr0. Qed. (* NB: not used *) @@ -413,245 +457,231 @@ Lemma cEx_Inv (X: {RV P -> R}) F : `| `E_[X | F] - `E X| = (1 - Pr P F) / Pr P F * `| `E_[X | (~: F)] - `E X|. Proof. move=> *; rewrite Ex_cExT -Pr_setC -setTD; apply cEx_Inv' => //. -apply ltR_neqAle; split; last by apply/subset_Pr/subsetT. -by apply/eqP; rewrite Pr_setT -Pr_lt1P. +by rewrite lt_neqAle subset_Pr // andbT Pr_setT -Pr_lt1P. Qed. -Lemma cvariance_ge0 (X : {RV P -> R}) F : 0 <= `V_[X | F]. -Proof. -have [/RltP H|] := boolP (0 < Pr P F)%mcR; last first. - rewrite -leNgt => /RleP. - move: (Pr_ge0 P F) => /[conj] /eqR_le H. - rewrite /cVar /cEx; apply big_ind; [exact/RleP|exact: addR_ge0|move=> i _]. - by rewrite setIC Pr_domin_setI // mulR0 divRE mul0R; exact/RleP. -rewrite /cVar cEx_ExInd /Ex /ambient_dist divRE big_distrl /=. -apply/RleP; apply: sumr_ge0 => u _; rewrite !coqRE mulr_ge0//; last first. - by rewrite invr_ge0; apply/RleP. -apply: mulr_ge0 => //; apply: mulr_ge0; first by apply/RleP; exact: sq_RV_ge0. -by rewrite /Ind; by case: ifPn. -Qed. - -Lemma variance_ge0 (X : {RV P -> R}) : 0 <= `V X. -Proof. by have := cvariance_ge0 X setT; rewrite -Var_cVarT. Qed. - -Lemma Ind_one F : Pr P F <> 0 -> `E_[Ind F : {RV P -> R} | F] = 1. +Lemma Ind_one F : Pr P F != 0 -> `E_[Ind F : {RV P -> R} | F] = 1. Proof. move=> F0; rewrite cEx_ExInd. have -> : Ind F `* Ind F = Ind F. - by move=> f; rewrite /mul_RV /Ind boolp.funeqE => u; case: ifPn; rewrite ?(mulR0,mulR1). -by rewrite E_Ind divRE mulRV//; exact/eqP. + by move=>*; rewrite /Ind boolp.funeqE=>? /=; case: ifPn; rewrite ?mulr0 ?mulr1. +by rewrite E_Ind mulrV // unitfE. Qed. Lemma cEx_add_RV (X Y : {RV (P) -> (R)}) F: `E_[(X `+ Y) | F] = `E_[X | F] + `E_[Y | F]. Proof. - rewrite !cEx_ExInd -mulRDl. - congr (_ * _). - rewrite -E_add_RV. +rewrite !cEx_ExInd -mulrDl. +congr (_ * _). +rewrite -E_add_RV. apply congr_big => // i HiU. - by rewrite /mul_RV mulRDl. + by rewrite /mul_RV mulrDl. Qed. Lemma cEx_sub_RV (X Y: {RV P -> R}) F: `E_[X `- Y | F] = `E_[X|F] - `E_[Y|F]. Proof. - rewrite !cEx_ExInd. - unfold Rminus. - rewrite -mulNR. - rewrite big_morph_oppR -mulRDl. - congr (_ * _). - rewrite -big_split /=. - apply eq_bigr => u _. - by rewrite -mulNR -mulRDl -mulNR -mulRDl. +rewrite !cEx_ExInd -mulrBl. +congr (_ * _). +by rewrite mul_RVBl E_sub_RV. Qed. Lemma cEx_const_RV (k : R) F: 0 < Pr P F -> `E_[(const_RV P k) | F] = k. Proof. - move => HPrPF. - by rewrite cEx_ExInd E_scalel_RV E_Ind /Rdiv -mulRA mulRV; [rewrite mulR1 | apply gtR_eqF]. +by move=> ?; rewrite cEx_ExInd E_scalel_RV E_Ind -mulrA mulfV ?mulr1 ?gt_eqF. Qed. +(* NB: It is pointless to retain both `*cst (scaler_RV) and `cst* (scalel_RV) + since R is commutative; moreover, the name scalel does not follow the + naming scheme of mathcomp (r in scaler should stand for rings). *) Lemma const_RC (X: {RV P -> R}) k: X `*cst k = k `cst* X. -Proof. - unfold "`*cst", "`cst*". - rewrite boolp.funeqE => x. - by rewrite mulRC. -Qed. +Proof. by rewrite boolp.funeqE => ?; exact: mulrC. Qed. Lemma cEx_scaler_RV (X : {RV (P) -> (R)}) (k : R) F: `E_[(X `*cst k) | F] = `E_[X | F] * k. Proof. - rewrite !cEx_ExInd mulRC mulRA. - congr (_ * _). - rewrite -E_scalel_RV const_RC. - apply eq_bigr => i _. - unfold "`cst*". - by rewrite mulRA. +rewrite !cEx_ExInd mul_RVAC mulrAC /Ex; congr (_ / _). +rewrite big_distrl /=. +by under [LHS]eq_bigr do rewrite /= mulrAC. Qed. Lemma cEx_scalel_RV (X : {RV (P) -> (R)}) (k : R) F: `E_[(k `cst* X) | F] = k * `E_[X | F]. -Proof. - by rewrite mulRC -cEx_scaler_RV const_RC. -Qed. +Proof. by rewrite mulrC -cEx_scaler_RV const_RC. Qed. Lemma cEx_trans_add_RV (X: {RV P -> R}) m F: -0 < Pr P F -> - `E_[X `+cst m | F] = `E_[X | F] + m. -Proof. - move => HPrPF_gt0. - have: `E_[const_RV P m | F] = m by apply cEx_const_RV. - move => HcExm. - by rewrite -{2}HcExm -cEx_add_RV. -Qed. + 0 < Pr P F -> `E_[X `+cst m | F] = `E_[X | F] + m. +Proof. by move=> ?; rewrite cEx_add_RV cEx_const_RV. Qed. Lemma cEx_trans_RV_id_rem (X: {RV P -> R}) m F: - `E_[(X `-cst m) `^2 | F] = `E_[((X `^2 `- (2 * m `cst* X)) `+cst m ^ 2) | F]. + `E_[(X `-cst m) `^2 | F] = `E_[((X `^2 `- ((2 * m)%mcR `cst* X)) `+cst m ^+ 2) | F]. Proof. - rewrite !cEx_ExInd. - congr (_ * _). - apply eq_bigr => a _. - rewrite /sub_RV /trans_add_RV /trans_min_RV /sq_RV /= /comp_RV /scalel_RV /=. - by rewrite /ambient_dist; field. +rewrite !cEx_ExInd; congr (_ * _); apply: eq_bigr => a _. +rewrite /sub_RV /trans_add_RV /trans_min_RV /sq_RV /= /comp_RV /scalel_RV /=. +lra. Qed. Lemma cEx_Pr_eq0 (X: {RV P -> R}) F: Pr P F = 0 -> `E_[X | F] = 0. -Proof. -move => PrF0. -by rewrite cEx_ExInd PrF0 !coqRE invr0 mulr0. -Qed. +Proof. by move=> PrF0; rewrite cEx_ExInd PrF0 invr0 mulr0. Qed. Lemma cVarE (X : {RV (P) -> (R)}) F: - `V_[X | F] = `E_[X `^2 | F] - `E_[X | F] ^ 2. + `V_[X | F] = `E_[X `^2 | F] - `E_[X | F] ^+ 2. Proof. - have: 0 <= Pr P F by apply Pr_ge0. - case => [HPr_gt0 | HPr_eq0]. - rewrite /cVar cEx_trans_RV_id_rem. - rewrite cEx_trans_add_RV; last by []. - rewrite cEx_sub_RV cEx_scalel_RV. - field. - by rewrite /cVar !cEx_Pr_eq0; first (simpl; rewrite mul0R subR0). +have: 0 <= Pr P F by apply Pr_ge0. +rewrite le_eqVlt; case/orP => [ /eqP /esym HPr_eq0 | HPr_gt0P]. + by rewrite /cVar !cEx_Pr_eq0 // expr0n /= subr0. +rewrite /cVar cEx_trans_RV_id_rem. +rewrite cEx_trans_add_RV //. +rewrite cEx_sub_RV cEx_scalel_RV !expr2. +lra. Qed. Lemma cVarDist (X : {RV P -> R}) F x: 0 < Pr P F -> - `E_[(X `-cst x) `^2 | F] = - `V_[X | F] + (`E_[X | F] - x)². -Proof. - move => HPrPF. - unfold Rsqr. - rewrite cVarE. - simpl; rewrite mulR1 mulRDl !mulRDr !addRA -(mulRC (- _)) -!addRA addRA addRA -(addRA _ (- _)) (addRC (- _)). - have ->: `E_[X | F] * `E_[X | F] + - (`E_[X | F] * `E_[X | F]) = 0 by apply subRR. - rewrite addR0 -!cEx_scalel_RV. - have <-: `E_[(const_RV P (-x * -x)) | F] = (-x * -x) by apply cEx_const_RV. - rewrite -!cEx_add_RV !cEx_ExInd. - congr (_ * _). - apply eq_bigr => i _. - repeat congr (_ * _); - unfold "`-cst", "`^2", "`o", "`cst*", const_RV, "`+"; - simpl. - by rewrite !mulR1 mulRDl !mulRDr !addRA -(mulRC (-_)). + `E_[(X `-cst x) `^2 | F] = `V_[X | F] + (`E_[X | F] - x) ^+ 2. +Proof. +move=> ?. +rewrite cEx_trans_RV_id_rem cVarE cEx_add_RV cEx_sub_RV. +rewrite cEx_const_RV // cEx_scalel_RV. +lra. +Qed. + +Lemma cEx_sub_eq (X : {RV P -> R}) (F G : {set U}) : + F \subset G -> Pr P F = Pr P G -> `E_[ X | F ] = `E_[ X | G ]. +Proof. +move=> ? Pr_FG_eq; apply/eqP. +rewrite -subr_eq0 -normr_eq0 distrC. +rewrite !cEx_ExInd Pr_FG_eq -mulrBl -E_sub_RV -mul_RVBr -Ind_setD //. +rewrite normrM mulf_eq0; apply/orP; left. +rewrite normr_eq0 -sqrf_eq0 -normr_le0 normrX real_normK ?num_real //. +apply: le_trans; first exact: Cauchy_Schwarz_proba. +by rewrite -I_square Ind_setD // E_sub_RV !E_Ind Pr_FG_eq subrr mulr0. +Qed. + +Lemma cEx_union (X : {RV P -> R}) (F G H : {set U}) : + F \subset G :|: H -> + Pr P (F :&: G) + Pr P (F :&: H) = Pr P F -> + `E_[ X | F :&: G ] * Pr P (F :&: G) + `E_[ X | F :&: H ] * Pr P (F :&: H) = + `E_[ X | F ] * Pr P F. +Proof. +move=> FsubGUH. +have[F0|Fneq0]:= eqVneq (Pr P F) 0. + by rewrite !Pr_domin_setI // F0 !mulr0 addr0. +have[FIG0|FIGneq0]:= eqVneq (Pr P (F :&: G)) 0. + rewrite FIG0 mulr0 !add0r => FIHF. + by congr (_ * _)=> //; apply: cEx_sub_eq=> //; exact: subsetIl. +have[FIH0|FIHneq0]:= eqVneq (Pr P (F :&: H)) 0. + rewrite FIH0 mulr0 !addr0=> FIGF. + by congr (_ * _)=> //; apply: cEx_sub_eq=> //; exact: subsetIl. +move=> FGHF. +rewrite !cExE -!mulrA !mulVf // !mulr1 -big_union_nondisj /=; last first. + have/setIidPl/(congr1 (Pr P)):= FsubGUH. + rewrite setIUr Pr_setU FGHF=> /eqP. + rewrite -subr_eq0 addrAC subrr add0r oppr_eq0 => /eqP /psumr_eq0P P0. + by rewrite big1 // => *; rewrite P0 // mulr0. +by rewrite -setIUr; have/setIidPl->:= FsubGUH. +Qed. + +(* similarly to total_prob or total_prob_cond *) +Lemma total_cEx (X : {RV P -> R}) (I : finType) (E : {set U}) + (F : I -> {set U}) : + Pr P E = \sum_(i in I) Pr P (E :&: F i) -> + E \subset cover [set F x | x : I] -> + `E_[ X | E ] * Pr P E = + \sum_(i in I) `E_[ X | E :&: F i] * Pr P (E :&: F i). +Proof. +Abort. + +Lemma cExID (X : {RV P -> R}) (F G : {set U}) : + `E_[ X | F :&: G ] * Pr P (F :&: G) + `E_[ X | F :\: G ] * Pr P (F :\: G) = + `E_[ X | F ] * Pr P F. +Proof. +rewrite setDE cEx_union ?setUCr //. +rewrite -big_union_nondisj /=; last by rewrite setICA -setIA setICr !setI0 big_set0. +by rewrite -setIUr setUCr setIT. Qed. + End probability. Notation "`V_[ X | F ]" := (cVar X F) : proba_scope. -Arguments Ind_one {U P}. +Arguments Ind_one {R U P}. +Arguments cEx_sub_eq {R U P X} F G. Section resilience. -Variables (U : finType) (P : {fdist U}). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U). Lemma cresilience (delta : R) (X : {RV P -> R}) (F G : {set U}) : 0 < delta -> delta <= Pr P F / Pr P G -> F \subset G -> `| `E_[ X | F ] - `E_[ X | G ] | <= - sqrt (`V_[ X | G ] * 2 * (1 - delta) / delta). + Num.sqrt (`V_[ X | G ] * 2 * (1 - delta) / delta). Proof. move => delta_gt0 delta_FG /[dup] /setIidPr HGnF_F FG. -have [Pr_FG_eq|/eqP Pr_FG_neq] := eqVneq (Pr P F) (Pr P G). - have FGFG : F :|: G :\: F = G. - by have := setID G F; have := setIidPl FG; rewrite setIC => ->. - have GFP0 : \sum_(u in G :\: F) P u = 0. - move: Pr_FG_eq. - rewrite -[in X in _ = X -> _]FGFG [in X in _ = X -> _]/Pr. - rewrite big_union/=; last by apply/setDidPl; rewrite setDDl setUid. - by move=> /eqP; rewrite addRC -subr_eq => /eqP <-; rewrite /Pr subrr. - have {}GFP0 : forall u, u \in G :\: F -> P u = 0. - by move/psumr_eq0P : GFP0; exact. - rewrite !cExE Pr_FG_eq -Rdiv_minus_distr. - rewrite -[in X in `|(_ - X) / _|]FGFG. - rewrite big_union/=; last by apply/setDidPl; rewrite setDDl setUid. - rewrite subRD subRR sub0R big1 ?oppR0 ?div0R ?normR0; last first. - by move=> i /GFP0 ->; rewrite mulR0. - exact/sqrt_pos. -have [?|/eqP PrF_neq0] := eqVneq (Pr P F) 0; first nra. -have ? := subset_Pr P FG. -have ? := Pr_ge0 P F. -have [?|/eqP PrG_neq0] := eqVneq (Pr P G) 0; first by nra. -have HPrFpos : 0 < Pr P F by have := Pr_ge0 P F; lra. -have HPrGpos : 0 < Pr P G by have := Pr_ge0 P G; lra. +have [Pr_FG_eq|Pr_FG_neq] := eqVneq (Pr P F) (Pr P G). + by rewrite (cEx_sub_eq F G) // subrr normr0 sqrtr_ge0. +have FltG: Pr P F < Pr P G by rewrite lt_neqAle Pr_FG_neq subset_Pr. +have [PrF0|PrF_neq0] := eqVneq (Pr P F) 0. + by have:= lt_le_trans delta_gt0 delta_FG; rewrite PrF0 mul0r ltxx. +have HPrFpos : 0 < Pr P F by rewrite lt_neqAle eq_sym Pr_ge0 andbT. +have [PrG0|PrG_neq0] := eqVneq (Pr P G) 0. + by have:= subset_Pr P FG; rewrite PrG0 => /(lt_le_trans HPrFpos); rewrite ltxx. +have HPrGpos : 0 < Pr P G by rewrite lt_neqAle eq_sym Pr_ge0 andbT. have delta_lt1 : delta < 1. - by apply/(leR_ltR_trans delta_FG)/ltR_pdivr_mulr => //; lra. -case : (Rle_or_lt delta (1/2)) => delta_12. + apply/(le_lt_trans delta_FG). + by rewrite ltr_pdivrMr // mul1r. +have/orP[]:= le_total delta (1/2)=> delta_12. (*Pr P F <= 1/2 , A.3 implies the desired result*) - apply: (leR_trans (cEx_cVar _ _ _)) => //. - apply sqrt_le_1_alt. - rewrite !divRE -!mulRA; apply (leR_wpmul2l (cvariance_ge0 _ _)). - apply: (@leR_trans (1 / delta)). - rewrite (leR_pdivl_mulr delta)//. - rewrite mulRC -leR_pdivl_mulr; last exact: divR_gt0. - rewrite div1R invRM ?gtR_eqF //; last exact: invR_gt0. - by rewrite invRK ?gtR_eqF // mulRC. - by rewrite !divRE mulRA leR_pmul2r; [lra|exact: invR_gt0]. -rewrite cEx_Inv'//; last lra. -apply: leR_trans. - apply leR_wpmul2l; first exact: divR_ge0. + apply: (le_trans (cEx_cVar _ _ _)) => //. + rewrite ler_wsqrtr //. + rewrite -!mulrA; apply (ler_wpM2l (cvariance_ge0 _ _)). + apply: (@le_trans _ _ (1 / delta)). + rewrite ler_pdivlMr //. + rewrite mulrC -ler_pdivlMr; last exact: divr_gt0. + by rewrite div1r invfM invrK mulrC. + by rewrite mulrA ler_pM2r; [lra|rewrite invr_gt0]. +have delta_neq0: delta != 0 by lra. +have delta_pos: 0 < delta by lra. +have FG_pos: 0 < Pr P F / Pr P G by exact: (lt_le_trans delta_gt0 delta_FG). +rewrite cEx_Inv' //. +have PrGDF_pos: 0 < Pr P (G :\: F) by rewrite Pr_setD HGnF_F subr_gt0. +apply: le_trans. + apply: ler_wpM2l; first by rewrite ltW // divr_gt0. apply cEx_cVar => //; last exact: subsetDl. - by rewrite Pr_setD HGnF_F subR_gt0; lra. -apply: (@leR_trans - (sqrt (`V_[ X | G] * (Pr P G * (1 - delta)) / (Pr P G * delta * delta)))). - rewrite -(Rabs_pos_eq (Pr P (G :\: F) / Pr P F)); last exact: divR_ge0. - rewrite -sqrt_Rsqr_abs; rewrite -sqrt_mult_alt; last exact: Rle_0_sqr. - apply sqrt_le_1_alt. - rewrite !divRE !mulRA [in X in X <= _](mulRC _ (`V_[X | G])) -!mulRA. - apply: leR_wpmul2l; first exact: cvariance_ge0. - rewrite !mulRA mulRC !mulRA mulVR ?mul1R; last first. - by rewrite Pr_setD HGnF_F; apply/eqP; nra. - rewrite mulRC (mulRC (/Pr P F)) -mulRA -invRM; [|exact/gtR_eqF|exact/gtR_eqF]. - rewrite mulRA; apply/leR_pdivr_mulr; first by nra. - rewrite mulRAC; apply/leR_pdivl_mulr; first by apply: Rmult_lt_0_compat; nra. - move/leR_pdivl_mulr : delta_FG => /(_ HPrGpos) => delta_FG. - apply Rmult_le_compat_r with (r:= Pr P G) in delta_FG => //. - rewrite (mulRC (Pr P G)) -mulRA; apply: leR_pmul => //. - - apply: mulR_ge0 => //; apply/mulR_ge0; last exact/ltRW. - by apply/mulR_ge0 => //; exact/ltRW. - - by rewrite Pr_setD HGnF_F; nra. - - by rewrite mulRCA; apply: leR_pmul; nra. -apply sqrt_le_1_alt. -rewrite divRE invRM; [|exact/gtR_eqF/mulR_gt0|exact/gtR_eqF]. -rewrite mulRA; apply/leR_pmul2r; first exact/invR_gt0. -rewrite -!mulRA; apply: leR_wpmul2l; first exact: cvariance_ge0. -rewrite invRM; [|exact/gtR_eqF|exact/gtR_eqF]. -rewrite mulRCA (mulRA (Pr P G)) mulRV ?mul1R; last exact/gtR_eqF. -rewrite mulRC; apply/leR_wpmul2r; first lra. -by rewrite -div1R; apply/leR_pdivr_mulr => //; nra. +apply: (@le_trans _ _ (Num.sqrt (`V_[ X | G] * (delta^-1 - 1) / delta))). + rewrite -[X in X * Num.sqrt _]gtr0_norm ?divr_gt0 // -sqrtr_sqr. + rewrite -sqrtrM ?sqr_ge0 // ler_wsqrtr //. + rewrite mulrC -!mulrA ler_wpM2l ?cvariance_ge0 //. + rewrite mulrC exprMn !mulrA mulVf // -?Pr_gt0P // mul1r. + rewrite Pr_setD HGnF_F mulrDl mulNr mulfV //. + rewrite mulrAC -mulrA -invf_div. + apply: ler_pM. + - by rewrite subr_ge0 -invr1 lef_pV2 ?posrE // ler_pdivrMr // mul1r subset_Pr. + - by rewrite invr_ge0 ltW. + - by rewrite lerD // lef_pV2. + - by rewrite lef_pV2. +rewrite ler_wsqrtr // -!mulrA ler_wpM2l ?cvariance_ge0 //. +rewrite [X in 2 * X]mulrDl mulNr mulfV // div1r mulrC ler_wpM2r //. + by rewrite subr_ge0 -[leLHS]invrK lef_pV2 ?posrE ?invr1 // ltW. +by rewrite -lef_pV2 ?posrE ?invr_gt0 // invrK -div1r. Qed. (* NB: not used, unconditional version of cresilience *) Lemma resilience (delta : R) (X : {RV P -> R}) F : 0 < delta -> delta <= Pr P F -> - `| `E_[ X | F ] - `E X | <= sqrt (`V X * 2 * (1 - delta) / delta). + `| `E_[ X | F ] - `E X | <= Num.sqrt (`V X * 2 * (1 - delta) / delta). Proof. move=> delta_gt0 delta_F. have := @cresilience _ X F setT delta_gt0. -rewrite Pr_setT divR1 => /(_ delta_F); rewrite -Ex_cExT -Var_cVarT. +rewrite Pr_setT divr1 => /(_ delta_F); rewrite -Ex_cExT -Var_cVarT. by apply; exact/subsetT. Qed. End resilience. Section robustmean. -Variables (U : finType) (P : {fdist U}). +Context {R : realType}. +Variables (U : finType) (P : R.-fdist U). Theorem robust_mean (good drop: {set U}) (X : {RV P -> R}) (eps : R): let bad := ~: good in @@ -661,173 +691,136 @@ Theorem robust_mean (good drop: {set U}) (X : {RV P -> R}) (eps : R): 0 < eps -> eps <= 1/8 -> Pr P bad = eps -> Pr P drop = 4 * eps -> (* All the outliers exceeding the ε-quantile are eliminated: *) - (forall y, y \in bad -> sqrt (sigma / eps) < `| X y - mu | -> y \in drop) -> - `| mu_hat - mu | <= 8 * sqrt (sigma / eps). + (forall y, y \in bad -> Num.sqrt (sigma / eps) < `| X y - mu | -> y \in drop) -> + `| mu_hat - mu | <= 8 * Num.sqrt (sigma / eps). Proof. move=> bad mu_hat mu sigma Hmin_outliers Hmax_outliers Hbad_ratio Hdrop_ratio Hquantile_drop_bad. -have H : Pr P good = 1 - eps by apply/esym/subR_eq; rewrite -Hbad_ratio Pr_cplt. +have H : Pr P good = 1 - eps by rewrite -Hbad_ratio -Pr_to_cplt. (* On the other hand, we remove at most 4ε good points *) have max_good_drop : Pr P (good :&: drop) <= 4 * eps. by rewrite -Hdrop_ratio; exact/subset_Pr/subsetIr. pose eps' := Pr P (bad :\: drop) / Pr P (~: drop). have Hcompl : Pr P (good :\: drop) / Pr P (~: drop) = 1 - eps'. - apply/esym/subR_eq; rewrite /eps' -mulRDl -disjoint_Pr_setU. - by rewrite -setDUl setUCr setTD mulRV// Pr_setC; apply/eqP; lra. - by rewrite -setI_eq0 -setDIl setICr set0D. -have eps'_ge0 : 0 <= eps'. - by apply: mulR_ge0 => //; apply/ltRW/invR_gt0; rewrite Pr_setC; lra. + rewrite -(setCK good) -/bad setDE setIC -setDE. + rewrite Pr_setD setIC -setDE mulrDl mulNr mulfV //. + by rewrite -Pr_gt0P Pr_setC; lra. +have eps'_ge0 : 0 <= eps' by rewrite mulr_ge0 // ?invr_ge0 Pr_ge0. have eps'_le1 : eps' <= 1. - rewrite /eps'; apply/leR_pdivr_mulr; first by rewrite Pr_setC; lra. - by rewrite mul1R; exact/subset_Pr/subsetDr. + rewrite ler_pdivrMr; last by rewrite Pr_setC; lra. + by rewrite mul1r subset_Pr // subsetDr. (* Remaining good points: 1 - (4 * eps) / (1 - eps) *) pose delta := 1 - (4 * eps) / (1 - eps). have min_good_remain : delta <= Pr P (good :\: drop) / Pr P good. rewrite /delta Pr_setD H. - apply: (@leR_trans ((1 - eps - 4 * eps) / (1 - eps))). - apply/leR_pdivl_mulr; first lra. - by rewrite mulRDl -mulNR -(mulRA _ (/ _)) Rinv_l; lra. - apply/leR_pdivr_mulr; first lra. - rewrite -[X in _ <= X]mulRA mulVR ?mulR1; first lra. - by apply/eqP; lra. + apply: (@le_trans _ _ ((1 - eps - 4 * eps) / (1 - eps))). + rewrite ler_pdivlMr; last lra. + by rewrite mulrDl -mulNr -(mulrA _ _^-1) mulVf //; lra. + rewrite ler_pdivrMr; last lra. + rewrite -[X in _ <= X]mulrA mulVf ?mulr1; lra. have delta_gt0 : 0 < delta. - apply (@ltR_pmul2r (1 - eps)); first lra. - by rewrite mul0R mulRDl mul1R -mulNR -mulRA Rinv_l; lra. + rewrite -(@ltr_pM2r _ (1 - eps)); last lra. + by rewrite mul0r mulrDl mul1r -mulNr -mulrA mulVf //; lra. have delta_le1 : delta <= 1. - apply (@leR_pmul2r (1 - eps)); first lra. - by rewrite mul1R mulRDl mul1R -mulNR -mulRA Rinv_l ?mulR1; lra. + rewrite -(@ler_pM2r _ (1 - eps)); last lra. + by rewrite mul1r mulrDl mul1r -mulNr -mulrA mulVf ?mulr1 //; lra. have Exgood_bound : `| `E_[X | good :\: drop ] - `E_[X | good] | <= - sqrt (`V_[X | good] * 2 * (1 - delta) / delta). + Num.sqrt (`V_[X | good] * 2 * (1 - delta) / delta). have [gdg|gdg] := eqVneq (Pr P (good :\: drop)) (Pr P good). - suff : `E_[X | (good :\: drop)] = `E_[X | good]. - by move=> ->; rewrite subRR normR0; exact: sqrt_pos. - apply: eq_bigr => i _; rewrite gdg; congr (_ * _ * _). - rewrite setIDA Pr_setD -setIA. - (* NB: lemma? *) - apply/subR_eq; rewrite addRC; apply/subR_eq; rewrite subRR; apply/esym. - move: gdg; rewrite Pr_setD => /subR_eq; rewrite addRC => /subR_eq. - by rewrite subRR [in X in _ -> X]setIC => /esym; exact: Pr_domin_setI. + by move=> ->; rewrite subrr normr0 sqrtr_ge0. + by apply: cEx_sub_eq => //; exact: subsetDl. - apply cresilience. - + apply (@ltR_pmul2r (1 - eps)); first lra. - by rewrite mul0R; apply: mulR_gt0 => //; lra. + + rewrite -(@ltr_pM2r _ (1 - eps)); last lra. + by rewrite mul0r mulr_gt0 //; lra. + lra. + exact: subsetDl. have Exbad_bound : 0 < Pr P (bad :\: drop) -> - `| `E_[ X | bad :\: drop ] - mu | <= sqrt (sigma / eps). + `| `E_[ X | bad :\: drop ] - mu | <= Num.sqrt (sigma / eps). move=> Pr_bd. - rewrite -(mulR1 mu) -(@Ind_one U P (bad :\: drop)); last lra. - rewrite 2!cEx_ExInd -addR_opp -mulNR mulRA -(I_double P) -mulRDl big_distrr /=. - rewrite /Ex -big_split /= [X in `|X */ _|](_ : _ = - \sum_(i in U) (X i - mu) * @Ind U (bad :\: drop) i * P i); last first. - by apply: eq_bigr => u _; rewrite -mulRA mulNR addR_opp -mulRBl mulRA. - rewrite normRM (geR0_norm (/ _)); last exact/ltRW/invR_gt0. - apply/leR_pdivr_mulr => //; apply: (leR_trans (leR_sumR_Rabs _ _)). + rewrite -(mulr1 mu) -(@Ind_one _ U P (bad :\: drop)); last lra. + rewrite 2!cEx_ExInd -mulNr mulrA -(I_double P) -mulrDl big_distrr /=. + rewrite /Ex -big_split /= [X in `|X / _|](_ : _ = + \sum_(i in U) (X i - mu) * @Ind _ U (bad :\: drop) i * P i); last first. + by apply: eq_bigr => u _; rewrite -mulrA mulNr -mulrBl mulrA. + rewrite normrM (@ger0_norm _ _^-1); last by rewrite ltW // invr_gt0. + rewrite ler_pdivrMr //; apply: (le_trans (ler_norm_sum _ _ _)). rewrite (bigID [pred i | i \in bad :\: drop]) /=. - rewrite [X in _ + X]big1 ?addR0; last first. - by move=> u /negbTE abaddrop; rewrite /Ind abaddrop mulR0 mul0R normR0. - rewrite /Pr big_distrr /=. apply leR_sumR => i ibaddrop. - rewrite normRM (geR0_norm (P i))//; apply: leR_wpmul2r => //. - rewrite /Ind ibaddrop mulR1. + rewrite [X in _ + X]big1 ?addr0; last first. + by move=> u /negbTE abaddrop; rewrite /Ind abaddrop mulr0 mul0r normr0. + rewrite /Pr big_distrr /=; apply: ler_sum => i ibaddrop. + rewrite normrM (@ger0_norm _ (P i)) // ler_wpM2r //. + rewrite /Ind ibaddrop mulr1. move: ibaddrop; rewrite inE => /andP[idrop ibad]. - by rewrite leRNgt => /Hquantile_drop_bad => /(_ ibad); apply/negP. + by rewrite leNgt -(rwP negP) => /(Hquantile_drop_bad _ ibad); exact/negP. have max_bad_remain : Pr P (bad :\: drop) <= eps / Pr P (~: drop). rewrite Pr_setC Hdrop_ratio Pr_setD Hbad_ratio. - apply: (@leR_trans eps); first exact/leR_subl_addr/leR_addl. - by apply/leR_pdivl_mulr; [lra|nra]. + apply: (@le_trans _ _ eps); first by rewrite lerBlDr lerDl Pr_ge0. + by rewrite ler_pdivlMr; [nra|lra]. have Ex_not_drop : `E_[ X | ~: drop ] = (`E_[ X | good :\: drop ] * Pr P (good :\: drop) + `E_[ X | bad :\: drop ] * Pr P (bad :\: drop)) / Pr P (~: drop). - have good_bad : Pr P (good :\: drop) + Pr P (bad :\: drop) = Pr P (~: drop). - rewrite -(_ : good :\: drop :|: bad :\: drop = ~: drop); last first. - by rewrite -setDUl setUCr setTD. - rewrite Pr_setU. - apply/subR_eq; rewrite subR_opp addRC; apply/esym/subR_eq; rewrite subRR. - suff : (good :\: drop) :&: (bad :\: drop) = set0. - by move=> ->; rewrite Pr_set0. - by rewrite !setDE setIACA setIid setICr set0I. - have [bd0|/eqP bd0 {good_bad}] := eqVneq (Pr P (bad :\: drop)) 0. - - rewrite bd0 addR0 in good_bad. - rewrite bd0 mulR0 addR0 good_bad. - rewrite /Rdiv -mulRA mulRV ?mulR1; last first. - by apply/Pr_gt0P; rewrite -good_bad Pr_setD H; lra. - rewrite 2!cEx_ExInd good_bad; congr (_ / _). - apply/eq_bigr => u _. - rewrite /ambient_dist -!mulRA; congr (_ * _). - (* NB: lemma? *) - rewrite /Ind !inE. - have bad_drop0 : u \in bad :\: drop -> P u = 0 by apply Pr_set0P. - case: ifPn => idrop //=. - by case: ifPn => // igood; rewrite bad_drop0 ?mulR0// !inE idrop. - - apply/eqR_divl_mulr; first by rewrite Pr_setC; apply/eqP; nra. - rewrite !cEx_ExInd -!mulRA. - rewrite Rinv_l ?mulR1; last by rewrite Pr_setC; nra. - rewrite Rinv_l ?mulR1; last nra. - rewrite Rinv_l // mulR1. - rewrite [in RHS]/Ex -big_split; apply: eq_bigr => i _ /=. - rewrite /ambient_dist -!mulRA -mulRDr -mulRDl ; congr (X i * (_ * _)). - (* NB: lemma? *) - rewrite /Ind !inE; case: ifPn => //=; rewrite ?(addR0,add0R)//. - by case: ifPn => //=; rewrite ?(addR0,add0R). -rewrite -(mulR1 mu). + rewrite !setDE (setIC good) (setIC bad) /bad -setDE cExID. + rewrite -mulrA mulfV ?mulr1 // Pr_setC. + lra. +rewrite -(mulr1 mu). rewrite (_ : 1 = eps' + Pr P (good :\: drop) / Pr P (~: drop)); last first. - by rewrite Hcompl addRCA addR_opp subRR addR0. -rewrite (mulRDr mu) -addR_opp oppRD. -rewrite /mu_hat Ex_not_drop divRDl. -rewrite {2}/Rdiv -(mulRA `E_[X | _]) -divRE -/eps'. -rewrite Hcompl. -rewrite {1}/Rdiv -(mulRA `E_[X | _]) -divRE. + by rewrite Hcompl addrCA subrr addr0. +rewrite (mulrDr mu) opprD. +rewrite /mu_hat Ex_not_drop mulrDl. +rewrite -(mulrA `E_[X | _]) -/eps'. rewrite Hcompl. -rewrite -addRA addRC addRA -!mulNR -(mulRDl _ _ eps'). -rewrite -addRA -mulRDl. -rewrite (addRC (-mu)). -apply: (leR_trans (Rabs_triang _ _)). -rewrite 2!normRM (geR0_norm eps'); last lra. -rewrite (geR0_norm (1 - eps')); last lra. -apply: (@leR_trans (sqrt (`V_[ X | good] / eps) * eps' + - sqrt (`V_[ X | good] * 2 * (1 - delta) / delta) * (1 - eps'))). +rewrite -(mulrA `E_[X | _]). +rewrite -addrA addrC addrA -!mulNr -(mulrDl _ _ eps'). +rewrite -addrA -mulrDl. +rewrite (addrC (-mu)). +rewrite (le_trans (ler_normD _ _)) //. +rewrite (normrM _ eps') (@ger0_norm _ eps'); last lra. +rewrite normrM. +rewrite mulNr -/eps' (@ger0_norm _ (1 - eps')); last lra. +apply: (@le_trans _ _ (Num.sqrt (`V_[ X | good] / eps) * eps' + + Num.sqrt (`V_[ X | good] * 2 * (1 - delta) / delta) * (1 - eps'))). have [->|/eqP eps'0] := eqVneq eps' 0. - by rewrite !(mulR0,add0R,subR0,mulR1). + by rewrite !(mulr0,add0r,subr0,mulr1). have [->|/eqP eps'1] := eqVneq eps' 1. - rewrite !(subRR,mulR0,addR0,mulR1); apply: Exbad_bound. + rewrite !(subrr, mulr0, addr0, mulr1); apply: Exbad_bound. apply Pr_gt0P; apply: contra_notN eps'0 => /eqP. - by rewrite /eps' => ->; rewrite div0R. + by rewrite /eps' => ->; rewrite mul0r. have [bd0|bd0] := eqVneq (Pr P (bad :\: drop)) 0. - by exfalso; apply/eps'0; rewrite /eps' bd0 div0R. - apply: leR_add; (apply/leR_pmul2r; first lra). + by exfalso; apply/eps'0; rewrite /eps' bd0 mul0r. + apply: lerD; (rewrite ler_pM2r; last lra). - exact/Exbad_bound/Pr_gt0P. - exact: Exgood_bound. -rewrite /sigma /Rdiv !sqrt_mult //; last 8 first. +rewrite /sigma !sqrtrM //; last 4 first. - exact: cvariance_ge0. - - lra. - - by apply: mulR_ge0; [exact: cvariance_ge0|lra]. - - lra. - - apply: mulR_ge0; [|lra]. - by apply: mulR_ge0; [exact: cvariance_ge0|lra]. - - by apply/ltRW/invR_gt0; lra. + - by apply: mulr_ge0; [exact: cvariance_ge0|lra]. + - apply: mulr_ge0; [|lra]. + by apply: mulr_ge0; [exact: cvariance_ge0|lra]. - exact: cvariance_ge0. - - by apply/ltRW/invR_gt0; lra. -rewrite (mulRC 8) -!mulRA -mulRDr; apply: leR_wpmul2l; first exact: sqrt_pos. -rewrite mulRA -sqrt_mult; [|lra|lra]. -rewrite mulRA -sqrt_mult; [|lra|]; last by apply/ltRW/invR_gt0; lra. -rewrite addRC; apply/leR_subr_addr. -rewrite -mulRBr -(sqrt_Rsqr (1 - eps')); last lra. -rewrite -(sqrt_Rsqr (8 - eps')); last lra. -rewrite -sqrt_mult; last 2 first. - - by apply/mulR_ge0; [lra|apply/ltRW/invR_gt0; lra]. - - exact: Rle_0_sqr. -rewrite -sqrt_mult; last 2 first. - - by apply/ltRW/invR_gt0; lra. - - exact: Rle_0_sqr. -apply/sqrt_le_1_alt/leR_pmul. -- by apply: mulR_ge0; [lra|apply/ltRW/invR_gt0; lra]. -- exact: Rle_0_sqr. -- rewrite -divRE; apply/leR_pdivr_mulr; first lra. - rewrite (mulRC _ delta) -divRE; apply/leR_pdivl_mulr; first lra. - rewrite mulRC mulRA; apply/(@leR_pmul2r (1 - eps)); first lra. - rewrite mulRDl mul1R -mulNR -(mulRA _ (/ _)) Rinv_l ?mulR1; last lra. - by rewrite -mulRA mulRDl oppRD oppRK mulRDl -(mulRA _ (/ _)) Rinv_l; [nra|lra]. -- by apply/Rsqr_incr_1; lra. +rewrite addrCA subrr addr0. +rewrite -(mulr_natl _ 8) -!mulrA -mulrDr mul1r. +rewrite -!(mulrCA (Num.sqrt `V_[ X | good])). +apply: ler_wpM2l; first exact: sqrtr_ge0. +rewrite mulrA -sqrtrM; [|lra]. +rewrite mulrA -sqrtrM; [|lra]. +rewrite addrC -lerBrDr (mulrC 8) -mulrBr. +rewrite -(@ger0_norm _ (1 - eps')) -?sqrtr_sqr; last lra. +rewrite -(@ger0_norm _ (8 - eps')) -?sqrtr_sqr; last lra. +rewrite [leLHS]mulrC [leRHS]mulrC. +rewrite -sqrtrM ?sqr_ge0 //. +rewrite -sqrtrM ?sqr_ge0 //. +rewrite ler_sqrt 1?mulr_ge0 ?sqr_ge0 ?invr_ge0 //; last by rewrite ltW. +apply: ler_pM. +- exact: sqr_ge0. +- by rewrite !mulr_ge0 ?invr_ge0 //; lra. +- rewrite ler_sqr ?nnegrE; lra. +- rewrite -[leRHS]mulr1 ler_pdivlMl; last lra. + rewrite [leLHS](_ : _ = 8 * eps * eps / (1 - 5 * eps)); last first. + rewrite /delta; field; apply/andP; split; lra. + rewrite ler_pdivrMr; last lra. + rewrite mul1r (@le_trans _ _ eps) //; last lra. + by rewrite ler_piMl //; lra. Qed. End robustmean. diff --git a/robust/weightedmean.v b/robust/weightedmean.v index 754c8bef..62b76eba 100644 --- a/robust/weightedmean.v +++ b/robust/weightedmean.v @@ -1,16 +1,16 @@ From mathcomp Require Import all_ssreflect ssralg ssrnum matrix. +From mathcomp Require Import lra ring. From mathcomp Require boolp. From mathcomp Require Import Rstruct reals mathcomp_extra. -From mathcomp Require Import lra. -Require Import Reals. -From infotheo Require Import ssrR Reals_ext realType_ext logb ssr_ext ssralg_ext. -From infotheo Require Import bigop_ext fdist proba. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln. +Require Import fdist proba. +Require coqRE. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -(*Local Open Scope R_scope.*) +Local Open Scope ring_scope. Local Open Scope reals_ext_scope. Local Open Scope fdist_scope. Local Open Scope proba_scope. @@ -56,132 +56,15 @@ Require Import robustmean. Section is01. Local Open Scope ring_scope. -Definition is01 (U : finType) (C : {ffun U -> R}) := forall i, 0 <= C i <= 1. +Definition is01 (U : finType) (C : {ffun U -> Rdefinitions.R}) := forall i, 0 <= C i <= 1. End is01. -Section misc20240303. -Local Open Scope ring_scope. - -(* to ssrR *) -Lemma RsqrtE' (x : RbaseSymbolsImpl.R) : sqrt x = Num.sqrt x. -Proof. -set Rx := Rcase_abs x. -have RxE: Rx = Rcase_abs x by []. -rewrite /sqrt. -rewrite -RxE. -move: RxE. -case: Rcase_abs=> x0 RxE. - by rewrite RxE; have/RltP/ltW/ler0_sqrtr-> := x0. -rewrite /Rx -/(sqrt _) RsqrtE //. -by have/Rge_le/RleP:= x0. -Qed. - -(* to ssrnum? *) -Lemma sqrBC (R : realDomainType) (x y : R) : (x - y) ^+ 2 = (y - x) ^+ 2. -Proof. -have:= num_real (x - y) => /real_normK <-. -by rewrite distrC real_normK // num_real. -Qed. - -(* to ssrnum? *) -Lemma ler_abs_sqr (T : realDomainType) (x y : T) : (`|x| <= `|y|) = (x ^+ 2 <= y ^+ 2). -Proof. by rewrite -[LHS]ler_sqr ?nnegrE// ?real_normK// num_real. Qed. - -(* TODO: use ring_scope in robustmean.v *) -Lemma cresilience' - (V : finType) (PP : {fdist V}) (delta : R) (XX : {RV (PP) -> (R)}) (F G : {set V}) : - 0 < delta -> delta <= Pr PP F / Pr PP G -> F \subset G -> - `| `E_[XX | F] - `E_[XX | G] | <= Num.sqrt (`V_[ XX | G] * 2 * (1 - delta) / delta). -Proof. -rewrite -!coqRE -RsqrtE' => /RltP ? /RleP ? ?. -exact/RleP/cresilience. -Qed. - -Lemma variance_ge0' (U : finType) (P : {fdist U}) (X : {RV (P) -> (R)}) : - 0 <= `V X. -Proof. exact/RleP/variance_ge0. Qed. - -Lemma cvariance_ge0' (U : finType) (P : {fdist U}) (X : {RV (P) -> (R)}) (F : {set U}) : - 0 <= `V_[ X | F]. -Proof. exact/RleP/cvariance_ge0. Qed. - -Lemma resilience' - (U : finType) (P : {fdist U}) (delta : R) (X : {RV (P) -> (R)}) (F : {set U}) : - 0 < delta -> delta <= Pr P F -> - `| `E_[X | F] - `E X | <= Num.sqrt (`V X * 2 * (1 - delta) / delta). -Proof. -rewrite -!coqRE -RsqrtE' => /RltP ? /RleP ?. -exact/RleP/resilience. -Qed. - -(* analog of ssrR.(pmulR_lgt0', pmulR_rgt0') *) -Lemma wpmulr_lgt0 (R : numDomainType) (x y : R) : 0 <= x -> 0 < y * x -> 0 < y. -Proof. -rewrite le_eqVlt=> /orP [/eqP <- |]. - by rewrite mulr0 ltxx. -by move/pmulr_lgt0->. -Qed. -Lemma wpmulr_rgt0 (R : numDomainType) (x y : R) : 0 <= x -> 0 < x * y -> 0 < y. -Proof. rewrite mulrC; exact: wpmulr_lgt0. Qed. - -(* eqType version of order.bigmax_le *) -Lemma bigmax_le' disp (T : porderType disp) (I : eqType) (r : seq I) (f : I -> T) - (x0 x : T) (PP : pred I) : - (x0 <= x)%O -> - (forall i : I, i \in r -> PP i -> (f i <= x)%O) -> - (\big[Order.max/x0]_(i <- r | PP i) f i <= x)%O. -Proof. -move=> x0x cond; rewrite big_seq_cond bigmax_le // => ? /andP [? ?]; exact: cond. -Qed. - -(* seq version of order.bigmax_leP *) -Lemma bigmax_leP_seq disp (T : orderType disp) (I : eqType) (r : seq I) (F : I -> T) - (x m : T) (PP : pred I) : -reflect ((x <= m)%O /\ (forall i : I, i \in r -> PP i -> (F i <= m)%O)) - (\big[Order.max/x]_(i <- r | PP i) F i <= m)%O. -Proof. -apply:(iffP idP); last by case; exact:bigmax_le'. -move=> bm; split; first by exact/(le_trans _ bm)/bigmax_ge_id. -by move=> *; exact/(le_trans _ bm)/le_bigmax_seq. -Qed. - -Section topology_ext. -Import boolp. -(* variant of robustmean.bigmaxR_ge0_cond, should be moved to topology.v *) -Lemma bigmax_gt0_seq (A : eqType) (F : A -> R) (s : seq A) (PP : pred A) : -reflect (exists i : A, [/\ i \in s, PP i & 0 < F i]) (0 < \big[Num.max/0]_(m <- s | PP m) F m). -Proof. -rewrite ltNge. -apply:(iffP idP). - move=> /bigmax_leP_seq /not_andP []; first by rewrite lexx. - move=> /existsNP [] x /not_implyP [] xs /not_implyP [] PPx /negP; rewrite -ltNge=> Fx0. - by exists x; repeat (split=> //). -case=> x [] ? ? ?; apply/bigmax_leP_seq/not_andP; right. -apply/existsNP; exists x; do 2 (apply/not_implyP; split=> //). -by apply/negP; rewrite -ltNge. -Qed. -End topology_ext. - -End misc20240303. - -Section proba_ext. -Local Open Scope ring_scope. -Variables (A : finType) (P : {fdist A}). -Lemma Pr_setT' : Pr P [set: A] = 1. -Proof. by rewrite /Pr (eq_bigl xpredT) ?FDist.f1 // => ?; rewrite in_setT. Qed. -End proba_ext. - -Section finset_ext. -Variables (R : Type) (idx : R) (op : Monoid.com_law idx) (I : finType) (a b : I) (F : I -> R). -Lemma big_set2 : a != b -> \big[op/idx]_(i in [set a; b]) F i = op (F a) (F b). -Proof. by move=> ab; rewrite big_setU1 ?inE // big_set1. Qed. -End finset_ext. - Module Weighted. Section def. Local Open Scope ring_scope. - -Variables (A : finType) (d0 : {fdist A}) (g : nneg_finfun A). +Let R := Rdefinitions.R. +Variables (A : finType) (d0 : {fdist A}) (g : {ffun A -> R}). +Hypotheses g0 : forall a, 0 <= g a. Definition total := \sum_(a in A) g a * d0 a. @@ -192,7 +75,8 @@ Definition f := [ffun a => g a * d0 a / total]. Lemma total_gt0 : 0 < total. Proof. rewrite lt_neqAle eq_sym total_neq0/= /total sumr_ge0// => i _. -by apply/mulr_ge0/FDist.ge0; case: g => ? /= /forallP. +apply/mulr_ge0/FDist.ge0. +exact/g0. Qed. Lemma total_le1 : (forall i, i \in A -> g i <= 1) -> total <= 1. @@ -208,7 +92,7 @@ Proof. by move=> g01; apply: total_le1=> i _; have /andP [] := g01 i. Qed. Let f0 a : 0 <= f a. Proof. rewrite ffunE /f divr_ge0//; last exact/ltW/total_gt0. -by rewrite mulr_ge0 //; case: g => ? /= /forallP; exact. +by rewrite mulr_ge0. Qed. Let f1 : \sum_(a in A) f a = 1. @@ -225,12 +109,12 @@ Proof. by rewrite /d; unlock; rewrite ffunE. Qed. Lemma support_nonempty : {i | g i != 0}. Proof. move: total_neq0; rewrite psumr_neq0; last first. - by move=> *; apply: mulr_ge0 => //; exact: nneg_finfun_ge0. + by move=> *; apply: mulr_ge0. case/hasP/sig2W=> /= x ?. -move/RltP/pmulR_lgt0'. +move/(@wpmulr_lgt0 R). have := fdist_ge0_le1 d0 x. -case/andP=> /[swap] _ /RleP /[swap] /[apply]. -by move/ltR_eqF; rewrite eq_sym => ?; exists x. +case/andP=> /[swap] _ /[swap] /[apply]. +by move/lt_eqF; rewrite eq_sym => H; exists x; rewrite H. Qed. End def. @@ -249,8 +133,9 @@ Notation "Q .-RV X '\o' f" := (change_dist Q f X) Module Split. Section def. Local Open Scope ring_scope. - -Variables (T : finType) (P : {fdist T}) (h : nneg_finfun T). +Let R := Rdefinitions.R. +Variables (T : finType) (P : {fdist T}) (h : {ffun T -> R}). +Hypothesis h0 : forall t, 0 <= h t. Hypothesis h01 : is01 h. Definition g := fun x => if x.2 then h x.1 else 1 - h x.1. @@ -259,7 +144,8 @@ Definition f := [ffun x => g x * P x.1]. Lemma g_ge0 x : (0 <= g x)%mcR. Proof. -rewrite /g; case: ifPn => _; first by case: h => ? /= /forallP. +rewrite /g; case: ifPn => _. + exact/h0. by have /andP [_ ?] := h01 x.1; rewrite subr_ge0. Qed. @@ -294,16 +180,16 @@ Lemma Pr_setXT A : Pr P A = Pr d (A `* [set: bool]). Proof. rewrite /Pr big_setX/=; apply: eq_bigr => u uS. rewrite setT_bool big_setU1//= ?inE// big_set1. -by rewrite !dE/= -mulRDl addRCA addR_opp subRR addR0 mul1R. +by rewrite !dE/= -mulrDl addrCA subrr addr0 mul1r. Qed. Lemma cEx (X : {RV P -> R}) A : `E_[X | A] = `E_[fst_RV X | A `* [set: bool]]. Proof. -rewrite !cExE -Pr_setXT !coqRE; congr (_ / _). +rewrite !cExE -Pr_setXT; congr (_ / _). rewrite big_setX//=; apply: eq_bigr => u uS. rewrite setT_bool big_setU1//= ?inE// big_set1. rewrite !dE/= /fst_RV/=. -by rewrite -mulRDr -mulRDl addRCA addR_opp subRR addR0 mul1R. +by rewrite -mulrDr -mulrDl addrCA subrr addr0 mul1r. Qed. Section fst_RV'. @@ -314,11 +200,11 @@ Proof. rewrite cEx. rewrite !cExE. rewrite Pr_XsetT. -congr (_ / _)%coqR. +congr (_ / _). rewrite big_setX /=. apply: eq_bigr=> a aA. rewrite /fst_RV /fst_RV' /change_dist /= -big_distrr /=. -congr (_ * _)%coqR. +congr (_ * _). rewrite -Pr_set1 -PrX_fst /=. under [RHS]eq_bigr do rewrite setX1 Pr_set1 /=. apply: eq_bigl => b. @@ -334,29 +220,29 @@ End Split. Section emean_cond. Local Open Scope ring_scope. - -Context {U : finType} (P : {fdist U}) (X : {RV P -> R}) (C : nneg_finfun U) +Let R := Rdefinitions.R. +Context {U : finType} (P : {fdist U}) (X : {RV P -> R}) (C : {ffun U -> R}) (A : {set U}) (PC0 : Weighted.total P C != 0). - -Let WP := Weighted.d PC0. +Hypothesis C0 : forall u, 0 <= C u. +Let WP := Weighted.d C0 PC0. Hypothesis C01 : is01 C. Lemma emean_condE : `E_[WP.-RV X | A] = (\sum_(i in A) C i * P i * X i) / (\sum_(i in A) C i * P i). Proof. -rewrite /Var cExE /Pr /WP !coqRE !sumRE. -under eq_bigr do rewrite Weighted.dE !coqRE mulrA (mulrC (X _)). +rewrite /Var cExE /Pr /WP. +under eq_bigr do rewrite Weighted.dE mulrA (mulrC (X _)). rewrite -big_distrl -mulrA; congr (_ * _). -rewrite sumRE -invfM mulrC big_distrl /=. +rewrite -invfM mulrC big_distrl /=. by under eq_bigr do rewrite Weighted.dE -!mulrA mulVf // mulr1. Qed. -Lemma emean_cond_split : `E_[WP.-RV X | A] = `E_[Split.fst_RV C01 X | A `* [set true]]. +Lemma emean_cond_split : `E_[WP.-RV X | A] = `E_[Split.fst_RV C0 C01 X | A `* [set true]]. Proof. -rewrite emean_condE cExE big_setX /= !coqRE; congr (_ / _). +rewrite emean_condE cExE big_setX /=; congr (_ / _). apply: eq_bigr => u uA. - by rewrite big_set1 /Split.fst_RV/= Split.dE/= [RHS]mulRC. + by rewrite big_set1 /Split.fst_RV/= Split.dE/= [RHS]mulrC. by rewrite /Pr big_setX/=; apply: eq_bigr => u uA; rewrite big_set1 Split.dE. Qed. @@ -364,38 +250,38 @@ End emean_cond. Section emean. Local Open Scope ring_scope. - -Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : nneg_finfun U) +Let R := Rdefinitions.R. +Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : {ffun U -> R}) (PC0 : Weighted.total P C != 0). - -Let WP := Weighted.d PC0. +Hypotheses C0 : forall u, 0 <= C u. +Let WP := Weighted.d C0 PC0. (** emean expressed using big sums *) Lemma emean_sum : `E (WP.-RV X) = (\sum_(i in U) C i * P i * X i) / \sum_(i in U) C i * P i. Proof. rewrite /Ex big_distrl/=. -by under eq_bigr do rewrite Weighted.dE mulRCA mulRA. +by under eq_bigr do rewrite Weighted.dE mulrCA mulrA. Qed. End emean. Section sq_dev. Local Open Scope ring_scope. - -Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : nneg_finfun U) +Let R := Rdefinitions.R. +Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : {ffun U -> R}) (PC0 : Weighted.total P C != 0). - -Let WP := Weighted.d PC0. +Hypothesis C0 : forall u, 0 <= C u. +Let WP := Weighted.d C0 PC0. Definition sq_dev := (X `-cst `E (WP.-RV X))`^2. Lemma sq_dev_ge0 u : 0 <= sq_dev u. -Proof. by rewrite /sq_dev sq_RV_pow2; exact/RleP/pow2_ge_0. Qed. +Proof. by rewrite /sq_dev sq_RV_pow2 sqr_ge0. Qed. Definition sq_dev_max := \big[Order.max/0]_(i | C i != 0) sq_dev i. -Local Notation j := (sval (Weighted.support_nonempty PC0)). +Local Notation j := (sval (Weighted.support_nonempty C0 PC0)). Definition sq_dev_arg_max := [arg max_(i > j | C i != 0) sq_dev i]%O. @@ -419,17 +305,17 @@ Lemma compfid A B (f : A -> B) : f \o idfun = f. Proof. by []. Qed. Section evar. Local Open Scope ring_scope. - -Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : nneg_finfun U) +Let R := Rdefinitions.R. +Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : {ffun U -> R}) (PC0 : Weighted.total P C != 0). - -Let WP := Weighted.d PC0. +Hypothesis C0 : forall u, 0 <= C u. +Let WP := Weighted.d C0 PC0. Lemma evarE : `V_[WP.-RV X | setT] = `V (WP.-RV X). Proof. by rewrite Var_cVarT. Qed. Lemma evar0P : - reflect (forall i, C i * P i * sq_dev X PC0 i = 0) (`V (WP.-RV X) == 0). + reflect (forall i, C i * P i * sq_dev X PC0 C0 i = 0) (`V (WP.-RV X) == 0). Proof. rewrite /Var. rewrite (emean_sum (_ `^2)). @@ -442,28 +328,30 @@ rewrite mulf_eq0 => /orP []; last first. move/[swap] => i. rewrite psumr_eq0. by move/allP/(_ i)/[!mem_index_enum]/(_ erefl)/implyP/[!inE]/(_ erefl)/eqP->. -move=> x _; apply/mulr_ge0; last exact/RleP/pow2_ge_0. -by apply/mulr_ge0=> //; exact/nneg_finfun_ge0. +move=> x _; apply/mulr_ge0. + by rewrite mulr_ge0. +by rewrite sqr_ge0. Qed. End evar. Section pos_evar. Local Open Scope ring_scope. - -Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : nneg_finfun U). +Let R := Rdefinitions.R. +Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : {ffun U -> R}). +Hypothesis C0 : forall u, 0 <= C u. Hypothesis (PC0 : Weighted.total P C != 0). -Let WP := Weighted.d PC0. +Let WP := Weighted.d C0 PC0. Hypothesis (evar_gt0 : 0 < `V (WP.-RV X)). Lemma pos_evar_index : - exists i, 0 < C i * P i * sq_dev X PC0 i. + exists i, 0 < C i * P i * sq_dev X PC0 C0 i. Proof. move: evar_gt0; rewrite lt_neqAle eq_sym => /andP [] /[swap] _. case/evar0P/boolp.existsNP=> x /eqP ?; exists x. rewrite lt_neqAle eq_sym; apply/andP; split=> //. apply: mulr_ge0; last exact/sq_dev_ge0. -apply: mulr_ge0=> //; exact/nneg_finfun_ge0. +exact: mulr_ge0=> //. Qed. End pos_evar. @@ -473,26 +361,30 @@ Notation denom := ((3 / 10)^-1)%mcR. Section invariant. Local Open Scope ring_scope. +Let R := Rdefinitions.R. (**md ## eqn I, page 5 *) -Definition invariant (U : finType) (P : {fdist U}) (C : nneg_finfun U) +Definition invariant (U : finType) (P : {fdist U}) (C : {ffun U -> R}) (S : {set U}) (eps : R) := \sum_(i in S) (1 - C i) * P i <= (1 - eps) / 2 * \sum_(i in ~: S) (1 - C i) * P i. (**md ## page 62, line -1 *) -Definition invariantW (U : finType) (P : {fdist U}) (C : nneg_finfun U) +Definition invariantW (U : finType) (P : {fdist U}) (C : {ffun U -> R}) + (C0 : forall u, 0 <= C u) (S : {set U}) (eps : R) (PC0 : Weighted.total P C != 0) := - let WP := Weighted.d PC0 in + let WP := Weighted.d C0 PC0 in 1 - eps <= Pr WP S. End invariant. Section bounding_empirical_mean. Local Open Scope ring_scope. +Let R := Rdefinitions.R. -Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : nneg_finfun U) +Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : {ffun U -> R}) (S : {set U}) (eps_max : R). +Hypothesis C0 : forall u, 0 <= C u. Local Notation cplt_S := (~: S). Local Notation eps := (Pr P cplt_S). @@ -502,12 +394,12 @@ Hypotheses (eps_max01 : 0 < eps_max < 1) (C01 : is01 C) (PC0 : Weighted.total P Lemma pr_S : Pr P S = 1 - eps. Proof. by rewrite Pr_to_cplt. Qed. -Let eps0 : 0 <= eps. Proof. exact/RleP/Pr_ge0. Qed. +Let eps0 : 0 <= eps. Proof. exact/Pr_ge0. Qed. -Let WP := Weighted.d PC0. +Let WP := Weighted.d C0 PC0. -Let tau := sq_dev X PC0. -Let tau_max := sq_dev_max X PC0. +Let tau := sq_dev X PC0 C0. +Let tau_max := sq_dev_max X PC0 C0. Lemma pr_S_gt0 : 0 < Pr P S. Proof. by rewrite pr_S; move: eps0 low_eps eps_max01; lra. Qed. @@ -522,10 +414,10 @@ Lemma weight_contrib : (\sum_(i in S) C i * P i * tau i) / Pr P S <= `V_[X | S] + (`E_[X | S] - `E (WP.-RV X))^+2. Proof. apply (@le_trans _ _ (`E_[tau | S])); last first. - rewrite le_eqVlt/tau/sq_dev; apply/orP; left; exact/eqP/cVarDist/RltP. -rewrite cExE !coqRE ler_pM2r ?invr_gt0 //. + rewrite le_eqVlt/tau/sq_dev; apply/orP; left; exact/eqP/cVarDist. +rewrite cExE ler_pM2r ?invr_gt0 //. apply: ler_suml=> i HiS //. - rewrite !coqRE (mulrC (tau i)) ler_wpM2r ?sq_dev_ge0 //. + rewrite (mulrC (tau i)) ler_wpM2r ?sq_dev_ge0 //. have /andP [_ c1] := C01 i. have hp := FDist.ge0 P i. by rewrite -{2}(mul1r (P i)); apply ler_wpM2r. @@ -533,7 +425,7 @@ by rewrite mulr_ge0 // sq_dev_ge0. Qed. Let invariant := invariant P C S eps. -Let invariantW := invariantW S eps PC0. +Let invariantW := invariantW C0 S eps PC0. Lemma invariant_impl : invariant -> invariantW. Proof. @@ -559,7 +451,7 @@ rewrite {2}pr_S addrA -addrA mulrDr opprD addrC. rewrite -lerBlDr. rewrite opprK -mulrN addrC -mulrA mulVf; last by apply/eqP; lra. rewrite mulr1 opprD opprK. -rewrite sumRE -!sumrN -!big_split /=. +rewrite -!sumrN -!big_split /=. have H E : \sum_(i in E) (P i + - (C i * P i)) = \sum_(i in E) (1 - C i) * P i. by apply eq_bigr => i _; rewrite mulrBl mul1r. by rewrite !H pr_S. @@ -578,14 +470,14 @@ Lemma bound_emean : invariantW -> Proof. move=> invC; have pSC:= invariantW_pr_S_neq0 invC. have vhe0: 0 <= `V (WP.-RV X) * 2 * eps / (1 - eps). - rewrite mulr_ge0 // ?invr_ge0 // ?subr_ge0 // -?mulrA ?mulr_ge0 // ?variance_ge0' //. + rewrite mulr_ge0 // ?invr_ge0 // ?subr_ge0 // -?mulrA ?mulr_ge0 // ?variance_ge0 //. by move: low_eps eps_max01; lra. suff h : `| `E (WP.-RV X) - `E_[WP.-RV X | S] | <= Num.sqrt (`V (WP.-RV X) * 2 * eps / (1 - eps)). rewrite -real_normK ?num_real // -[leRHS]sqr_sqrtr //. by rewrite lerXn2r // ?nnegrE ?sqrtr_ge0. rewrite distrC {1}(_ : eps = 1 - (1 - eps)); last by lra. set delta := 1 - eps. -apply: resilience'=> //. +apply: resilience=> //. by rewrite /delta; move: low_eps eps_max01; lra. Qed. @@ -602,8 +494,7 @@ apply (@le_trans _ _ (1 - (1 - eps) / 2 / Pr P S * rewrite lerD2l lerNl opprK ler_pM2l; last first. rewrite pr_S mulrC mulrA mulVf //; lra. apply ler_sum => i icplt_S. - rewrite mulrBr mulr1 lerBlDr lerDl. apply: mulr_ge0 => //. - by have /andP [] := C01 i. + by rewrite mulrBr mulr1 lerBlDr lerDl; exact: mulr_ge0. rewrite -pr_S -mulrA mulrCA !mulrA mulVf ?pr_S // mul1r. rewrite ler_pdivlMr; last by move: low_eps eps_max01; lra. rewrite -pr_S mulrDl mul1r {2}pr_S mulNr. @@ -619,30 +510,30 @@ Lemma bound_mean : invariant -> (`E_[X | S] - `E_[WP.-RV X | S])^+2 <= `V_[X | S] * 2 * eps / (2 - eps). Proof. move=> Hinv. -have -> : `E_[X | S] = `E_[Split.fst_RV C01 X | S `* [set: bool]]. +have -> : `E_[X | S] = `E_[Split.fst_RV C0 C01 X | S `* [set: bool]]. by rewrite -Split.cEx. -have -> : `E_[WP.-RV X | S] = `E_[Split.fst_RV C01 X | S `* [set true]]. +have -> : `E_[WP.-RV X | S] = `E_[Split.fst_RV C0 C01 X | S `* [set true]]. by rewrite emean_cond_split. rewrite sqrBC. -apply: (@le_trans _ _ (`V_[ Split.fst_RV C01 X | S `* [set: bool]] * +apply: (@le_trans _ _ (`V_[ Split.fst_RV C0 C01 X | S `* [set: bool]] * 2 * (1 - (1 - eps / 2)) / (1 - eps / 2))). - have V0: 0 <= `V_[ Split.fst_RV C01 X | S `* [set: bool]] * + have V0: 0 <= `V_[ Split.fst_RV C0 C01 X | S `* [set: bool]] * 2 * (1 - (1 - eps / 2)) / (1 - eps / 2). apply: mulr_ge0; last by rewrite invr_ge0; move: low_eps eps_max01; lra. apply: mulr_ge0; last by move: eps0 low_eps; lra. apply: mulr_ge0 => //. - exact: cvariance_ge0'. + exact: cvariance_ge0. rewrite -ler_sqrt // sqrtr_sqr. - apply: cresilience'. + apply: cresilience. + move: low_eps eps_max01; lra. + have := S_mass Hinv. - rewrite -Split.Pr_setXT [in X in _ -> _ <= X]/Pr !sumRE big_setX /= => /le_trans; apply. + rewrite -Split.Pr_setXT [in X in _ -> _ <= X]/Pr big_setX /= => /le_trans; apply. rewrite le_eqVlt; apply/orP; left; apply/eqP. congr (_ / _); apply: eq_bigr => u uS. by rewrite big_set1 Split.dE. + exact/setXS. rewrite Split.cVar -(mulrA _ eps) -(mulrA _ (1 - _)). -apply: ler_wpM2l; first by apply mulr_ge0; [exact: cvariance_ge0'|lra]. +apply: ler_wpM2l; first by apply mulr_ge0; [exact: cvariance_ge0|lra]. rewrite opprB addrCA subrr addr0. rewrite -mulrA -invfM mulrDr mulr1 mulrN. rewrite mulrCA divff ?mulr1 //. @@ -657,18 +548,18 @@ Proof. move=> IC. have I1C : invariantW by exact: invariant_impl. apply: (le_trans (ler_distD `E_[ (WP.-RV X) | S ] `E_[ X | S ] (`E (WP.-RV X)))). -have ? : 0 <= eps by apply/RleP/Pr_ge0. +have ? : 0 <= eps by apply/Pr_ge0. apply: lerD. - rewrite -(ger0_norm (sqrtr_ge0 _)). rewrite ler_abs_sqr sqr_sqrtr; first rewrite bound_mean//. - rewrite -!mulrA; apply/mulr_ge0; first exact: cvariance_ge0'. + rewrite -!mulrA; apply/mulr_ge0; first exact: cvariance_ge0. rewrite mulr_ge0 // mulr_ge0 // invr_ge0. by move: low_eps eps0 eps_max01; lra. - rewrite distrC -(ger0_norm (sqrtr_ge0 _)). rewrite ler_abs_sqr sqr_sqrtr ?bound_mean //. + exact: bound_emean. + apply: mulr_ge0; last by rewrite invr_ge0; move: low_eps eps_max01; lra. - by rewrite mulr_ge0 // mulr_ge0 // variance_ge0'. + by rewrite mulr_ge0 // mulr_ge0 // variance_ge0. Qed. End bounding_empirical_mean. @@ -679,12 +570,13 @@ Arguments bound_mean_emean [_ _ _] C [_] eps_max. (** WIP *) Section update. Local Open Scope ring_scope. - -Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : nneg_finfun U). +Let R := Rdefinitions.R. +Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : {ffun U -> R}). +Hypothesis C0 : forall u, 0 <= C u. Hypotheses (PC0 : Weighted.total P C != 0). -Let tau := sq_dev X PC0. -Let tau_max := sq_dev_max X PC0. +Let tau := sq_dev X PC0 C0. +Let tau_max := sq_dev_max X PC0 C0. Definition arg_tau_max := [arg max_(i > (fdist_supp_choice P) in [set: U]) tau i]%O. @@ -693,35 +585,35 @@ Definition update_ffun : {ffun U -> R} := [ffun i => if (tau_max == 0) || (C i == 0) then 0 else C i * (1 - tau i / tau_max)]. -Lemma update_pos_ffun : [forall a, 0 <= update_ffun a]%mcR. +Lemma update_pos_ffun : (forall a, 0 <= update_ffun a)%mcR. Proof. -apply/forallP=> i; apply/RleP. +move=> i. rewrite /update_ffun ffunE. -case: ifPn; first by move=> ?; exact: Rle_refl. +case: ifPn => //. case/norP=> tau_max_neq0 Ci_neq0. -apply/RleP/mulr_ge0; first exact/nneg_finfun_ge0. +apply/mulr_ge0 => //. rewrite subr_ge0 ler_pdivrMr ?mul1r; first exact/sq_dev_max_ge. by rewrite lt_neqAle eq_sym tau_max_neq0/=; exact/sq_dev_max_ge0. Qed. -Definition update : nneg_finfun U := mkNNFinfun update_pos_ffun. +(*Definition update : nneg_finfun U := mkNNFinfun update_pos_ffun.*) End update. (** part 2 of lemma 1.4 *) Section bounding_empirical_variance. Local Open Scope ring_scope. - -Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : nneg_finfun U) (S : {set U}). - +Let R := Rdefinitions.R. +Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : {ffun U -> R}) (S : {set U}). +Hypothesis C0 : forall u, 0 <= C u. Local Notation cplt_S := (~: S). Local Notation eps := (Pr P cplt_S). Hypotheses (C01 : is01 C) (PC0 : Weighted.total P C != 0). -Let WP := Weighted.d PC0. +Let WP := Weighted.d C0 PC0. -Let eps0 : 0 <= eps. Proof. exact/RleP/Pr_ge0. Qed. +Let eps0 : 0 <= eps. Proof. exact/Pr_ge0. Qed. (* Let mu := `E_[X | S]. *) (* Let var := `V_[X | S]. *) @@ -729,11 +621,11 @@ Let eps0 : 0 <= eps. Proof. exact/RleP/Pr_ge0. Qed. (* Let mu_hat := `E (WP.-RV X). *) (* Let var_hat := `V (WP.-RV X). *) -Let tau := sq_dev X PC0. -Let tau_max := sq_dev_max X PC0. +Let tau := sq_dev X PC0 C0. +Let tau_max := sq_dev_max X PC0 C0. Let invariant := invariant P C S eps. -Let invariantW := invariantW S eps PC0. +Let invariantW := invariantW C0 S eps PC0. Hypotheses (var16 : 16 * `V_[X | S] <= `V (WP.-RV X)) (IC : invariant). @@ -757,19 +649,19 @@ have Heps2 : 0 <= 2 - eps by move: low_eps eps_max01; lra. have Heps2' : 0 < 2 - eps by move: low_eps eps_max01; lra. have Heps2'' : 0 <= 2 * eps by move: eps0; lra. have H44eps2 : 0 <= 4 * 4 * (2 - eps) by move: low_eps; lra. -have Hvar_hat0 : 0 <= `V (WP.-RV X) by exact: variance_ge0'. +have Hvar_hat0 : 0 <= `V (WP.-RV X) by exact: variance_ge0. have Hvar_hat_2_eps : 0 <= `V (WP.-RV X) * 2 * eps by rewrite -mulrA; apply: mulr_ge0. -have Hvar0 : 0 <= `V_[X | S] by exact: cvariance_ge0'. +have Hvar0 : 0 <= `V_[X | S] by exact: cvariance_ge0. have ? := pr_S_gt0 eps_max01 low_eps. (*a6*) apply (@le_trans _ _ ((1 - eps) * (`V_[X | S] + (`E_[X | S] - `E (WP.-RV X))^+2))). - by rewrite -!pr_S mulrC -ler_pdivrMr // (weight_contrib _ eps_max01). + by rewrite -!pr_S mulrC -ler_pdivrMr // (weight_contrib _ C0 eps_max01). (*a6-a7*) apply (@le_trans _ _ ((1 - eps) * (`V_[X | S] + (Num.sqrt (`V_[X | S] * 2 * eps / (2 - eps)) + Num.sqrt (`V (WP.-RV X) * 2 * eps / (1 - eps)))^+2))). apply ler_wpM2l. - by rewrite subr_ge0; exact/RleP/Pr_le1. + by rewrite subr_ge0; exact/Pr_le1. rewrite lerD2l -ler_abs_sqr. rewrite [x in _ <= x]ger0_norm; first exact: (bound_mean_emean C eps_max). exact/addr_ge0/sqrtr_ge0/sqrtr_ge0. @@ -786,8 +678,7 @@ apply (@le_trans _ _ ((1 - eps) * `V (WP.-RV X) * rewrite -exprMn (mulrDr (Num.sqrt (`V (WP.-RV X) * 2 * eps))). rewrite ler_sqr ?nnegrE; last 2 first. - by apply/addr_ge0/sqrtr_ge0/sqrtr_ge0. - - by rewrite ?addr_ge0 ?mulr_ge0 ?invr_ge0 ?mulr_ge0 //; - apply/RleP; rewrite -?RsqrtE';rewrite -!coqRE; try exact/sqrt_pos. + - by rewrite ?addr_ge0 ?mulr_ge0 ?invr_ge0 ?mulr_ge0 ?sqrtr_ge0//. apply: lerD. apply: (@le_trans _ _ (Num.sqrt (`V (WP.-RV X) * 2 * eps * (4 * 4 * (2 - eps))^-1))); last first. rewrite sqrtrM // sqrtrV //. @@ -804,7 +695,7 @@ apply (@le_trans _ _ ((1 - eps) * `V (WP.-RV X) * by rewrite -[leLHS]mulrA -[leRHS]mulrA ler_pM // mulr_ge0. by rewrite -sqrtrV // -sqrtrM // sqr_sqrtr. rewrite /bound_intermediate [leRHS]mulrC (mulrC (1 - eps)). -by rewrite ?coqRE !mulrA. +by rewrite !mulrA. Qed. Lemma bound_evar_ineq_S : @@ -820,10 +711,10 @@ have Heps2 : 0 <= 2 - eps by move: low_eps eps_max01; lra. have Heps2' : 0 < 2 - eps by move: low_eps eps_max01; lra. have Heps2'' : 0 <= 2 * eps by move: eps0; lra. have H44eps2 : 0 <= 4 * 4 * (2 - eps) by move: low_eps; lra. -have Hvar_hat0 : 0 <= `V (WP.-RV X) by exact: variance_ge0'. +have Hvar_hat0 : 0 <= `V (WP.-RV X) by exact: variance_ge0. have Hvar_hat_2_eps : 0 <= `V (WP.-RV X) * 2 * eps by rewrite -mulrA; apply: mulr_ge0. -have Hvar0 : 0 <= `V_[X | S] by exact: cvariance_ge0'. +have Hvar0 : 0 <= `V_[X | S] by exact: cvariance_ge0. have ? := pr_S_gt0 eps_max01 low_eps. apply: (le_trans bound_evar_ineq_S_intermediate). rewrite /bound_intermediate. @@ -837,10 +728,13 @@ apply (@le_trans _ _ ((1 - eps) * apply:addr_ge0; first lra. rewrite mulr_ge0 //. exact: sqr_ge0. - - apply: ler_pM=> //. apply: addr_ge0; first lra. rewrite mulr_ge0//. exact: sqr_ge0. + - apply: ler_pM=> //. + apply: addr_ge0; first lra. + rewrite mulr_ge0//. + exact: sqr_ge0. - apply: lerD => //. apply: ler_pM=> //; first exact: sqr_ge0. - by move: low_eps; rewrite 2?coqRE 2?(_ : 2%coqR = 2)//; lra. + by move: low_eps; lra. rewrite lerXn2r // ?nnegrE ?addr_ge0 //?invr_ge0 ?mulr_ge0 // ?sqrtr_ge0 //. rewrite lerD ?lerXn2r // ?nnegrE ?addr_ge0 //?invr_ge0 ?mulr_ge0 // ?sqrtr_ge0 //. rewrite ?lef_pV2 ?posrE ?mulr_gt0 // ?sqrtr_gt0 //; last by move: eps_max01; lra. @@ -864,7 +758,10 @@ Hypothesis low_eps : eps <= eps_max. (* TODO: "interval" in the identifier? *) Lemma bound_evar_ineq_by_interval : bound_evar_ineq eps_max. -Proof. by rewrite /bound_evar_ineq/bound_intermediate; apply/RleP; rewrite -!coqRE -!RsqrtE'; interval. Qed. +Proof. +rewrite /bound_evar_ineq/bound_intermediate. +apply/RleP; rewrite -!coqRE.coqRE; interval. +Qed. (**md ## lemma 1.4, page 5 (part 2) *) (**md ## eqn A.6--A.9, page 63 *) @@ -885,12 +782,12 @@ have -> : \sum_(i in cplt_S) C i * P i * tau i = apply/esym/eqP; rewrite subr_eq -bigID2 /=. under [eqbRHS]eq_bigr do rewrite if_same. rewrite big_distrl /=; apply/eqP/eq_bigr=> i _. - rewrite !coqRE /tau [in RHS]mulrC !mulrA. + rewrite /tau [in RHS]mulrC !mulrA. rewrite Weighted.dE -/(Weighted.total P C). - by rewrite -!mulrA !mul1r mulVf // mulr1. -apply:(@le_trans _ _ (`V (WP.-RV X) * (1 - 3 / 2 * eps) - + by rewrite -!mulrA mulVf // mulr1//. +apply: (@le_trans _ _ (`V (WP.-RV X) * (1 - 3 / 2 * eps) - \sum_(i in S) C i * P i * tau i)); last first. - rewrite lerD2r ler_wpM2l // ?variance_ge0' //. + rewrite lerD2r ler_wpM2l // ?variance_ge0 //. apply: (@le_trans _ _ ((1 - eps / 2) * (1 - eps))); first nra. apply: (@le_trans _ _ (\sum_(i in S) C i * P i)). rewrite -pr_S -ler_pdivlMr; last by move: low_eps; lra. @@ -903,16 +800,16 @@ apply (@le_trans _ _ ((1 - 3 / 2 * eps - (1 - eps) * bound_intermediate eps) * ` have ->// : 2 / denom * `V (WP.-RV X) <= (1 - 3 / 2 * eps - (1 - eps) * bound_intermediate eps) * `V (WP.-RV X). -rewrite ler_wpM2r // ?variance_ge0' // /bound_intermediate. -apply/RleP. move: low_eps => /RleP. move: eps0 => /RleP. -rewrite -!coqRE -!RsqrtE' => ? ?. -interval with (i_prec 20, i_bisect eps). +rewrite ler_wpM2r // ?variance_ge0 // /bound_intermediate. +apply/RleP; move: low_eps => /RleP. move: eps0 => /RleP. +rewrite -!coqRE.coqRE => ? ?. +interval with (i_bisect eps). Qed. (**md ## eqn 1.3--1.4, page 7 *) (* TODO: improve the notation for pos_ffun (and for pos_fun) *) Lemma update_removed_weight (E : {set U}) : - let C' := update X PC0 in + let C' := update_ffun X C0 PC0 in 0 < tau_max -> \sum_(i in E) (1 - C' i) * P i = (\sum_(i in E) (1 - C i) * P i) + @@ -921,10 +818,16 @@ Proof. move => C' tau_max_gt0. have <- : \sum_(i in E) (C i - C' i) * P i= 1 / tau_max * (\sum_(i in E) C i * P i * tau i). - rewrite /C' /update big_distrr. + rewrite /C' big_distrr/= /update_ffun/=. apply eq_bigr => i _ /=. rewrite /update_ffun-/tau_max-/tau ffunE. - by case: ifPn => [/orP[/eqP|/eqP->]|]; lra. + case: ifPn => [/orP[/eqP|/eqP->]|]. + lra. + lra. + rewrite negb_or => /andP[? ?]. + rewrite mulrBr mulr1 opprB addrCA subrr addr0. + rewrite mul1r [in RHS]mulrC. + by rewrite mulrAC mulrA. by rewrite -big_split/=; apply eq_bigr => i HiE; rewrite -mulrDl addrA subrK. Qed. @@ -932,49 +835,50 @@ End bounding_empirical_variance. Section update_invariant. Local Open Scope ring_scope. - -Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : nneg_finfun U) (S : {set U}). +Let R := Rdefinitions.R. +Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (C : {ffun U -> R}) (S : {set U}). +Hypothesis C0 : forall u, 0 <= C u. Local Notation cplt_S := (~: S). Local Notation eps := (Pr P cplt_S). Hypotheses (PC0 : Weighted.total P C != 0) (C01 : is01 C). -Let WP := Weighted.d PC0. +Let WP := Weighted.d C0 PC0. (* Let var_hat := evar X PC0. *) (* Let var := `V_[X | S]. *) Let tau := sq_dev X PC0. -Let tau_max := sq_dev_max X PC0. +Let tau_max := sq_dev_max X PC0 C0. Hypotheses (low_eps : eps <= eps_max) (var16 : 16 * `V_[X | S] < `V (WP.-RV X)). -Lemma sq_dev_max_neq0 : 0 < `V (WP.-RV X) -> sq_dev_max X PC0 != 0. +Lemma sq_dev_max_neq0 : 0 < `V (WP.-RV X) -> sq_dev_max X PC0 C0 != 0. Proof. rewrite /sq_dev_max => var_hat_gt0. -have PCge0 := ltW (weighted_total_gt0 PC0). +have PCge0 := ltW (weighted_total_gt0 C0 PC0). move: var_hat_gt0. rewrite /Var. -move=> /fsumr_gt0[i _]. rewrite !coqRE. +move=> /fsumr_gt0[i _]. rewrite Weighted.dE => /[dup]/wpmulr_lgt0 sq_dev_gt0. -have /RleP/wpmulr_rgt0/[apply] := sq_RV_ge0 (X `-cst \sum_(v in U) X v * Weighted.d PC0 v) i. +have /wpmulr_rgt0/[apply] := sq_RV_ge0 (X `-cst \sum_(v in U) X v * Weighted.d C0 PC0 v) i. have:= PCge0; rewrite -invr_ge0=> /wpmulr_lgt0 /[apply]. have /[apply] Cigt0 := wpmulr_lgt0 (FDist.ge0 P i). -rewrite gt_eqF //; apply/bigmax_gt0_seq; exists i. +rewrite gt_eqF //; apply/bigmax_gt0P_seq; exists i. split=> //; first by rewrite gt_eqF. by rewrite sq_dev_gt0 // mulr_ge0 // ?mulr_ge0 // ?nneg_finfun_ge0 // invr_ge0 PCge0. Qed. (**md ## lemma 1.5, page 5, update preserves the invariant of filter1D *) -Lemma invariant_update : let C' := update X PC0 in +Lemma invariant_update : let C' := update_ffun X C0 PC0 in invariant P C S eps -> invariant P C' S eps. Proof. simpl=> inv. -have var_ge0 : 0 <= `V_[X | S] by exact: cvariance_ge0'. -have tau_max_gt0 : 0 < sq_dev_max X PC0. +have var_ge0 : 0 <= `V_[X | S] by exact: cvariance_ge0. +have tau_max_gt0 : 0 < sq_dev_max X PC0 C0. by rewrite lt_neqAle eq_sym sq_dev_max_neq0 ?sq_dev_max_ge0 //; move: var16; lra. -suff H2 : \sum_(i in S) (C i * P i) * tau i <= - (1 - eps) / 2 * (\sum_(i in ~: S) (C i * P i) * tau i). +suff H2 : \sum_(i in S) (C i * P i) * tau C0 i <= + (1 - eps) / 2 * (\sum_(i in ~: S) (C i * P i) * tau C0 i). rewrite /invariant !update_removed_weight// !mulrDr; apply lerD => //. by rewrite mulrCA; rewrite ler_pM2l; [exact: H2 | exact: divr_gt0]. have var16':= ltW var16. @@ -985,13 +889,12 @@ rewrite -(mulrA 2) mulVf ?mulr1; last by move: low_eps; lra. by apply: le_trans; last exact: bound_empirical_variance_cplt_S. Qed. -Lemma is01_update : is01 (update X PC0). +Lemma is01_update : is01 (update_ffun X C0 PC0). Proof. -move=> u; apply/andP; split; first by have/forallP := update_pos_ffun X PC0. +move=> u; apply/andP; split; first by have := update_pos_ffun X C0 PC0. rewrite /update_ffun ffunE; case: ifPn; first lra. rewrite negb_or => /andP[sq_dev_neq0 Cu_neq0]. -apply: mulr_ile1. -- exact: nneg_finfun_ge0. +apply: mulr_ile1 => //. - rewrite subr_ge0 ler_pdivrMr// ?mul1r//; last first. by rewrite lt_neqAle eq_sym sq_dev_neq0/=; exact: sq_dev_max_ge0. exact: sq_dev_max_ge. @@ -1003,7 +906,7 @@ End update_invariant. Section base_case. Local Open Scope ring_scope. - +Let R := Rdefinitions.R. (* TODO: define a proper environment *) Variables (A : finType) (P : {fdist A}) (S : {set A}). @@ -1011,25 +914,24 @@ Local Notation cplt_S := (~: S). Local Notation eps := (Pr P cplt_S). Definition ffun1 : {ffun A -> R} := [ffun=> 1]. -Let ffun1_subproof : [forall a, 0 <= ffun1 a]. -Proof. by apply/forallP => u; rewrite ffunE; apply/RleP. Qed. -Definition Cpos_ffun1 := @mkNNFinfun A ffun1 ffun1_subproof. +Lemma ffun1_subproof : forall a, 0 <= ffun1 a. +Proof. by move=> u; rewrite ffunE. Qed. +(*Definition Cpos_ffun1 := @mkNNFinfun A ffun1 ffun1_subproof.*) -Lemma PC1_neq0 : Weighted.total P Cpos_ffun1 != 0. +Lemma PC1_neq0 : Weighted.total P ffun1 != 0. Proof. rewrite/Weighted.total. -under eq_bigr => i _ do rewrite /Cpos_ffun1/=/ffun1 ffunE mul1r. +under eq_bigr => i _ do rewrite /ffun1_subproof/=/ffun1 ffunE mul1r. rewrite FDist.f1. apply oner_neq0. Qed. -Lemma C1_is01 : is01 Cpos_ffun1. +Lemma C1_is01 : is01 ffun1. Proof. by move => i; rewrite ffunE; lra. Qed. -Lemma base_case: invariant P Cpos_ffun1 S eps. +Lemma base_case: invariant P ffun1 S eps. Proof. -rewrite /invariant. -rewrite /Cpos_fun /=. +rewrite /invariant/=. under eq_bigr do rewrite ffunE subrr mul0r. rewrite big1; last by []. under eq_bigr do rewrite ffunE subrr mul0r. @@ -1041,39 +943,40 @@ End base_case. Require Import FunInd Recdef. -Notation "a '<=?' b" := (Bool.bool_dec (Rleb a b) true). +Notation "a '<=?' b" := (Bool.bool_dec (Rleb a b) true) (at level 70). Notation "a '!=?' b" := (Bool.bool_dec (a != b) true) (at level 70). (**md ## Algorithm 2, page 4 *) Section filter1D. Local Open Scope ring_scope. +Let R := Rdefinitions.R. Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}). Local Obligation Tactic := idtac. -Lemma filter1D_arg_decreasing (C : nneg_finfun U) (v : R) : +Lemma filter1D_arg_decreasing (C : {ffun U -> R}) (C0 : forall u, 0 <= C u) (v : R) : 0 <= v -> is01 C -> forall PC0 : Weighted.total P C != 0, - let WP := wgt PC0 in + let WP := wgt C0 PC0 in forall K : Rleb (`V (WP.-RV X)) (16 * v) <> true, - (#|0.-support (update X PC0)| < #|0.-support C|)%coq_nat. + (#|0.-support (update_ffun X C0 PC0)| < #|0.-support C|)%coq_nat. Proof. rewrite/Weighted.total=> v_ge0 C01 PCneq0 /negP/RlebP/RleP. -rewrite -ltNge !coqRE=> evar16. +rewrite -ltNge => evar16. apply/ssrnat.ltP/proper_card/properP; split. apply/subsetP => u; rewrite !supportE /update_ffun ffunE. by case: ifPn; [rewrite eqxx|rewrite negb_or => /andP[]]. -have PCgt0 := weighted_total_gt0 PCneq0. +have PCgt0 := weighted_total_gt0 C0 PCneq0. have PCge0 := ltW PCgt0. move: (PCgt0) => /fsumr_gt0[u _]. -rewrite mulr_ge0_gt0// => [/andP[Cu0 Pu0]|]; last by have/andP[]:= C01 u. -have Cmax_neq0 : C [arg max_(i > u | C i != 0) sq_dev X PCneq0 i]%O != 0. +rewrite mulr_ge0_gt0// => /andP[Cu0 Pu0]. +have Cmax_neq0 : C [arg max_(i > u | C i != 0) sq_dev X PCneq0 C0 i]%O != 0. by case: arg_maxP => //; rewrite gt_eqF. -have sq_dev_max_neq0 : sq_dev_max X PCneq0 != 0. +have sq_dev_max_neq0 : sq_dev_max X PCneq0 C0 != 0. apply/sq_dev_max_neq0/(le_lt_trans _ evar16). by rewrite mulr_ge0 //; apply/ltW/RltP/IPR_gt_0. -exists [arg max_(i > u | C i != 0) sq_dev X PCneq0 i]%O. +exists [arg max_(i > u | C i != 0) sq_dev X PCneq0 C0 i]%O. by rewrite supportE. rewrite /update_ffun supportE ffunE negbK ifF. rewrite mulf_eq0 subr_eq0 -invr1 -(mul1r (1^-1))%mcR. @@ -1084,30 +987,31 @@ by rewrite (negbTE sq_dev_max_neq0)/=; exact/negbTE. Qed. Function filter1D_rec v (v_ge0 : 0 <= v) - (C : nneg_finfun U) (C01 : is01 C) (PC0 : Weighted.total P C != 0) + (C : {ffun U -> R}) (C0 : forall u, 0 <= C u) (C01 : is01 C) (PC0 : Weighted.total P C != 0) {measure (fun C => #| 0.-support C |) C} := - let WP := wgt PC0 in + let WP := wgt C0 PC0 in if `V (WP.-RV X) <=? 16 * v is left _ then Some (`E (WP.-RV X)) else - let C' := update X PC0 in + let C' := update_ffun X C0 PC0 in if Weighted.total P C' !=? 0 is left PC0' then - filter1D_rec v_ge0 (is01_update X PC0 C01) PC0' + filter1D_rec v_ge0 (update_pos_ffun _ C0 PC0) (is01_update X C0 PC0 C01) PC0' else None. Proof. -rewrite/Weighted.total=> v v_ge0 C C01 PC0 evar16 h2 h3 _. +rewrite/Weighted.total=> v v_ge0 C C0 C01 PC0 evar16 h2 h3 _. exact: (filter1D_arg_decreasing v_ge0). Qed. -Definition filter1D v (v_ge0 : 0 <= v) := filter1D_rec v_ge0 (@C1_is01 U) (PC1_neq0 P). +Definition filter1D v (v_ge0 : 0 <= v) := + filter1D_rec v_ge0 (@ffun1_subproof U) (@C1_is01 U) (PC1_neq0 P). End filter1D. - Section filter1D_correct. Local Open Scope ring_scope. +Let R := Rdefinitions.R. Variables (U : finType) (P : {fdist U}) (X : {RV P -> R}) (S : {set U}). Local Notation cplt_S := (~: S). @@ -1115,8 +1019,8 @@ Local Notation eps := (Pr P cplt_S). Hypothesis low_eps : eps <= eps_max. (* Let mu := `E_[X | S]. *) (* Let v := `V_[X | S]. *) -Let v_ge0 := cvariance_ge0' X S. -Let eps0 : 0 <= eps. Proof. exact/RleP/Pr_ge0. Qed. +Let v_ge0 := cvariance_ge0 X S. +Let eps0 : 0 <= eps. Proof. exact/Pr_ge0. Qed. Functional Scheme filter1D_rec_ind := Induction for filter1D_rec Sort Prop. @@ -1127,28 +1031,28 @@ Lemma filter1D_correct : Num.sqrt (16 * v * (2 * eps) / (1 - eps)) else false. Proof. -have sixteenE: 16%coqR = 16 by rewrite /16%coqR -INR_IPR /= coqRE. +(*have sixteenE: 16%coqR = 16 by rewrite /16%coqR -INR_IPR /= coqRE.*) rewrite /filter1D. have tr x y : Rleb x y <> true -> y < x by move=> /negP/RlebP/RleP; rewrite -ltNge. have tr' x y : Rleb x y = true -> x <= y by move=> /RlebP/RleP. have := base_case P S. apply filter1D_rec_ind => //=. -- move=> C C01 PC0 /tr' evar16 _ Inv. +- move=> C C0 C01 PC0 /tr' evar16 _ Inv. apply: le_trans; first by apply (bound_mean_emean C eps_max) => //; lra. apply lerD; first by rewrite mulrA. rewrite ler_wsqrtr // ler_wpM2r //. by rewrite invr_ge0; move: low_eps; lra. - rewrite -mulrA ler_wpM2r //; first by move: eps0; lra. - by move: evar16; rewrite !coqRE sixteenE. -- move=> C C01 PC_neq0 [//|/=] evar16 _ _ PC0 _ IH Inv. + by rewrite -mulrA ler_wpM2r //; first by move: eps0; lra. +- move=> C C0 C01 PC_neq0 [//|/=] evar16 _ _ PC0 _ IH Inv. apply/IH/invariant_update => //. - by move/tr: evar16; rewrite !coqRE sixteenE. -- move=> C C01 PC0 [//|] evar16 _ /= _ [//|/=] PC_eq0 _ /= _. - move/tr: evar16; rewrite !coqRE sixteenE. + by move/tr: evar16. +- move=> C C0 C01 PC0 [//|] evar16 _ /= _ [//|/=] PC_eq0 _ /= _. + move/tr: evar16. move=> evar16 /(invariant_update C01 low_eps evar16). - have PC0' : forall x, update X PC0 x * P x = 0. - move: PC_eq0=> /negP/negbNE; rewrite psumr_eq0; - last by move=> i _; rewrite mulr_ge0 ?nneg_finfun_ge0. + have PC0' : forall x, update_ffun X C0 PC0 x * P x = 0. + move: PC_eq0=> /negP/negbNE; rewrite psumr_eq0; last first. + move=> u _. + by rewrite mulr_ge0// update_pos_ffun. by move/allP=> PC0' x; apply/eqP/PC0'/mem_index_enum. rewrite /invariant. under eq_bigr do rewrite mulrDl mulNr PC0' subr0 mul1r. diff --git a/toy_examples/conditional_entropy.v b/toy_examples/conditional_entropy.v index ab66d9cf..13e6f02c 100644 --- a/toy_examples/conditional_entropy.v +++ b/toy_examples/conditional_entropy.v @@ -1,9 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) From mathcomp Require Import all_ssreflect ssralg ssrnum fingroup finalg matrix. -Require Import Reals Lra. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext realType_ext logb ssr_ext ssralg_ext bigop_ext fdist. +From mathcomp Require Import ring lra. +From mathcomp Require Import Rstruct reals. +Require Import ssr_ext ssralg_ext bigop_ext realType_ext realType_ln fdist. Require Import proba jfdist_cond entropy. (******************************************************************************) @@ -15,18 +15,20 @@ Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. -Local Open Scope R_scope. +Local Open Scope ring_scope. Local Open Scope fdist_scope. Local Open Scope proba_scope. -Module conditional_entropy_example. +Import GRing.Theory Num.Theory Order.Theory. +Module conditional_entropy_example. +Definition R := Rdefinitions.R. Definition zero : 'I_4 := ord0. Definition one : 'I_4 := @Ordinal 4 1 isT. Definition two : 'I_4 := @Ordinal 4 2 isT. Definition three : 'I_4 := @Ordinal 4 3 isT. -Definition f := [ffun x : 'I_4 * 'I_4 => [eta (fun=>0) with +Definition f := [ffun x : 'I_4 * 'I_4 => [eta (fun=>(0:R)) with (zero, zero) |-> (1/8), (zero, one) |-> (1/16), (zero, two) |-> (1/16), (zero, three) |-> (1/4), (one, zero) |-> (1/16), (one, one) |-> (1/8), (one, two) |-> (1/16), (one, three) |-> 0, (two, zero) |-> (1/32), (two, one) |-> (1/32), (two, two) |-> (1/16), (two, three) |-> 0, @@ -34,8 +36,7 @@ Definition f := [ffun x : 'I_4 * 'I_4 => [eta (fun=>0) with Lemma f0 : forall x, (0 <= f x)%mcR. Proof. -move=> x; rewrite ffunE; apply/RleP; move: x. -rewrite (_ : 0%mcR = 0)//. +move=> x; rewrite ffunE; move: x. case => -[ [? [[|[|[|[|[]//]]]]] | [? [[|[|[|[|[]//]]]]] | [? [[|[|[|[|[]//]]]]] @@ -46,7 +47,7 @@ Lemma f1 : \sum_(x in {: 'I_4 * 'I_4}) f x = 1. Proof. rewrite (eq_bigr (fun x => f (x.1, x.2))); last by case. rewrite -(pair_bigA _ (fun x1 x2 => f (x1, x2))) /=. -rewrite !big_ord_recl !big_ord0 /f /= !ffunE /=; field. +by rewrite !big_ord_recl !big_ord0 /f /= !ffunE /=; field. Qed. Definition d : {fdist 'I_4 * 'I_4} := locked (FDist.make f0 f1). @@ -58,31 +59,28 @@ Lemma conditional_entropyE : cond_entropy d = 11/8. Proof. rewrite /cond_entropy /=. rewrite !big_ord_recl big_ord0 !fdist_sndE /=. -rewrite !big_ord_recl big_ord0. -repeat (rewrite dE /f /= ffunE /=) . -rewrite -!coqRE; field_simplify. +rewrite !big_ord_recl !big_ord0. +repeat (rewrite dE /f /= ffunE /=). +rewrite !(add0r,addr0). rewrite /cond_entropy1 /=. rewrite !big_ord_recl big_ord0. rewrite /jcPr /Pr. repeat (rewrite big_setX /= !big_set1 dE /f /= ffunE /=). -rewrite !divRE; ring_simplify. rewrite !fdist_sndE /=. rewrite !big_ord_recl !big_ord0. repeat (rewrite dE /f /= ffunE /=). -rewrite -!coqRE. -field_simplify. -rewrite !addR0. +rewrite !(add0r,addr0). rewrite (_ : 1/32 + 1/32 = 1/16); last lra. -rewrite (addRCA (1/16)). -rewrite (addRA (1/16)). +rewrite (addrCA (1/16)). +rewrite (addrA (1/16)). rewrite (_ : 1/16 + 1/16 = 1/8); last lra. rewrite (_ : 1/8 + 1/8 = 1/4); last lra. -rewrite !divRE invRM; [|apply/eqP;lra|apply/eqP;lra]. +rewrite invfM//. repeat (rewrite logM; [|lra|lra]). -rewrite invRK. +rewrite invrK invr1 !mul1r. repeat (rewrite logV; last lra). rewrite log1 log4 log8 log16 log32. -field. +by field. Qed. End conditional_entropy_example. diff --git a/toy_examples/expected_value_variance.v b/toy_examples/expected_value_variance.v index e485a2ad..7ada52e1 100644 --- a/toy_examples/expected_value_variance.v +++ b/toy_examples/expected_value_variance.v @@ -1,9 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -From mathcomp Require Import all_ssreflect ssrnum. -Require Import Reals Lra. -From mathcomp Require Import Rstruct. -Require Import ssrR Reals_ext fdist proba. +From mathcomp Require Import all_ssreflect ssralg ssrnum lra ring. +(*Require Import Reals Lra.*) +From mathcomp Require Import Rstruct reals. +Require Import (*ssrR Reals_ext*) fdist proba. (* Coq/SSReflect/MathComp, Morikita, Sect. 7.2 *) @@ -12,8 +12,12 @@ Unset Strict Implicit. Import Prenex Implicits. Local Open Scope reals_ext_scope. -Local Open Scope R_scope. Local Open Scope ring_scope. +Local Open Scope ring_scope. + +Import GRing.Theory. + +Local Definition R := Rdefinitions.R. Definition pmf : {ffun 'I_3 -> R} := [ffun i => [fun x => 0 with inord 0 |-> 1/2, inord 1 |-> 1/3, inord 2 |-> 1/6] i]. @@ -54,12 +58,12 @@ Lemma pmf_ge0 : [forall a : 'I_3, 0 <= pmf a]. Proof. apply/forallPP; first by move=> x; exact/RleP. case/I3P. -- rewrite /f ffunE /= eqxx; lra. +- rewrite /f ffunE /= eqxx; apply/RleP; lra. - rewrite /f ffunE /= ifF; last by I3_neq. - rewrite eqxx; lra. + rewrite eqxx; apply/RleP; lra. - rewrite /f ffunE /= ifF; last by I3_neq. rewrite ifF; last by I3_neq. - rewrite eqxx; lra. + rewrite eqxx; apply/RleP; lra. Qed. Ltac I3_eq := rewrite (_ : _ == _ = true); last by @@ -70,7 +74,7 @@ Proof. apply/andP; split; first exact: pmf_ge0. apply/eqP. do 3 rewrite big_ord_recl. -rewrite big_ord0 addR0 /=. +rewrite big_ord0 addr0 /=. rewrite /f !ffunE /= ifT; last by I3_eq. rewrite ifF; last by I3_neq. rewrite ifT; last by I3_eq. @@ -78,7 +82,7 @@ rewrite ifF; last by I3_neq. rewrite ifF; last by I3_neq. rewrite ifT; last by I3_eq. (* 1 / 2 + (1 / 3 + 1 / 6) = 1 *) -by field. +lra. Qed. Local Open Scope fdist_scope. @@ -86,24 +90,23 @@ Local Open Scope proba_scope. Definition d : {fdist 'I_3} := FDist.mk pmf01. -Definition X : {RV d -> R} := (fun i => INR i.+1). +Definition X : {RV d -> R} := (fun i => i.+1%:R). Lemma expected : `E X = 5/3. Proof. rewrite /Ex. do 3 rewrite big_ord_recl. -rewrite big_ord0 addR0. -rewrite /X mul1R. +rewrite big_ord0 addr0. +rewrite /X mul1r. rewrite /f !ffunE /= ifT; last by I3_eq. -rewrite (_ : INR _ = 2) //. +rewrite (_ : (bump 0 0).+1%:R = 2) //. rewrite /= ifF; last by I3_neq. rewrite ifT; last by I3_eq. -rewrite (_ : INR _ = 3); last first. - rewrite S_INR (_ : INR _ = 2) //; by field. +rewrite (_ : (bump 0 (bump 0 0)).+1%:R = 3)//. rewrite /f /= ifF; last by I3_neq. rewrite ifF; last by I3_neq. rewrite ifT; last by I3_eq. -field. +lra. Qed. Lemma variance : `V X = 5/9. @@ -112,19 +115,18 @@ rewrite VarE. rewrite expected. rewrite /Ex /X. do 3 rewrite big_ord_recl. -rewrite big_ord0 addR0 /=. +rewrite big_ord0 addr0 /=. rewrite /sq_RV /comp_RV /=. -rewrite !mul1R. +rewrite expr1n mul1r. rewrite {1}/pmf !ffunE /=. rewrite ifT; last by I3_eq. -rewrite (_ : INR _ = 2) // mulR1. +rewrite (_ : (bump 0 0).+1%:R = 2) //. rewrite /f /=. rewrite ifF; last by I3_neq. rewrite ifT; last by I3_eq. -rewrite (_ : INR _ = 3); last first. - rewrite S_INR (_ : INR _ = 2) //; by field. +rewrite (_ : (bump 0 (bump 0 0)).+1%:R = 3)//. rewrite ifF; last by I3_neq. rewrite ifF; last by I3_neq. rewrite ifT; last by I3_eq. -field. +lra. Qed. diff --git a/toy_examples/expected_value_variance_ordn.v b/toy_examples/expected_value_variance_ordn.v index eb55cd8c..6b3294e9 100644 --- a/toy_examples/expected_value_variance_ordn.v +++ b/toy_examples/expected_value_variance_ordn.v @@ -1,9 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -Require Import Reals Lra. -From mathcomp Require Import all_ssreflect ssrnum. -From mathcomp Require Import Rstruct. -Require Import Reals_ext ssrR realType_ext fdist proba. +(*Require Import Reals Lra.*) +From mathcomp Require Import all_ssreflect ssralg ssrnum lra ring. +From mathcomp Require Import Rstruct reals. +Require Import (*Reals_ext ssrR*) realType_ext fdist proba. (* Coq/SSReflect/MathComp, Morikita, Sect. 7.2, without inord *) @@ -13,9 +13,10 @@ Import Prenex Implicits. Local Open Scope reals_ext_scope. Local Open Scope tuple_ext_scope. -Local Open Scope R_scope. Local Open Scope ring_scope. +Import GRing.Theory Num.Theory Order.Theory. + Definition ord1 {n} := lift ord0 (@ord0 n). Definition ord2 {n} := lift ord0 (@ord1 n). @@ -23,6 +24,8 @@ Lemma ord0E n : 0%nat = @ord0 n. Proof. done. Qed. Lemma ord1E n : 1%nat = @ord1 n. Proof. done. Qed. Lemma ord2E n : 2%nat = @ord2 n. Proof. done. Qed. +Local Definition R := Rdefinitions.R. + Definition pmf : {ffun 'I_3 -> R} := finfun [fun x => 0 with ord0 |-> 1/2, ord1 |-> 1/3, ord2 |-> 1/6]. @@ -31,13 +34,13 @@ Proof. apply/forallP => a. rewrite /pmf ffunE /=. apply/RleP. -do! case: ifP => _; lra. +by do! case: ifP => _; apply/RleP; lra. Qed. Lemma pmf01 : [forall a, 0 <= pmf a] && (\sum_(a in 'I_3) pmf a == 1). Proof. apply/andP; split; first exact: pmf_ge0. -by apply/eqP; rewrite 3!big_ord_recl big_ord0 /= /pmf !ffunE /=; field. +by apply/eqP; rewrite 3!big_ord_recl big_ord0 /= /pmf !ffunE /=; lra. Qed. Local Open Scope fdist_scope. @@ -45,14 +48,13 @@ Local Open Scope proba_scope. Definition P : {fdist 'I_3} := FDist.mk pmf01. -Definition X : {RV P -> R} := (fun i => INR i.+1). +Definition X : {RV P -> R} := (fun i => i.+1%:R). Lemma expected : `E X = 5/3. Proof. rewrite /Ex. rewrite 3!big_ord_recl big_ord0 /=. rewrite /pmf /X !ffunE /= /bump /=. -rewrite !S_INR (_ : 0%:R = 0) //. by field. Qed. @@ -61,6 +63,5 @@ Proof. rewrite VarE expected /Ex /X /sq_RV /comp_RV /=. rewrite 3!big_ord_recl big_ord0 /=. rewrite !ffunE /bump /=. -rewrite !S_INR (_ : 0%:R = 0) //. by field. Qed. diff --git a/toy_examples/expected_value_variance_tuple.v b/toy_examples/expected_value_variance_tuple.v index 612a1747..3f33525b 100644 --- a/toy_examples/expected_value_variance_tuple.v +++ b/toy_examples/expected_value_variance_tuple.v @@ -1,9 +1,9 @@ (* infotheo: information theory and error-correcting codes in Coq *) (* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later *) -Require Import Reals Lra. -From mathcomp Require Import all_ssreflect ssrnum. -From mathcomp Require Import Rstruct. -Require Import Reals_ext ssrR realType_ext fdist proba. +(*Require Import Reals Lra.*) +From mathcomp Require Import all_ssreflect ssralg ssrnum ring lra. +From mathcomp Require Import Rstruct reals. +Require Import (*Reals_ext ssrR*) realType_ext fdist proba. (* Coq/SSReflect/MathComp, Morikita, Sect. 7.2, using tuple *) @@ -13,10 +13,11 @@ Import Prenex Implicits. Local Open Scope reals_ext_scope. Local Open Scope tuple_ext_scope. -Local Open Scope R_scope. Local Open Scope ring_scope. -Definition ps := [tuple 1/2; 1/3; 1/6]. +Local Definition R := Rdefinitions.R. + +Definition ps := [tuple (1/2:R); 1/3; 1/6]. Definition p : {ffun 'I_3 -> R} := [ffun i => tnth ps i]. Lemma p_nonneg : [forall a : 'I_3, (0 <= p a)%mcR]. @@ -24,7 +25,7 @@ Proof. apply/forallP => a. rewrite /p ffunE. apply/all_tnthP: a => /=. -rewrite !andb_idr => * //; apply/RleP; lra. +rewrite !andb_idr => * //; lra. Qed. Lemma p_sum01 : [forall a, 0 <= p a] && (\sum_(a in 'I_3) p a == 1). @@ -39,14 +40,16 @@ Local Open Scope proba_scope. Definition P : {fdist 'I_3} := FDist.mk p_sum01. -Definition X : {RV P -> R} := (fun i => INR i.+1). +Definition X : {RV P -> R} := (fun i => i.+1%:R). Lemma expected : `E X = 5/3. Proof. rewrite /Ex. rewrite 3!big_ord_recl big_ord0 /=. rewrite /X !ffunE !(tnth_nth 0) /=. -cbv; by field. +rewrite (_ : (bump 0 0).+1%:R = 2)//. +rewrite (_ : (bump 0 _).+1%:R = 3)//. +lra. Qed. Lemma variance : `V X = 5/9. @@ -54,5 +57,7 @@ Proof. rewrite VarE expected /Ex /X /sq_RV /comp_RV /=. rewrite 3!big_ord_recl big_ord0 /=. rewrite !ffunE !(tnth_nth 0) /=. -cbv; by field. +rewrite (_ : (bump 0 0).+1%:R = 2)//. +rewrite (_ : (bump 0 _).+1%:R = 3)//. +lra. Qed.