diff --git a/_CoqProject b/_CoqProject index 1caabc13..43fa619a 100644 --- a/_CoqProject +++ b/_CoqProject @@ -8,8 +8,10 @@ lib/ssrZ.v lib/ssrR.v lib/realType_ext.v lib/Reals_ext.v +lib/realType_logb.v lib/logb.v lib/Ranalysis_ext.v +lib/derive_ext.v lib/ssr_ext.v lib/f2.v lib/ssralg_ext.v diff --git a/changelog.txt b/changelog.txt index c688fe5a..663ad5a9 100644 --- a/changelog.txt +++ b/changelog.txt @@ -1,4 +1,14 @@ +* 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/information_theory/aep.v b/information_theory/aep.v index cfa6708a..84d38d7e 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_logb. 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..4c5417b0 100644 --- a/information_theory/binary_symmetric_channel.v +++ b/information_theory/binary_symmetric_channel.v @@ -2,8 +2,7 @@ (* 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 realType_ext realType_logb ssr_ext ssralg_ext bigop_ext. Require Import fdist entropy binary_entropy_function channel hamming channel_code. Require Import pproba. @@ -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}. +Variable p : {prob Rdefinitions.R}. Definition c : `Ch(A, A) := fdist_binary card_A p. @@ -42,66 +41,64 @@ 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). +Variables (P : {fdist A}) (p : Rdefinitions.R). Hypothesis p_01' : (0 < p < 1)%mcR. Let p_01'_ : (0 <= p <= 1)%mcR. 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). + 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. + rewrite log1 !(mul0r, mulr0, addr0, add0r, mul1r, mulr1). + by rewrite /onem mulN1r opprK opprB opprK addrC. +rewrite 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. + by move/(_ H1). + by case/andP: p_01' => ? ?; exact/onem_gt0. +rewrite logM; last 2 first. move/eqP in H1. have [+ _] := fdist_gt0 P a. - by move/(_ H1) => /RltP. - by case/andP: p_01' => ? ?; exact/RltP. + by move/(_ H1). + by case/andP: p_01'. case: (Req_EM_T (P b) 0) => H2. - rewrite H2 !(mul0R, mulR0, addR0, add0R). + 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. + rewrite log1 !(mul0r, mulr0, addr0, add0r, mul1r, mulr1). + rewrite /onem/=. + by rewrite mulN1r opprK opprB opprK addrC. +rewrite 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. + by move/(_ H2). + by case/andP: p_01' => ? ?. +rewrite 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)//. + by move/(_ 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,75 +107,21 @@ 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. diff --git a/information_theory/channel.v b/information_theory/channel.v index 30557a04..cbb8c7fe 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 realType_ext realType_logb ssr_ext ssralg_ext bigop_ext 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..5b21289b 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 realType_ext realType_logb bigop_ext 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/entropy.v b/information_theory/entropy.v index 78c6bfab..cf46137e 100644 --- a/information_theory/entropy.v +++ b/information_theory/entropy.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 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. +From mathcomp Require Import reals exp. +Require Import realType_ext ssr_ext ssralg_ext bigop_ext. +Require Import realType_logb (*ln_facts*) fdist jfdist_cond proba binary_entropy_function. Require Import divergence. (******************************************************************************) @@ -54,27 +53,31 @@ 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. +(* TODO: kludge *) +(*Hint Extern 0 ((0 <= _)%coqR) => solve [exact/RleP/FDist.ge0] : core. +Hint Extern 0 ((_ <= 1)%coqR) => solve [exact/RleP/FDist.le1] : core.*) + 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). 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. +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; apply mulR_ge0 => //; apply: oppR_ge0. -rewrite -log1; apply: Log_increasing_le => //. -by apply/RltP; rewrite lt0r Hi/=. +rewrite mulrC -mulNr mulr_ge0// lerNr oppr0. +rewrite -log1 ler_log// ?posrE//. +by rewrite lt0r Hi/=. Qed. End entropy_definition. @@ -85,63 +88,60 @@ 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 if_same 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. + case/boolP : (P a == 0) => [/eqP ->|H0]; 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 +150,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 +158,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 +170,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 +189,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 +199,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 +208,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 +218,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 +228,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) @@ -250,31 +252,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 +293,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). @@ -315,7 +317,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 +328,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 +351,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 +401,7 @@ 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. @@ -454,7 +457,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 +470,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 +490,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 +540,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 +550,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 +562,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 +590,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 +607,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 +620,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 +644,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 +652,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 +666,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 +682,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 +700,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 +724,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 +746,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 +755,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 +785,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 +794,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 +807,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 +830,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 +845,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 +859,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 +896,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 +922,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. @@ -1094,9 +1094,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 +1120,28 @@ 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 +1153,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 ler_add2r. (* 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 +1167,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 +1199,28 @@ 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 _. +case/boolP : (PRQ x == 0) => [/eqP ->|H0]; 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 +1231,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 +1251,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 +1278,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 +1308,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 +1361,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. @@ -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 ler_subl_addr {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) ler_add2l. +exact/han_helper. Qed. End Han_inequality. diff --git a/information_theory/pproba.v b/information_theory/pproba.v index 927744f1..7666d7a5 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 ssrR realType_ext ssr_ext ssralg_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. @@ -111,9 +110,9 @@ 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. @@ -139,7 +138,7 @@ 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. Qed. @@ -153,7 +152,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. @@ -167,34 +166,28 @@ 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,11 +202,11 @@ 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. +under eq_bigr do rewrite /f' fdist_post_probE. rewrite -big_distrl /= mulR_eq0 => -[/eqP|]. - by apply/negP; rewrite -receivable_propE receivableP. - by rewrite -RinvE; apply/invR_neq0/eqP; rewrite -receivable_propE receivableP. @@ -223,12 +216,10 @@ Let f (i : 'I_n) := [ffun a => marginal_post_prob_den * \sum_(t in 'rV_n | 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 +230,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. diff --git a/information_theory/shannon_fano.v b/information_theory/shannon_fano.v index 21495e93..6ab00bdf 100644 --- a/information_theory/shannon_fano.v +++ b/information_theory/shannon_fano.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 ssrZ ssrR logb Reals_ext realType_ext ssr_ext fdist. +From mathcomp Require Import all_ssreflect all_algebra archimedean. +From mathcomp Require Import Rstruct reals. +Require Import ssrZ ssr_ext realType_logb realType_ext fdist bigop_ext. Require Import entropy kraft. (******************************************************************************) @@ -19,13 +18,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. @@ -44,7 +43,7 @@ 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,30 +64,22 @@ 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 _ _ (Exp #|T|%:R (- Log #|T|%:R (P i)^-1))); last first. + by rewrite LogV// opprK natn LogK// card_ord. +rewrite pow_Exp; last by rewrite card_ord. +rewrite Exp_oppr card_ord lef_pV2// ?posrE ?Exp_gt0//. +rewrite Exp_le_increasing// ?ltr1n//. +rewrite (le_trans (mathcomp_extra.ceil_ge _))//. +by rewrite natr_absz// ler_int ler_norm. Qed. End shannon_fano_is_kraft. @@ -116,28 +107,29 @@ 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. +rewrite le_eqVlt; apply/orP; left; apply/eqP. +rewrite /entropy big_morph_oppr; apply eq_bigr => i _. +by rewrite card_ord /log//. Qed. End shannon_fano_suboptimal. diff --git a/information_theory/typ_seq.v b/information_theory/typ_seq.v index baeb8bdb..12f614c4 100644 --- a/information_theory/typ_seq.v +++ b/information_theory/typ_seq.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. +From mathcomp Require Import reals lra exp. +Require Import ssr_ext realType_ext realType_logb. Require Import fdist proba entropy aep. (******************************************************************************) @@ -35,19 +34,19 @@ 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)))%R. Definition set_typ_seq := [set ta | typ_seq ta]. @@ -57,154 +56,139 @@ 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 -> +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. +rewrite !inE /typ_seq => /andP[H2 H3] [:Htmp]. +apply/andP; split. +- apply/(le_trans _ H2). + rewrite ler_powR ?ler1n// !mulNr lerNr opprK; apply ler_wpM2l => //. + rewrite lerD2l//. 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. + 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 Htmp. 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. +case/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)// Exp_gt0//. + by rewrite Exp_gt0. + by rewrite mulNr powRN logV ?Exp_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 Exp_gt0//. + rewrite -H3 in H1. + by rewrite ltNge H1. + rewrite mulN1r. + rewrite lerNl. + rewrite -ler_log ?posrE// in H1; last first. + by rewrite Exp_gt0. + by rewrite mulNr powRN logV ?Exp_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)%mcR]. 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). + case/andP : H => H _; apply/(lt_le_trans _ H). + by rewrite Exp_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)%mcR && + (`| - n.+1%:R^-1 * log ((P `^ n.+1)%fdist x) - `H P | > epsilon)%mcR]. 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)%mcR && + (`| - n.+1%:R^-1 * log ((P `^ n.+1)%fdist x) - `H P | > epsilon)%mcR]. 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 => /log_increasing => /(_ 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/log_increasing : 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 big1// add0r. +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. @@ -216,7 +200,9 @@ move/Pr_TS_1 => H. case/boolP : (#| `TS P n.+1 epsilon | == O) => [|Heq]; last by apply/eqP. 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. @@ -233,22 +219,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/lib/bigop_ext.v b/lib/bigop_ext.v index 1a6cbcee..adff8818 100644 --- a/lib/bigop_ext.v +++ b/lib/bigop_ext.v @@ -11,6 +11,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). diff --git a/lib/binary_entropy_function.v b/lib/binary_entropy_function.v index 1f170fd2..4e40f265 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_logb. (******************************************************************************) (* 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/derive_ext.v b/lib/derive_ext.v new file mode 100644 index 00000000..02ab3029 --- /dev/null +++ b/lib/derive_ext.v @@ -0,0 +1,223 @@ +(* 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 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 realType_logb 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 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. + +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. + +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. +by rewrite scaler0 add0r prednK ?mulr_regr // (@ltn_trans 1). +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. + +End is_derive. + +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/realType_ext.v b/lib/realType_ext.v index 7aebdc25..cae3399e 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,7 +11,7 @@ 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 *) (* *) (******************************************************************************) @@ -34,6 +34,28 @@ Import Prenex Implicits. Import Order.POrderTheory Order.TotalTheory GRing.Theory Num.Theory. +(* TODO: move to "mathcomp_extra.v" *) +Section num_ext. +Local Open Scope ring_scope. +(* analogs 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. 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. + 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 +63,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 +86,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 +105,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}. @@ -587,3 +670,71 @@ 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. diff --git a/lib/realType_logb.v b/lib/realType_logb.v new file mode 100644 index 00000000..d21943ea --- /dev/null +++ b/lib/realType_logb.v @@ -0,0 +1,236 @@ +(* 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 reals exp sequences. +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 in base 2 *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. + +Local Open Scope ring_scope. + +Import Order.POrderTheory GRing.Theory Num.Theory. + +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. + +Lemma le_ln1Dx x : -1 < x -> ln (1 + x) <= x. +Proof. +(*this will be in MathComp-Analysis 1.5.0*) +Admitted. + +Lemma expR_gt1Dx x : x != 0 -> 1 + x < expR x. +Proof. +(*this will be in MathComp-Analysis 1.5.0*) +Admitted. + +(* TODO: add to MCA? *) +Lemma lt_ln1Dx x : 0 < x -> ln (1 + x) < x. +Proof. +move=> x1. +rewrite -ltr_expR lnK ?expR_gt1Dx//. + by rewrite 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}(GRing.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 xlnx. +Context {R : realType}. + +Definition xlnx (x : R) : R := if (0 < x)%mcR then x * ln x else 0. + +Lemma xlnx_0 : xlnx 0 = 0. +Proof. by rewrite /xlnx mul0r ltxx. Qed. + +Lemma xlnx_1 : xlnx 1 = 0. +Proof. by rewrite /xlnx ltr01 mul1r ln1. Qed. + +End xlnx. + + +Section Log. +Context {R : realType}. + +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. + +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}. + +(* TODO: rm *) +Definition Exp (n : R) (x : R) := n `^ x. + +Lemma pow_Exp (x : R) n : (0 <= x) -> x ^+ n = Exp x n%:R. +Proof. by move=> x0; rewrite /Exp powR_mulrn. Qed. + +Lemma LogK n x : (1 < n)%N -> 0 < x -> Exp n%:R (Log n x) = x. +Proof. +move=> n1 x0. +rewrite /Exp /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. + +Lemma Exp_oppr n x : Exp n (- x) = (Exp n x)^-1. +Proof. by rewrite /Exp -powRN. Qed. + +Lemma Exp_gt0 n x : 0 < n -> 0 < Exp n x. Proof. by move=> ?; rewrite /Exp powR_gt0. Qed. + +Lemma Exp_ge0 n x : 0 <= Exp n x. Proof. by rewrite /Exp powR_ge0. Qed. + +Lemma Exp_increasing n x y : 1 < n -> x < y -> Exp n x < Exp n y. +Proof. +move=> n1 xy; rewrite /Exp /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. + +Lemma Exp_le_increasing n x y : 1 < n -> x <= y -> Exp n x <= Exp n y. +Proof. +by move=> n1 xy; rewrite /Exp ler_powR// ltW. +Qed. + +End Exp. + +Hint Extern 0 (0 <= Exp _ _) => solve [exact/Exp_ge0] : core. + +Section log. +Context {R : realType}. +Implicit Types x y : R. + +Definition log {R : realType} (x : R) := 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 prednK// 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 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 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. +rewrite logexp1E. +rewrite invr_ge0// ltW//. +by rewrite 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 x : R) : log (a `^ x) = x * log a. +Proof. +by rewrite /log /Log ln_powR// mulrA. +Qed. + +Lemma log_increasing (a b : R) : 0 < a -> a < b -> log a < log b. +Proof. +move=> Ha a_b. +rewrite /log /Log prednK// ltr_pmul2r ?invr_gt0 ?ln2_gt0//. +by rewrite ltr_ln ?posrE// (lt_trans _ a_b). +Qed. + +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))%R. +Proof. +move=> f0 f0'. +elim: s => [|h t ih]. + by rewrite !big_nil log1 oppr0. +rewrite big_cons logM//; last first. + by apply/prodr_gt0 => a _. +by rewrite [RHS]big_cons opprD ih. +Qed. diff --git a/lib/ssr_ext.v b/lib/ssr_ext.v index 51931ab1..29aba646 100644 --- a/lib/ssr_ext.v +++ b/lib/ssr_ext.v @@ -17,9 +17,13 @@ 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 +106,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 +162,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 +279,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 +439,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,38 +469,38 @@ 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. - -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. +End seq_bool. -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. @@ -993,6 +980,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 +1017,8 @@ Proof. move=> ?; rewrite /connect_sym => ? ?; apply/idP/idP => /connect_sym1; exact. Qed. +End fingraph_ext. + Section uniq_path. Variable A : eqType. @@ -1087,6 +1078,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. diff --git a/lib/ssralg_ext.v b/lib/ssralg_ext.v index c6b5920a..55bb30f9 100644 --- a/lib/ssralg_ext.v +++ b/lib/ssralg_ext.v @@ -686,3 +686,13 @@ 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. diff --git a/probability/bayes.v b/probability/bayes.v index 1ec195f9..136589e4 100644 --- a/probability/bayes.v +++ b/probability/bayes.v @@ -368,9 +368,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. @@ -428,7 +428,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 +442,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/eqP in Hden. - rewrite /cPr /Rdiv -mulRA mulVR // mulR1 mul1R. + rewrite /cPr RmultE -GRing.mulrA GRing.mulVr// GRing.mulr1 RmultE GRing.mul1r. move/(f_equal (Rminus den)). - rewrite subRR setIC -Pr_setD => /Pr_set0P/(_ u). + rewrite subRR setIC RminusE -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 +470,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. @@ -584,7 +584,9 @@ under eq_bigr => A _ /=. over. apply/setP => i; move/subsetP/(_ i): ee'; by cases_in i. rewrite -2!big_distrl /=. -congr (_ / _ * _). +rewrite [in RHS]/cPr. +rewrite RmultE. +congr (_ * _ * _)%mcR. 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 // ?GRing.mul0r => /esym/R1_neq_R0. set num := Pr _ _ => Hnum. have {}Hnum : num = den. - by rewrite -[RHS]mul1R -Hnum /Rdiv -mulRA mulVR // mulR1. + by rewrite -[RHS]GRing.mul1r -!coqRE -Hnum coqRE -GRing.mulrA GRing.mulVf ?GRing.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. @@ -696,7 +698,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 //. @@ -760,7 +762,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 <-. @@ -769,7 +771,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[] -> _ ->. diff --git a/probability/convex_equiv.v b/probability/convex_equiv.v index 065798f6..4250b399 100644 --- a/probability/convex_equiv.v +++ b/probability/convex_equiv.v @@ -3,9 +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 ssrR realType_ext Ranalysis_ext ssr_ext ssralg_ext. Require Import fdist jfdist_cond fsdist convex. (******************************************************************************) @@ -213,7 +212,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))) //. @@ -260,17 +259,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. @@ -295,10 +292,10 @@ Module B := NaryToBin(A). Module EA := Equiv2(A). Import A B. -Let 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. -Let T' := NaryConv_sort__canonical__convex_ConvexSpace. +Definition T' := NaryConv_sort__canonical__convex_ConvexSpace. Lemma equiv_conv p (a b : C.T) : a <| p |> b = a <& p &> b. Proof. @@ -419,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. @@ -437,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. @@ -464,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 /=. @@ -474,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 ->. @@ -490,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). @@ -498,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. @@ -587,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/divergence.v b/probability/divergence.v index 1b184598..aedef0a5 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_logb (*ln_facts logb*) 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. - -Variables (A : finType) (P Q : {fdist A}). +Context {R : realType}. +Variables (A : finType) (P Q : R.-fdist A). Definition div := \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..0986f5ef 100644 --- a/probability/fdist.v +++ b/probability/fdist.v @@ -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..dc74bb0d 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,10 @@ 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. +Local Notation R := (Rdefinitions.R : realType). +(*TODO: 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} := @@ -606,47 +604,47 @@ Let supp : finsupp f = D. Proof. apply/fsetP => a; rewrite /f /D. case: ifPn; [|case: ifPn]; - rewrite !mem_finsupp fsfunE ?inE !mem_finsupp avgRE. + rewrite !mem_finsupp fsfunE ?inE !mem_finsupp avgRE !ssrR.coqRE. - 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 fsfunE avgRE aD. -by apply/RleP; rewrite RplusE !RmultE addr_ge0// mulr_ge0//. +rewrite /f lt_neqAle mem_finsupp eq_sym => -> /=. +rewrite /f fsfunE avgRE !ssrR.coqRE aD. +by rewrite !addr_ge0. Qed. Let f1 : \sum_(a <- finsupp f) f a = 1. Proof. under eq_big_seq => b /[!supp] bD do rewrite /f fsfunE bD. -rewrite supp; under eq_bigr do rewrite avgRE. +rewrite supp; under eq_bigr do rewrite avgRE !ssrR.coqRE. 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. Proof. @@ -665,9 +663,11 @@ Proof. by rewrite /fsdist_conv -lock supp. Qed. End fsdist_conv_def. Section fsdist_convType. +Local Notation R := (Rdefinitions.R : realType). +(*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 +677,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 (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 +688,17 @@ 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 A) conv1 convmm convC convA. End fsdist_convType. Section fsdist_conv_prop. +Local Notation R := (Rdefinitions.R : realType). +(*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 : @@ -723,7 +725,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 !ssrR.coqRE 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. @@ -748,6 +751,8 @@ Local Open Scope proba_scope. Local Open Scope convex_scope. Section FSDist_affine_instances. +Local Notation R := (Rdefinitions.R : realType). +(*Context {R : realType}.*) Variable A B : choiceType. Lemma fsdistmap_affine (f : A -> B) : affine (fsdistmap f). @@ -756,7 +761,7 @@ Proof. by move=> ? ? ?; rewrite /fsdistmap fsdist_conv_bind_left_distr. Qed. HB.instance Definition _ (f : A -> B) := 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. Lemma fsdist_eval_affine (x : A) : affine (fsdist_eval x). Proof. by move=> a b p; rewrite /fsdist_eval fsdist_convE. Qed. @@ -767,33 +772,34 @@ HB.instance Definition _ (x : A) := End FSDist_affine_instances. Section fsdist_convn_lemmas. +Local Notation R := (Rdefinitions.R : realType). +(*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 : {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 +811,20 @@ 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. +Local Notation R := (Rdefinitions.R : realType). +(*Context {R : realType}.*) Variable C : convType. -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) (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 +833,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 +848,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,7 +870,7 @@ 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. +have opn0 : (Prob.p p).~ != 0. by apply onem_neq0. apply: S1_inj; 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 /=. @@ -876,16 +884,20 @@ HB.instance Definition _ := isAffine.Build _ _ _ Convn_of_fsdist_affine. End Convn_of_FSDist. Section lemmas_for_probability_monad_and_adjunction. +Local Notation R := (Rdefinitions.R : realType). +(*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 apply/RleP; rewrite !ssrR.coqRE FDist.ge0. +by rewrite fdist_of_fsE /= !ssrR.coqRE mul1r. Qed. Lemma Convn_of_fsdist1 (C : convType) (x : C) : Convn_of_fsdist (fsdist1 x) = x. @@ -893,14 +905,14 @@ Proof. apply: (@S1_inj _ _ 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}) : + (d : R.-dist C) : f (Convn_of_fsdist d) = Convn_of_fsdist (fsdistmap f d). Proof. apply S1_inj => /=. @@ -910,17 +922,18 @@ 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; apply/RleP; 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. @@ -929,17 +942,21 @@ by rewrite ssum_seq_finsuppE'' big_seq. Qed. Section triangular_laws_left_convn. +Local Notation R := (Rdefinitions.R : realType). +(*Context {R : realType}.*) 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. 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)). 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). @@ -949,7 +966,7 @@ have nx0 : \ssum_(i <- finsupp d `\ x) 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 !ssrR.coqRE mulr0 addr0 mulr1. by rewrite -(mem_fsetD1 xfd) nx0 fsfun_dflt // onem0 scale1pt. Qed. @@ -957,6 +974,8 @@ End triangular_laws_left_convn. End lemmas_for_probability_monad_and_adjunction. +Import ereal topology esum measure probability. + Section probability_measure. Section trivIset. @@ -1127,3 +1146,4 @@ Qed. HB.instance Definition _ := isProbability.Build disp T _ P P_is_probability. End probability_measure. + diff --git a/probability/graphoid.v b/probability/graphoid.v index 9a41c2d9..119dff2b 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 *) 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 realType_ext logb ssr_ext ssralg_ext bigop_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..c4429d0d 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 Rstruct. +Require Import ssrR realType_ext ssr_ext realType_ext ssralg_ext logb. Require Import fdist proba convex. (******************************************************************************) @@ -14,21 +13,24 @@ 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 convex_scope. Local Open Scope fdist_scope. -Import GRing.Theory. +Import Order.Theory GRing.Theory Num.Theory. Section jensen_inequality. +Local Notation R := Rdefinitions.R. +(*Context {R : realType}.*) + Variable f : R -> R. Variable D : {convex_set R}. 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}) : (forall a, r a \in D) -> @@ -43,21 +45,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,8 +72,9 @@ 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/RleP/le_trans; apply. +by rewrite lerD2l; apply ler_wpM2l => //; rewrite onem_ge0. Qed. Local Open Scope proba_scope. @@ -80,8 +83,8 @@ Lemma Jensen (P : {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. @@ -89,6 +92,9 @@ End jensen_inequality. Section jensen_concave. +Local Notation R := Rdefinitions.R. +(*Context {R : realType}.*) + Variable f : R -> R. Variable D : {convex_set R}. Hypothesis concave_f : concave_function_in D f. @@ -107,9 +113,11 @@ Lemma jensen_dist_concave (r : A -> R) (X : {fdist A}) : \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..f984b9bc 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 realType_ext realType_logb ssr_ext ssralg_ext bigop_ext. 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/log_sum.v b/probability/log_sum.v index 45e2394b..a9ea00fc 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 Rstruct reals lra exp. +Require Import ssrR realType_ext realType_logb bigop_ext. (******************************************************************************) (* 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}) := +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_wpmul2l; 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,50 @@ 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. +rewrite in_set. case/andP => a_C fa_not_0. -case (f0 a) => // abs. -by rewrite abs eqxx in fa_not_0. +case :(f0 a) => // abs. +by rewrite lt_neqAle eq_sym fa_not_0. Qed. diff --git a/probability/necset.v b/probability/necset.v index 592e6e65..0142e62d 100644 --- a/probability/necset.v +++ b/probability/necset.v @@ -1085,7 +1085,7 @@ 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]. @@ -1105,7 +1105,7 @@ 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. @@ -1114,7 +1114,7 @@ Definition F1join0 : FFT -> L' := fun X => NECSet.Pack (NECSet.Class (isConvexSet.Build _ _ (F1join0'_convex X)) (isNESet.Build _ _ (F1join0'_neq0 X))). Definition join1' (X : L') - : {convex_set [the convType of {dist {classic T}}]} := + : {convex_set [the convType of R.-dist {classic T}]} := ConvexSet.Pack (ConvexSet.Class (isConvexSet.Build _ _ (hull_is_convex (\bigcup_(i in X) if i \in X then (i : set _) else set0)))). diff --git a/probability/partition_inequality.v b/probability/partition_inequality.v index a6cb0a11..b1751c56 100644 --- a/probability/partition_inequality.v +++ b/probability/partition_inequality.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 Lra. -From mathcomp Require Import Rstruct. -Require Import ssrR realType_ext Reals_ext Ranalysis_ext ssr_ext logb ln_facts. +From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp Require Import Rstruct reals. +Require Import realType_ext ssr_ext realType_logb (*ln_facts*). Require Import bigop_ext fdist divergence log_sum variation_dist. (******************************************************************************) @@ -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..49bcf8c8 100644 --- a/probability/pinsker.v +++ b/probability/pinsker.v @@ -1,11 +1,15 @@ (* 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. +From mathcomp Require Import ring lra. +From mathcomp Require Import mathcomp_extra classical_sets functions. +From mathcomp Require Import set_interval. +From mathcomp Require Import reals Rstruct topology normedtype. +From mathcomp Require Import realfun sequences derive exp. +Require Import realType_ext realType_logb ssr_ext ssralg_ext bigop_ext. +Require Import derive_ext. +Require Import fdist divergence variation_dist partition_inequality. (******************************************************************************) (* Pinsker's Inequality *) @@ -20,316 +24,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. + +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 derive_pinsker_fun (p : R) c : 0 < p < 1 -> - pderivable (pinsker_fun p c) (fun q => 0 < q < 1). +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. -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 [X in X + _ = _]addrC. +congr (_ + _ - _). + by rewrite !opprD !opprK !addrA !subrr !add0r. +by rewrite -sqrrN !opprD !opprK addrCA !addrA subrr add0r. Qed. -Definition pinsker_function_spec c q := - log (1 - q) - 4 * c * q ^ 2. +Lemma pinsker_fun_p p c : pinsker_fun p c p = 0. +Proof. +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 q0 := - / ((1 - q0) * ln 2) - 8 * c * q0. +End pinsker_fun_def. -Lemma pderivable_pinsker_function_spec c : - pderivable (pinsker_function_spec c) (fun q => 0 <= q < 1). +Section pinsker_function_analysis. +Variable R : realType. + +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. -rewrite (proof_derive_irrelevance _ (pderivable_pinsker_function_spec c Hq0)) //. +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. +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 +336,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 +358,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 +368,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 +432,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 +453,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 70f9b18e..7447f17a 100644 --- a/probability/proba.v +++ b/probability/proba.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. +From mathcomp Require Import all_ssreflect all_algebra fingroup 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. +From mathcomp Require Import reals exp. +Require Import realType_ext realType_logb ssr_ext ssralg_ext. Require Import bigop_ext fdist. (******************************************************************************) @@ -123,20 +122,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 +172,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 +220,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 +243,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 +282,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 +345,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 +355,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 +388,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 +410,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 +438,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 +452,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 +464,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 +479,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 +494,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 +526,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 +547,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}. Variables (U : finType) (d : unit) (T : porderType d) (P : R.-fdist U). Variables (X : {RV P -> T}). @@ -563,6 +560,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 +571,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,58 +593,103 @@ 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 unit_RV : {RV P -> unit} := fun=> tt. Definition const_RV (T : eqType) cst : {RV P -> T} := fun=> cst. Definition comp_RV (TA TB : eqType) (f : TA -> TB) (X : {RV P -> TA}) : {RV P -> TB} := fun x => f (X x). -Local Notation "f `o X" := (comp_RV f X). -Definition scalel_RV k (X : {RV P -> R}) : {RV P -> R} := fun x => k * X x. -Definition scaler_RV (X : {RV P -> R}) k : {RV P -> R} := fun x => X x * k. -Definition add_RV (X Y : {RV P -> R}) : {RV P -> R} := fun x => X x + Y x. -Definition sumR_RV I (r : seq.seq I) (p : pred I) (X : I -> {RV P -> R}) : {RV P -> R} := - fun x => \sum_(i <- r | p i) X i x. -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 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. End random_variables. -Notation "k `cst* X" := (scalel_RV k X) : proba_scope. -Notation "X `*cst k" := (scaler_RV X k) : proba_scope. -Notation "f `o X" := (comp_RV f X) : proba_scope. -Notation "X '`/' n" := (scalel_RV (1 / n%:R) X) : proba_scope. +Notation "f `o X" := (comp_RV f X). + +Section zmod_random_variables. +Context {R : realType}. +Local Open Scope ring_scope. + +Variables (U : finType)(P : R.-fdist U)(V : zmodType). + +Definition add_RV (X Y : {RV P -> V}) : {RV P -> V} := fun x => X x + Y x. +Definition sub_RV (X Y : {RV P -> V}) : {RV P -> V} := fun x => X x - Y x. + +(* TODO: neg to opp *) +Definition neg_RV (X : {RV P -> V}) : {RV P -> V} := fun x => - X x. +Definition trans_add_RV (X : {RV P -> V}) m : {RV P -> V} := fun x => X x + m. +(* TODO: min to sub; no longer necessary *) +Definition trans_min_RV (X : {RV P -> V}) m : {RV P -> V} := fun x => X x - m. +Definition sumR_RV I (r : seq.seq I) (p : pred I) (X : I -> {RV P -> V}) : {RV P -> V} := + fun x => \sum_(i <- r | p i) X i x. + +Local Notation "X `+ Y" := (add_RV X Y) : proba_scope. +Local Notation "X `- Y" := (sub_RV X Y) : proba_scope. + +Lemma sub_RV_neg (X Y : {RV P -> V}): + X `- Y = X `+ neg_RV Y. +Proof. by []. Qed. + +End zmod_random_variables. + Notation "X `+ Y" := (add_RV X Y) : proba_scope. Notation "X `- Y" := (sub_RV X Y) : proba_scope. Notation "X '`+cst' m" := (trans_add_RV X m) : proba_scope. Notation "X '`-cst' m" := (trans_min_RV X m) : proba_scope. -Notation "X '`^2' " := (sq_RV X) : proba_scope. Notation "'`--' P" := (neg_RV P) : proba_scope. + +Section zmod_random_variables_lemmas. + +End zmod_random_variables_lemmas. + +Section ring_random_variables. +Context {R : realType}. +Local Open Scope ring_scope. + +Variables (U : finType)(P : R.-fdist U)(V : ringType). + +Definition scalel_RV k (X : {RV P -> V}) : {RV P -> V} := fun x => k * X x. +Definition scaler_RV (X : {RV P -> V}) k : {RV P -> V} := fun x => X x * k. +Definition sq_RV (X : {RV P -> V}) : {RV P -> V} := (fun x => x ^+ 2) `o X. + +End ring_random_variables. + +Notation "k `cst* X" := (scalel_RV k X) : proba_scope. +Notation "X `*cst k" := (scaler_RV X k) : proba_scope. +Notation "X '`/' n" := (scalel_RV (1 / n%:R) X) : proba_scope. +Notation "X '`^2' " := (sq_RV X) : proba_scope. + +Section real_random_variables. +Context {R : realType}. + +Variables (U : finType)(P : R.-fdist U). + +Definition log_RV : {RV P -> R} := fun x => log (P x). + +End real_random_variables. + 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 +698,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 +720,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 +741,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 +758,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 +818,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 +850,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 +867,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 +899,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 +931,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 +971,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 +979,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 +989,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 +1000,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 +1029,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 +1062,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 +1075,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 +1132,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 +1163,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 +1180,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 +1217,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 +1225,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 +1304,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 +1326,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 +1354,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 -> @@ -1317,7 +1382,54 @@ Qed. End mutual_independence. +Section uniform_finType_RV_lemmas. +Local Open Scope proba_scope. +Context {R : realType}. +Variables (T: finType) (n: nat) (P : R.-fdist T) (A : finType). +Variable X : {RV P -> A}. + +Hypothesis card_A : #|A| = n.+1. +Hypothesis Xunif : `p_X = fdist_uniform card_A. + +Lemma bij_comp_RV (f g : A -> A) : + cancel f g -> cancel g f -> `p_(f `o X) =1 `p_X \o g. +Proof. +move=> fg gf x /=; rewrite !fdistbindE. +apply: eq_bigr=> a _. +by rewrite !fdist1E -(can_eq gf) fg. +Qed. + +Lemma bij_RV_unif (f g : A -> A) : + cancel f g -> cancel g f -> `p_(f `o X) = fdist_uniform card_A. +Proof. +move => fg gf. +apply/val_inj/ffunP => x /=. +by rewrite (bij_comp_RV fg gf) Xunif /= !fdist_uniformE. +Qed. + +End uniform_finType_RV_lemmas. + +Section uniform_finZmod_RV_lemmas. +Local Open Scope proba_scope. +Context {R : realType}. +Variables (T: finType) (P : R.-fdist T) (A : finZmodType). +Variable X : {RV P -> A}. + +Let n := #|A|.-1. +Let card_A : #|A| = n.+1. +Proof. by apply/esym/prednK/card_gt0P; exists 0. Qed. + +Hypothesis Xunif : `p_X = fdist_uniform card_A. + +Lemma trans_RV_unif (m : A) : `p_(X `+cst m) = fdist_uniform card_A. +Proof. exact: (bij_RV_unif Xunif (addrK m) (subrK m)). Qed. + +Lemma neg_RV_unif : `p_(`-- X) = fdist_uniform card_A. +Proof. exact: (bij_RV_unif Xunif opprK opprK). Qed. +End uniform_finZmod_RV_lemmas. + Section conditional_probablity. +Context {R : realType}. Variables (A : finType) (d : R.-fdist A). Implicit Types E F : {set A}. @@ -1327,15 +1439,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 +1457,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 +1530,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 +1538,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 +1563,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 +1612,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 +1646,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 +1659,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 +1671,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 +1690,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 +1705,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 +1730,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 +1739,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 +1748,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 +1759,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 +1876,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 +1890,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 +1906,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 +1922,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 +1941,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 +1968,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 +1999,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 +2014,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 +2039,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 +2061,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 +2085,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 +2116,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 +2125,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 +2151,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 +2164,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 +2172,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 +2186,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 +2207,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 +2232,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 +2243,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 +2270,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 +2293,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 +2313,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 +2346,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 +2360,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..38b0dad8 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 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 mathcomp Require Import Rstruct reals mathcomp_extra. +From mathcomp Require Import lra ring. +From infotheo Require Import ssrR realType_ext logb ssr_ext ssralg_ext. From infotheo Require Import bigop_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,140 @@ 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. +Reserved Notation "A :^: B" (at level 52, left associativity). + +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. + +(* symmetric difference *) +Definition adds (T : finType) (A B : {set T}) := (A :\: B :|: B :\: A). +Notation "A :^: B" := (adds A B). + +Section adds_lemmas. +Variable (T : finType). +Implicit Types (A B C : {set T}). +Local Notation "+%S" := (@adds T). +Local Notation "-%S" := idfun. +Local Notation "0" := (@set0 T). + +Lemma addsA : 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 addsC : commutative +%S. +Proof. by move=> *; rewrite /adds setUC. Qed. +Lemma add0s : left_id 0 +%S. +Proof. by move=> ?; rewrite /adds set0D setD0 set0U. Qed. +Lemma addNs : left_inverse 0 -%S +%S. +Proof. by move=> *; rewrite /adds /= setDv setU0. Qed. +Lemma setI_addl : left_distributive (@setI T) +%S. +Proof. by move=> *; rewrite [in LHS]/adds setIUl !setIDACW. Qed. +End adds_lemmas. + +From mathcomp Require Import all_algebra. +Search subsetv. + +Lemma setIUAdd (T : finType) (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 setIIAdd_disj (T : finType) (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. + +Definition big_union_disj := big_union. + +Lemma big_union (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 -setIUAdd big_union_disj 1?disjoint_sym ?setIIAdd_disj //. +rewrite I0 Monoid.opm1 big_union_disj; last first. + by rewrite -setI_eq0 setIDA setIC Order.SetSubsetOrder.setIDv // set0D. +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. + +(* 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 +171,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 +224,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 +295,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 +310,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 +319,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 +389,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 +400,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 +422,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 +535,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 /=; 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 /=; 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 +769,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 4338d8a0..15bbc895 100644 --- a/robust/weightedmean.v +++ b/robust/weightedmean.v @@ -114,16 +114,6 @@ 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 : unit) (T : porderType disp) (I : eqType) (r : seq I) (f : I -> T) (x0 x : T) (PP : pred I) : diff --git a/toy_examples/expected_value_variance.v b/toy_examples/expected_value_variance.v index e485a2ad..57a39f2d 100644 --- a/toy_examples/expected_value_variance.v +++ b/toy_examples/expected_value_variance.v @@ -1,6 +1,6 @@ (* 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. +From mathcomp Require Import all_ssreflect ssralg ssrnum lra. Require Import Reals Lra. From mathcomp Require Import Rstruct. Require Import ssrR Reals_ext fdist proba. @@ -15,6 +15,8 @@ Local Open Scope reals_ext_scope. Local Open Scope R_scope. Local Open Scope ring_scope. +Import GRing.Theory. + 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 +56,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 +72,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 +80,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. @@ -92,18 +94,18 @@ 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 /= ifF; last by I3_neq. rewrite ifT; last by I3_eq. rewrite (_ : INR _ = 3); last first. - rewrite S_INR (_ : INR _ = 2) //; by field. + rewrite S_INR (_ : INR _ = 2) // !coqRE; lra. 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 +114,19 @@ 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 (_ : (_.+1%:R)%coqR = 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. + by rewrite S_INR (_ : INR _ = 2) // !coqRE; lra. 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..1424ec4b 100644 --- a/toy_examples/expected_value_variance_ordn.v +++ b/toy_examples/expected_value_variance_ordn.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 *) Require Import Reals Lra. -From mathcomp Require Import all_ssreflect ssrnum. +From mathcomp Require Import all_ssreflect ssralg ssrnum lra. From mathcomp Require Import Rstruct. Require Import Reals_ext ssrR realType_ext fdist proba. @@ -31,13 +31,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. @@ -52,8 +52,8 @@ Proof. rewrite /Ex. rewrite 3!big_ord_recl big_ord0 /=. rewrite /pmf /X !ffunE /= /bump /=. -rewrite !S_INR (_ : 0%:R = 0) //. -by field. +rewrite !S_INR !coqRE. +by lra. Qed. Lemma variance : `V X = 5/9. @@ -61,6 +61,6 @@ 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. +rewrite !S_INR !coqRE. +lra. Qed.