diff --git a/_CoqProject b/_CoqProject index d15a2a3ae..59adb1837 100644 --- a/_CoqProject +++ b/_CoqProject @@ -57,7 +57,7 @@ theories/lang_syntax_util.v theories/lang_syntax_toy.v theories/lang_syntax.v theories/lang_syntax_examples.v -theories/lang_syntax_examples_wip.v +theories/lang_syntax_table_game.v theories/altreals/xfinmap.v theories/altreals/discrete.v theories/altreals/realseq.v diff --git a/theories/Make b/theories/Make index c15994936..2d4eabce5 100644 --- a/theories/Make +++ b/theories/Make @@ -47,7 +47,7 @@ lang_syntax_util.v lang_syntax_toy.v lang_syntax.v lang_syntax_examples.v -lang_syntax_examples_wip.v +lang_syntax_table_game.v altreals/xfinmap.v altreals/discrete.v altreals/realseq.v diff --git a/theories/kernel.v b/theories/kernel.v index 4d8e2ff39..84c3c7f94 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -506,7 +506,7 @@ Variable k : X * Y -> \bar R. Lemma measurable_fun_xsection_integral (l : X -> {measure set Y -> \bar R}) - (k_ : ({nnsfun [the measurableType _ of X * Y] >-> R})^nat) + (k_ : {nnsfun (X * Y) >-> R}^nat) (ndk_ : nondecreasing_seq (k_ : (X * Y -> R)^nat)) (k_k : forall z, (k_ n z)%:E @[n --> \oo] --> k z) : (forall n r, @@ -614,7 +614,7 @@ Qed. HB.instance Definition _ := isKernel.Build _ _ _ _ _ (kdirac mf) measurable_fun_kdirac. -Let kdirac_prob x : kdirac mf x setT = 1. +Let kdirac_prob x : kdirac mf x [set: Y] = 1. Proof. by rewrite /kdirac/= diracT. Qed. HB.instance Definition _ := Kernel_isProbability.Build _ _ _ _ _ @@ -722,7 +722,7 @@ Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Variable f : R.-ker X ~> Y. Definition knormalize (P : probability Y R) : X -> {measure set Y -> \bar R} := - fun x => [the measure _ _ of mnormalize (f x) P]. + fun x => mnormalize (f x) P. Let measurable_knormalize (P : probability Y R) U : measurable U -> measurable_fun [set: X] (knormalize P ^~ U). diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index b1f7e2450..110fe48c6 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -3,13 +3,22 @@ From HB Require Import structures. From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval. From mathcomp Require Import mathcomp_extra boolp classical_sets. From mathcomp Require Import functions cardinality fsbigop. -Require Import signed reals ereal topology normedtype sequences esum measure. -Require Import lebesgue_measure numfun lebesgue_integral itv kernel prob_lang. -Require Import lang_syntax_util exp. +Require Import signed reals ereal topology normedtype sequences esum exp. +Require Import measure lebesgue_measure numfun lebesgue_integral itv kernel. +Require Import charge prob_lang lang_syntax_util. From mathcomp Require Import ring lra. -(******************************************************************************) -(* Syntax and Evaluation for a Probabilistic Programming Language *) +(**md**************************************************************************) +(* # Syntax and Evaluation for a Probabilistic Programming Language *) +(* *) +(* Reference: *) +(* - R. Saito, R. Affeldt. Experimenting with an Intrinsically-Typed *) +(* Probabilistic Programming Language in Coq using s-finite kernels in Coq. *) +(* APLAS 2023 *) +(* *) +(* beta distribution specialized to nat *) +(* beta_nat_pdf == probability density function *) +(* beta_nat == probability measure *) (* *) (* typ == syntax for types of data structures *) (* measurable_of_typ t == the measurable type corresponding to type t *) @@ -37,9 +46,6 @@ From mathcomp Require Import ring lra. (* function from mctx g to mtyp t *) (* pval R g t == "probabilistic value", i.e., *) (* s-finite kernel, from mctx g to mtyp t *) -(* mkswap k == given a kernel k : (Y * X) ~> Z, *) -(* returns a kernel of type (X * Y) ~> Z *) -(* letin' := mkcomp \o mkswap *) (* e -D> f ; mf == the evaluation of the deterministic expression e *) (* leads to the deterministic value f *) (* (mf is the proof that f is measurable) *) @@ -60,8 +66,6 @@ Unset Printing Implicit Defensive. Import Order.TTheory GRing.Theory Num.Def Num.Theory. Import numFieldTopology.Exports. -Reserved Notation "f .; g" (at level 60, right associativity, - format "f .; '/ ' g"). Reserved Notation "e -D> f ; mf" (at level 40). Reserved Notation "e -P> k" (at level 40). @@ -69,193 +73,740 @@ Local Open Scope classical_set_scope. Local Open Scope ring_scope. Local Open Scope ereal_scope. -(* TODO: mv *) -Arguments measurable_fst {d1 d2 T1 T2}. -Arguments measurable_snd {d1 d2 T1 T2}. +Section factD. -Section mswap. -Context d d' d3 (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). -Variable k : R.-ker Y * X ~> Z. +Let factD' n m : (n`! * m`! <= (n + m).+1`!)%N. +Proof. +elim: n m => /= [m|n ih m]. + by rewrite fact0 mul1n add0n factS leq_pmull. +rewrite 2!factS [in X in (_ <= _ * X)%N]addSn -mulnA leq_mul//. +by rewrite ltnS addSnnS leq_addr. +Qed. -Definition mswap xy U := k (swap xy) U. +Lemma factD n m : (n`! * m.-1`! <= (n + m)`!)%N. +Proof. +case: m => //= [|m]. + by rewrite fact0 muln1 addn0. +by rewrite addnS factD'. +Qed. + +End factD. + +Lemma leq_prod2 (x y n m : nat) : (n <= x)%N -> (m <= y)%N -> + (\prod_(m <= i < y) i * \prod_(n <= i < x) i <= \prod_(n + m <= i < x + y) i)%N. +Proof. +move=> nx my; rewrite big_addn -addnBA//. +rewrite [in leqRHS]/index_iota -addnBAC// iotaD big_cat/=. +rewrite mulnC leq_mul//. + by apply: leq_prod; move=> i _; rewrite leq_addr. +rewrite subnKC//. +rewrite -[in leqLHS](add0n m) big_addn. +rewrite [in leqRHS](_ : y - m = ((y - m + x) - x))%N; last first. + by rewrite -addnBA// subnn addn0. +rewrite -[X in iota X _](add0n x) big_addn -addnBA// subnn addn0. +by apply: leq_prod => i _; rewrite leq_add2r leq_addr. +Qed. -Let mswap0 xy : mswap xy set0 = 0. -Proof. done. Qed. +Lemma leq_fact2 (x y n m : nat) : (n <= x) %N -> (m <= y)%N -> + (x`! * y`! * ((n + m).+1)`! <= n`! * m`! * ((x + y).+1)`!)%N. +Proof. +move=> nx my. +rewrite (fact_split nx) -!mulnA leq_mul2l; apply/orP; right. +rewrite (fact_split my) mulnCA -!mulnA leq_mul2l; apply/orP; right. +rewrite [leqRHS](_ : _ = (n + m).+1`! * \prod_((n + m).+2 <= i < (x + y).+2) i)%N; last first. + by rewrite -fact_split// ltnS leq_add. +rewrite mulnA mulnC leq_mul2l; apply/orP; right. +do 2 rewrite -addSn -addnS. +exact: leq_prod2. +Qed. -Let mswap_ge0 x U : 0 <= mswap x U. -Proof. done. Qed. +Lemma bounded_norm_expn_onem {R : realType} (a b : nat) : + [bounded `|x ^+ a * (1 - x) ^+ b|%R : R | x in (`[0%R, 1%R]%classic : set R)]. +Proof. +exists 1%R; split; [by rewrite num_real|move=> x x1 /= y]. +rewrite in_itv/= => /andP[y0 y1]. +rewrite ger0_norm// ger0_norm; last first. + by rewrite mulr_ge0 ?exprn_ge0// subr_ge0. +rewrite (le_trans _ (ltW x1))// mulr_ile1 ?exprn_ge0//. +- by rewrite subr_ge0. +- by rewrite exprn_ile1. +- rewrite exprn_ile1 ?subr_ge0//. + by rewrite lerBlDl addrC -lerBlDl subrr. +Qed. -Let mswap_sigma_additive x : semi_sigma_additive (mswap x). -Proof. exact: measure_semi_sigma_additive. Qed. +Lemma measurable_fun_expn_onem {R : realType} a b : + measurable_fun setT (fun x : R => x ^+ a * `1-x ^+ b)%R. +Proof. +apply/measurable_funM => //; apply/measurable_fun_pow => //. +exact: measurable_funB. +Qed. -HB.instance Definition _ x := isMeasure.Build _ _ R - (mswap x) (mswap0 x) (mswap_ge0 x) (@mswap_sigma_additive x). +Section ubeta_nat_pdf. +Local Open Scope ring_scope. +Context {R : realType}. +Variables a b : nat. -Definition mkswap : _ -> {measure set Z -> \bar R} := - fun x => mswap x. +(* unnormalized pdf *) +Definition ubeta_nat_pdf (t : R) := + if (0 <= t <= 1)%R then (t ^+ a.-1 * (`1-t) ^+ b.-1)%R else 0%R. -Let measurable_fun_kswap U : - measurable U -> measurable_fun setT (mkswap ^~ U). +Lemma ubeta_nat_pdf_ge0 t : 0 <= ubeta_nat_pdf t. Proof. -move=> mU. -rewrite [X in measurable_fun _ X](_ : _ = k ^~ U \o @swap _ _)//. -apply measurableT_comp => //=; first exact: measurable_kernel. -exact: measurable_swap. +rewrite /ubeta_nat_pdf; case: ifPn => // /andP[t0 t1]. +by rewrite mulr_ge0// exprn_ge0// onem_ge0. +Qed. + +Lemma ubeta_nat_pdf_le1 t : ubeta_nat_pdf t <= 1. +Proof. +rewrite /ubeta_nat_pdf; case: ifPn => // /andP[t0 t1]. +by rewrite mulr_ile1// ?(exprn_ge0,onem_ge0,exprn_ile1,onem_le1). Qed. -HB.instance Definition _ := isKernel.Build _ _ - (X * Y)%type Z R mkswap measurable_fun_kswap. +Lemma measurable_ubeta_nat_pdf : measurable_fun setT ubeta_nat_pdf. +Proof. +rewrite /ubeta_nat_pdf /=; apply: measurable_fun_if => //=; last first. + by rewrite setTI; apply: measurable_funTS; exact: measurable_fun_expn_onem. +apply: measurable_and => /=. + apply: (measurable_fun_bool true). + rewrite [X in measurable X](_ : _ = `[0, +oo[%classic)//. + by rewrite set_interval.set_itv_c_infty. +apply: (measurable_fun_bool true). +by rewrite [X in measurable X](_ : _ = `]-oo, 1]%classic)//. +Qed. -End mswap. +Local Notation mu := lebesgue_measure. -Section mswap_sfinite_kernel. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). -Variable k : R.-sfker Y * X ~> Z. +Lemma integral_ubeta_nat_pdf U : + (\int[mu]_(x in U) (ubeta_nat_pdf x)%:E = + \int[mu]_(x in U `&` `[0%R, 1%R]) (ubeta_nat_pdf x)%:E)%E. +Proof. +rewrite [RHS]integral_mkcondr/=; apply: eq_integral => x xU. +rewrite patchE; case: ifPn => //. +rewrite notin_setE/= in_itv/= => /negP. +rewrite negb_and -!ltNge => /orP[x0|x1]. + by rewrite /ubeta_nat_pdf leNgt x0/=. +by rewrite /ubeta_nat_pdf !leNgt x1/= andbF. +Qed. -Let mkswap_sfinite : - exists2 k_ : (R.-ker X * Y ~> Z)^nat, - forall n, measure_fam_uub (k_ n) & - forall x U, measurable U -> mkswap k x U = kseries k_ x U. +Lemma integral_ubeta_nat_pdfT : + (\int[mu]_x (ubeta_nat_pdf x)%:E = + \int[mu]_(x in `[0%R, 1%R]) (ubeta_nat_pdf x)%:E)%E. +Proof. by rewrite integral_ubeta_nat_pdf/= setTI. Qed. + +End ubeta_nat_pdf. + +Lemma ubeta_nat_pdf11 {R : realType} (x : R) : (0 <= x <= 1)%R -> + ubeta_nat_pdf 1 1 x = 1%R. Proof. -have [k_ /= kE] := sfinite_kernel k. -exists (fun n => mkswap (k_ n)). - move=> n. - have /measure_fam_uubP[M hM] := measure_uub (k_ n). - by exists M%:num => x/=; exact: hM. -move=> xy U mU. -by rewrite /mswap/= kE. +move=> x01. +by rewrite /ubeta_nat_pdf !expr0 mulr1 x01. Qed. -HB.instance Definition _ := - Kernel_isSFinite_subdef.Build _ _ _ Z R (mkswap k) mkswap_sfinite. +(* normalization constant *) +Definition beta_nat_norm {R : realType} (a b : nat) : R := + fine (\int[@lebesgue_measure R]_x (ubeta_nat_pdf a b x)%:E). -End mswap_sfinite_kernel. +Axiom beta_nat_normE : forall {R : realType} (a b : nat), + beta_nat_norm a b = a.-1`!%:R * b.-1`!%:R / (a + b).-1`!%:R :> R. -Section kswap_finite_kernel_finite. -Context d d' d3 (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) - (k : R.-fker Y * X ~> Z). +Lemma beta_nat_norm_gt0 {R : realType} (a b : nat) : + (0 < beta_nat_norm a b :> R)%R. +Proof. by rewrite beta_nat_normE divr_gt0// ?mulr_gt0 ?ltr0n ?fact_gt0. Qed. -Let mkswap_finite : measure_fam_uub (mkswap k). +Lemma beta_nat_norm_ge0 {R : realType} (a b : nat) : + (0 <= beta_nat_norm a b :> R)%R. +Proof. exact/ltW/beta_nat_norm_gt0. Qed. + +Lemma integral_ubeta_nat_pdf_lty {R : realType} (a b : nat) : + (\int[@lebesgue_measure R]_x (ubeta_nat_pdf a b x)%:E) < +oo. Proof. -have /measure_fam_uubP[r hr] := measure_uub k. -apply/measure_fam_uubP; exists (PosNum [gt0 of r%:num%R]) => x /=. -exact: hr. +have := @beta_nat_norm_gt0 R a b. +rewrite /beta_nat_norm; set x := integral _ _ _. +by case: x => [r _| |//]; rewrite ?ltxx ?ltry. Qed. -HB.instance Definition _ := - Kernel_isFinite.Build _ _ _ Z R (mkswap k) mkswap_finite. +Lemma integral_ubeta_nat_pdf_fin_num {R : realType} (a b : nat) : + (\int[@lebesgue_measure R]_x (ubeta_nat_pdf a b x)%:E) \is a fin_num. +Proof. +rewrite ge0_fin_numE ?integral_ubeta_nat_pdf_lty//. +by apply: integral_ge0 => //= x _; rewrite lee_fin ubeta_nat_pdf_ge0. +Qed. -End kswap_finite_kernel_finite. +Lemma integral_ubeta_nat_pdfE {R : realType} (a b : nat) : + \int[lebesgue_measure]_x (ubeta_nat_pdf a b x)%:E = (beta_nat_norm a b)%:E :> \bar R. +Proof. by rewrite -[LHS]fineK ?integral_ubeta_nat_pdf_fin_num. Qed. -Notation "l .; k" := (mkcomp l (mkswap k)) : ereal_scope. +Lemma beta_nat_norm11 {R : realType} : beta_nat_norm 1 1 = 1%R :> R. +Proof. by rewrite beta_nat_normE/= fact0 mulr1/= divff. Qed. -Section letin'. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). +Section integrable_ubeta_nat_pdf. +Context {R : realType} (a b : nat). -Definition letin' (l : R.-sfker X ~> Y) (k : R.-sfker Y * X ~> Z) := - locked [the R.-sfker X ~> Z of l .; k]. +Local Notation mu := lebesgue_measure. -Lemma letin'E (l : R.-sfker X ~> Y) (k : R.-sfker Y * X ~> Z) x U : - letin' l k x U = \int[l x]_y k (y, x) U. -Proof. by rewrite /letin'; unlock. Qed. +Lemma integrable_ubeta_nat_pdf : mu.-integrable setT + (fun x : salgebraType (R.-ocitv.-measurable) => (ubeta_nat_pdf a b x)%:E). +Proof. +apply/integrableP; split. + by apply/EFin_measurable_fun; exact: measurable_ubeta_nat_pdf. +under eq_integral. + move=> /= x _. + rewrite ger0_norm//; last by rewrite ubeta_nat_pdf_ge0. + over. +by rewrite /= integral_ubeta_nat_pdf_lty. +Qed. -Lemma letin'_letin (l : R.-sfker X ~> Y) (k : R.-sfker Y * X ~> Z) : - letin' l k = letin l (mkswap k). -Proof. by rewrite /letin'; unlock. Qed. +End integrable_ubeta_nat_pdf. -End letin'. +Section beta_nat_pdf. +Local Open Scope ring_scope. +Context {R : realType}. +Variables a b : nat. -Section letin'C. -Import Notations. -Context d d1 d' (X : measurableType d) (Y : measurableType d1) - (Z : measurableType d') (R : realType). -Variables (t : R.-sfker Z ~> X) - (u' : R.-sfker X * Z ~> Y) - (u : R.-sfker Z ~> Y) - (t' : R.-sfker Y * Z ~> X) - (tt' : forall y, t =1 fun z => t' (y, z)) - (uu' : forall x, u =1 fun z => u' (x, z)). - -Definition T' z : set X -> \bar R := t z. -Let T0 z : (T' z) set0 = 0. Proof. by []. Qed. -Let T_ge0 z x : 0 <= (T' z) x. Proof. by []. Qed. -Let T_semi_sigma_additive z : semi_sigma_additive (T' z). -Proof. exact: measure_semi_sigma_additive. Qed. -HB.instance Definition _ z := @isMeasure.Build _ X R (T' z) (T0 z) (T_ge0 z) - (@T_semi_sigma_additive z). - -Let sfinT z : sfinite_measure (T' z). Proof. exact: sfinite_kernel_measure. Qed. -HB.instance Definition _ z := @isSFinite.Build _ X R (T' z) (sfinT z). - -Definition U' z : set Y -> \bar R := u z. -Let U0 z : (U' z) set0 = 0. Proof. by []. Qed. -Let U_ge0 z x : 0 <= (U' z) x. Proof. by []. Qed. -Let U_semi_sigma_additive z : semi_sigma_additive (U' z). -Proof. exact: measure_semi_sigma_additive. Qed. -HB.instance Definition _ z := @isMeasure.Build _ Y R (U' z) (U0 z) (U_ge0 z) - (@U_semi_sigma_additive z). - -Let sfinU z : sfinite_measure (U' z). Proof. exact: sfinite_kernel_measure. Qed. -HB.instance Definition _ z := @isSFinite.Build _ Y R (U' z) (sfinU z). - -Lemma letin'C z A : measurable A -> - letin' t - (letin' u' - (ret (measurable_fun_prod macc1of3' macc0of3'))) z A = - letin' u - (letin' t' - (ret (measurable_fun_prod macc0of3' macc1of3'))) z A. +(* normalized pdf for beta *) +Definition beta_nat_pdf t : R := ubeta_nat_pdf a b t / (beta_nat_norm a b). + +Lemma measurable_beta_nat_pdf : measurable_fun setT beta_nat_pdf. +Proof. by apply: measurable_funM => //; exact: measurable_ubeta_nat_pdf. Qed. + +Lemma beta_nat_pdf_ge0 t : 0 <= beta_nat_pdf t. Proof. -move=> mA. -rewrite !letin'E. +rewrite /beta_nat_pdf divr_ge0//; first exact: ubeta_nat_pdf_ge0. +exact: beta_nat_norm_ge0. +Qed. + +Lemma beta_nat_pdf_le_beta_nat_norm x : beta_nat_pdf x <= (beta_nat_norm a b)^-1. +Proof. +rewrite /beta_nat_pdf ler_pdivrMr ?beta_nat_norm_gt0//. +rewrite mulVf// ?gt_eqF ?beta_nat_norm_gt0//. +exact: ubeta_nat_pdf_le1. +Qed. + +Local Notation mu := lebesgue_measure. + +Lemma int_beta_nat_pdf01 : + (\int[mu]_(x in `[0%R, 1%R]) (beta_nat_pdf x)%:E = + \int[mu]_x (beta_nat_pdf x)%:E :> \bar R)%E. +Proof. +rewrite /beta_nat_pdf. +under eq_integral do rewrite EFinM. +rewrite /=. +rewrite ge0_integralZr//=; last 3 first. + apply: measurable_funTS => /=; apply/EFin_measurable_fun => //. + exact: measurable_ubeta_nat_pdf. + by move=> x _; rewrite lee_fin ubeta_nat_pdf_ge0. + by rewrite lee_fin invr_ge0// beta_nat_norm_ge0. +rewrite -integral_ubeta_nat_pdfT -ge0_integralZr//=. +- by apply/measurableT_comp => //; exact: measurable_ubeta_nat_pdf. +- by move=> x _; rewrite lee_fin ubeta_nat_pdf_ge0. +- by rewrite lee_fin invr_ge0// beta_nat_norm_ge0. +Qed. + +Lemma integrable_beta_nat_pdf : + mu.-integrable setT (fun y => (beta_nat_pdf y)%:E). +Proof. +apply/integrableP; split. + by apply/EFin_measurable_fun; exact: measurable_beta_nat_pdf. under eq_integral. - move=> x _. - rewrite letin'E -uu'. - under eq_integral do rewrite retE /=. + move=> /= x _. + rewrite ger0_norm//; last first. + by rewrite beta_nat_pdf_ge0. + over. +have -> : (\int[mu]_x `(beta_nat_pdf x)%:E = + \int[mu]_(x in `[0%R, 1%R]) `(beta_nat_pdf x)%:E)%E. + by rewrite -int_beta_nat_pdf01. +apply: (@le_lt_trans _ _ (\int[mu]_(x in `[0%R, 1%R]) (beta_nat_norm a b)^-1%:E)%E). + apply: ge0_le_integral => //=. + - by move=> x _; rewrite lee_fin beta_nat_pdf_ge0. + - by apply/measurable_funTS/EFin_measurable_fun => /=; exact: measurable_beta_nat_pdf. + - by move=> x _; rewrite lee_fin invr_ge0// beta_nat_norm_ge0. + - by move=> x _; rewrite lee_fin beta_nat_pdf_le_beta_nat_norm. + - rewrite integral_cst//= lebesgue_measure_itv//=. + by rewrite lte01 oppr0 adde0 mule1 ltry. +Qed. + +End beta_nat_pdf. + +Lemma bounded_beta_nat_pdf_01 {R : realType} (a b : nat) : + [bounded beta_nat_pdf a b x | x in `[0%R, 1%R]%classic : set R]. +Proof. +exists (1 / beta_nat_norm a b); split; first by rewrite num_real. +move=> // y y1. +near=> M => /=. +rewrite (le_trans _ (ltW y1))//. +near: M. +move=> M /=. +rewrite in_itv/= => /andP[M0 M1]. +rewrite /beta_nat_pdf. +rewrite ler_norml; apply/andP; split. + rewrite -mulNr. + rewrite ler_pM2r ?invr_gt0 ?beta_nat_norm_gt0//. + by rewrite (le_trans (@lerN10 R))// ubeta_nat_pdf_ge0. +rewrite ler_pM2r ?invr_gt0 ?beta_nat_norm_gt0//. +by rewrite ubeta_nat_pdf_le1. +Unshelve. all: by end_near. Qed. + +Section beta_nat. +Local Open Scope ring_scope. +Context {R : realType}. +Variables a b : nat. + +Local Notation mu := (@lebesgue_measure R). + +Let ubeta_nat (U : set (measurableTypeR R)) : \bar R := + \int[mu]_(x in U) (ubeta_nat_pdf a b x)%:E. + +Let ubeta_nat_lty U : measurable U -> (ubeta_nat U < +oo)%E. +Proof. +move=> mU. +rewrite /ubeta_nat. +apply: (@le_lt_trans _ _ (\int[mu]_(x in U `&` `[0%R, 1%R]%classic) 1)%E); last first. + rewrite integral_cst//= ?mul1e//. + rewrite (le_lt_trans (measureIr _ _ _))//= lebesgue_measure_itv//= lte01//. + by rewrite EFinN sube0 ltry. + exact: measurableI. +rewrite integral_ubeta_nat_pdf ge0_le_integral//=. +- exact: measurableI. +- by move=> x _; rewrite lee_fin ubeta_nat_pdf_ge0. +- apply/measurable_funTS/measurableT_comp => //. + exact: measurable_ubeta_nat_pdf. +- by move=> x _; rewrite lee_fin ubeta_nat_pdf_le1. +Qed. + +Let ubeta_nat0 : ubeta_nat set0 = 0%:E. +Proof. by rewrite /ubeta_nat integral_set0. Qed. + +Let ubeta_nat_ge0 U : (0 <= ubeta_nat U)%E. +Proof. +rewrite /ubeta_nat integral_ge0//= => x Ux. +by rewrite lee_fin ubeta_nat_pdf_ge0. +Qed. + +(* TODO: should be shorter *) +Let ubeta_nat_sigma_additive : semi_sigma_additive ubeta_nat. +Proof. +move=> /= F mF tF mUF; rewrite /ubeta_nat; apply: cvg_toP. + apply: ereal_nondecreasing_is_cvgn => m n mn. + apply: lee_sum_nneg_natr => // k _ _. + apply: integral_ge0 => /= x Fkx. + by rewrite lee_fin; exact: ubeta_nat_pdf_ge0. +rewrite ge0_integral_bigcup//=. +- by apply/measurable_funTS/measurableT_comp => //; exact: measurable_ubeta_nat_pdf. +- by move=> x _; rewrite lee_fin ubeta_nat_pdf_ge0. +Qed. + +HB.instance Definition _ := isMeasure.Build _ _ _ ubeta_nat + ubeta_nat0 ubeta_nat_ge0 ubeta_nat_sigma_additive. + +Definition beta_nat (*: set [the measurableType (R.-ocitv.-measurable).-sigma of + salgebraType R.-ocitv.-measurable] -> \bar R*) := + @mscale _ _ _ (invr_nonneg (NngNum (beta_nat_norm_ge0 a b))) ubeta_nat. + +(*Let beta_nat0 : beta_nat set0 = 0. +Proof. exact: measure0. Qed. + +Let beta_nat_ge0 U : (0 <= beta_nat U)%E. +Proof. exact: measure_ge0. Qed. + +Let beta_nat_sigma_additive : semi_sigma_additive beta_nat. +Proof. move=> /= F mF tF mUF; exact: measure_semi_sigma_additive. Qed. + +HB.instance Definition _ := isMeasure.Build _ _ _ beta_nat + beta_nat0 beta_nat_ge0 beta_nat_sigma_additive.*) + +HB.instance Definition _ := Measure.on beta_nat. + +Let beta_nat_setT : beta_nat setT = 1%:E. +Proof. +rewrite /beta_nat /= /mscale /= /ubeta_nat/= integral_ubeta_nat_pdfE//. +by rewrite -EFinM mulVf// gt_eqF// beta_nat_norm_gt0. +Qed. + +HB.instance Definition _ := @Measure_isProbability.Build _ _ _ + beta_nat beta_nat_setT. + +Lemma beta_nat01 : beta_nat `[0, 1] = 1%:E. +Proof. +rewrite /beta_nat /= /mscale/= /ubeta_nat. +rewrite -integral_ubeta_nat_pdfT integral_ubeta_nat_pdfE//. +by rewrite -EFinM mulVf// gt_eqF// beta_nat_norm_gt0. +Qed. + +Lemma beta_nat_fin_num U : measurable U -> beta_nat U \is a fin_num. +Proof. +move=> mU; rewrite ge0_fin_numE//. +rewrite /beta_nat/= /mscale/= /ubeta_nat lte_mul_pinfty//. + by rewrite lee_fin// invr_ge0 beta_nat_norm_ge0. +apply: (@le_lt_trans _ _ (\int[mu]_x (ubeta_nat_pdf a b x)%:E))%E. + apply: ge0_subset_integral => //=. + by apply/EFin_measurable_fun; exact: measurable_ubeta_nat_pdf. + by move=> x _; rewrite lee_fin ubeta_nat_pdf_ge0. +rewrite integral_ubeta_nat_pdfT. +apply: (@le_lt_trans _ _ (\int[mu]_(x in `[0%R, 1%R]) (cst 1 x)))%E. + apply: ge0_le_integral => //=. + - by move=> x _; rewrite lee_fin ubeta_nat_pdf_ge0. + - apply/measurable_funTS/measurableT_comp => //. + exact: measurable_ubeta_nat_pdf. + - by move=> x _; rewrite lee_fin ubeta_nat_pdf_le1. +by rewrite integral_cst//= lebesgue_measure_itv/= lte01 mul1e EFinN sube0 ltry. +Qed. + +End beta_nat. +Arguments beta_nat {R}. + +Lemma integral_beta_nat_pdf {R : realType} a b (U : set R) : measurable U -> + \int[lebesgue_measure]_(x in U) (beta_nat_pdf a b x)%:E = + beta_nat a b U :> \bar R. +Proof. +move=> mU. +rewrite /beta_nat_pdf. +under eq_integral do rewrite EFinM/=. +rewrite ge0_integralZr//=. +- by rewrite /beta_nat/= /mscale/= muleC. +- apply/measurable_funTS/measurableT_comp => //. + exact: measurable_ubeta_nat_pdf. +- by move=> x _; rewrite lee_fin ubeta_nat_pdf_ge0. +- by rewrite lee_fin invr_ge0// beta_nat_norm_ge0. +Qed. + +Lemma integral_beta_bernoulli_expn_lty {R : realType} n a b U : + (\int[beta_nat a b]_x `|bernoulli ((1 - x) ^+ n) U| < +oo :> \bar R)%E. +Proof. +apply: (@le_lt_trans _ _ (\int[beta_nat a b]_x cst 1 x))%E. + apply: ge0_le_integral => //=. + apply: measurableT_comp => //=. + apply: (measurableT_comp (measurable_bernoulli2 _)) => //. + by apply: measurable_fun_pow => //; exact: measurable_funB. + by move=> x _; rewrite gee0_abs// probability_le1. +by rewrite integral_cst//= mul1e -ge0_fin_numE// beta_nat_fin_num. +Qed. + +Lemma integral_beta_bernoulli_onem_lty {R : realType} n a b U : + (\int[beta_nat a b]_x `|bernoulli (1 - (1 - x) ^+ n) U| < +oo :> \bar R)%E. +Proof. +apply: (@le_lt_trans _ _ (\int[beta_nat a b ]_x cst 1 x))%E. + apply: ge0_le_integral => //=. + apply: measurableT_comp => //=. + apply: (measurableT_comp (measurable_bernoulli2 _)) => //. + apply: measurable_funB => //=. + by apply: measurable_fun_pow => //; exact: measurable_funB. + by move=> x y; rewrite gee0_abs// probability_le1. +by rewrite integral_cst//= mul1e -ge0_fin_numE// beta_nat_fin_num. +Qed. + +Section beta11_uniform. +Local Open Scope ring_scope. +Context {R : realType}. + +Lemma beta11_uniform : beta_nat 1 1 = uniform_prob (@ltr01 R). +Proof. +apply/funext => U. +rewrite /beta_nat /uniform_prob. +rewrite /mscale/= beta_nat_norm11 invr1 !mul1e. +rewrite integral_ubeta_nat_pdf integral_uniform_pdf. +under eq_integral. + move=> /= x. + rewrite inE => -[Ux/=]; rewrite in_itv/= => x10. + rewrite ubeta_nat_pdf11//=. over. -rewrite (sfinite_Fubini (T' z) (U' z) (fun x => \d_(x.1, x.2) A ))//; last first. - apply/EFin_measurable_fun => /=; rewrite (_ : (fun x => _) = mindic R mA)//. - by apply/funext => -[]. rewrite /=. -apply: eq_integral => y _. -by rewrite letin'E/= -tt'; apply: eq_integral => // x _; rewrite retE. +under [RHS]eq_integral. + move=> /= x. + rewrite inE => -[Ux/=]; rewrite in_itv/= => x10. + rewrite /uniform_pdf x10 subr0 invr1. + over. +by rewrite /=. Qed. -End letin'C. -Arguments letin'C {d d1 d' X Y Z R} _ _ _ _. +End beta11_uniform. -Section letin'A. -Context d d' d1 d2 d3 (X : measurableType d) (Y : measurableType d') - (T1 : measurableType d1) (T2 : measurableType d2) (T3 : measurableType d3) - (R : realType). -Import Notations. -Variables (t : R.-sfker X ~> T1) - (u : R.-sfker T1 * X ~> T2) - (v : R.-sfker T2 * X ~> Y) - (v' : R.-sfker T2 * (T1 * X) ~> Y) - (vv' : forall y, v =1 fun xz => v' (xz.1, (y, xz.2))). - -Lemma letin'A x A : measurable A -> - letin' t (letin' u v') x A - = - (letin' (letin' t u) v) x A. +Section integral_beta. +Context {R : realType}. +Variables a b : nat. + +Local Notation mu := lebesgue_measure. + +Lemma beta_nat_dom : @beta_nat R a b `<< mu. +Proof. +move=> A mA muA0; rewrite /beta_nat /mscale/=. +apply/eqP; rewrite mule_eq0 eqe invr_eq0 gt_eqF/= ?beta_nat_norm_gt0//; apply/eqP. +rewrite integral_ubeta_nat_pdf; apply/eqP; rewrite eq_le; apply/andP; split; last first. + by apply: integral_ge0 => x _; rewrite lee_fin ubeta_nat_pdf_ge0. +apply: (@le_trans _ _ (\int[mu]_(x in A `&` `[0%R, 1%R]%classic) 1)); last first. + rewrite integral_cst ?mul1e//=; last exact: measurableI. + by rewrite -[leRHS]muA0 measureIl. +apply: ge0_le_integral => //=; first exact: measurableI. +- by move=> x _; rewrite lee_fin ubeta_nat_pdf_ge0. +- apply/measurable_funTS/measurableT_comp => //. + exact: measurable_ubeta_nat_pdf. +- by move=> x _; rewrite lee_fin ubeta_nat_pdf_le1. +Qed. + +Lemma integral_beta_nat f U : measurable U -> + measurable_fun U f -> + \int[beta_nat a b]_(x in U) `|f x| < +oo -> + \int[beta_nat a b]_(x in U) f x = + \int[mu]_(x in U) (f x * (beta_nat_pdf a b x)%:E) :> \bar R. +Proof. +move=> mU mf finf. +rewrite -(Radon_Nikodym_change_of_variables beta_nat_dom) //=; last first. + by apply/integrableP; split. +apply: ae_eq_integral => //. +- apply: emeasurable_funM => //. + apply: measurable_int. + apply: integrableS (Radon_Nikodym_integrable _) => //=. + exact: beta_nat_dom. +- apply: emeasurable_funM => //=; apply/measurableT_comp => //=. + by apply/measurable_funTS; exact: measurable_beta_nat_pdf. +- apply: ae_eq_mul2l => /=. + rewrite Radon_NikodymE//=. + exact: beta_nat_dom. + move=> ?. + case: cid => /= h [h1 h2 h3]. + apply: integral_ae_eq => //. + + apply: integrableS h2 => //. (* integrableST? *) + apply/measurable_funTS/measurableT_comp => //. + exact: measurable_beta_nat_pdf. + + move=> E E01 mE. + have mB : measurable_fun E (EFin \o ubeta_nat_pdf a b). + apply/measurable_funTS/measurableT_comp => //. + exact: measurable_ubeta_nat_pdf. + by rewrite -(h3 _ mE)/= integral_beta_nat_pdf. +Qed. + +Local Open Scope ring_scope. + +Definition beta_nat_bernoulli a' b' U : \bar R := + \int[beta_nat a b]_(y in `[0, 1]) bernoulli (ubeta_nat_pdf a'.+1 b'.+1 y) U. + +Local Notation B := beta_nat_norm. + +Definition div_beta_nat_norm a' b' : R := + (beta_nat_norm (a + a') (b + b')) / beta_nat_norm a b. + +Lemma div_beta_nat_norm_ge0 a' b' : 0 <= div_beta_nat_norm a' b'. +Proof. by rewrite /div_beta_nat_norm divr_ge0// beta_nat_norm_ge0. Qed. + +Lemma div_beta_nat_norm_le1 a' b' : div_beta_nat_norm a' b' <= 1. +Proof. +rewrite /div_beta_nat_norm. +rewrite ler_pdivrMr// ?mul1r ?beta_nat_norm_gt0//. +rewrite !beta_nat_normE. +rewrite ler_pdivrMr ?ltr0n ?fact_gt0//. +rewrite mulrAC. +rewrite ler_pdivlMr ?ltr0n ?fact_gt0//. +rewrite -!natrM ler_nat. +case: a. + rewrite /= fact0 mul1n !add0n. + case: b => /=. + case: a' => //. + case: b' => //= m. + by rewrite fact0 !mul1n muln1. + move=> n/=. + by rewrite fact0 add0n muln1 mul1n factD. + move=> m. + rewrite mulnC leq_mul// mulnC. + by rewrite (leq_trans (factD _ _))// addSn addnS//= addnC. +move=> n. +rewrite addSn. +case: b. + rewrite !fact0 add0n muln1 [leqRHS]mulnC addn0/= leq_mul//. + by rewrite factD. +move=> m. +rewrite [(n + a').+1.-1]/=. +rewrite [n.+1.-1]/=. +rewrite [m.+1.-1]/=. +rewrite addnS. +rewrite [(_ + m).+1.-1]/=. +rewrite (addSn m b'). +rewrite [(m + _).+1.-1]/=. +rewrite (addSn (n + a')). +rewrite [_.+1.-1]/=. +rewrite addSn addnS. +by rewrite leq_fact2// leq_addr. +Qed. + +Lemma beta_nat_integrable a' b' : + (beta_nat a b).-integrable `[0, 1] + (fun x : salgebraType (R.-ocitv.-measurable) => (x ^+ a' * `1-x ^+ b')%:E). Proof. -move=> mA. -rewrite !letin'E. -under eq_integral do rewrite letin'E. -rewrite letin'_letin/=. -rewrite integral_kcomp; [|by []|]. - apply: eq_integral => z _. - apply: eq_integral => y _. - by rewrite (vv' z). -exact: measurableT_comp (@measurable_kernel _ _ _ _ _ v _ mA) _. +apply/integrableP; split. + apply/measurable_funTS/measurableT_comp => //. + exact: measurable_fun_expn_onem. +apply: (@le_lt_trans _ _ (\int[beta_nat a b]_(x in `[0%R, 1%R]) 1)%E). + apply: ge0_le_integral => //=. + apply/measurable_funTS/measurableT_comp => //. + by apply/measurableT_comp => //; exact: measurable_fun_expn_onem. + move=> x; rewrite in_itv/= => /andP[x0 x1]. + rewrite lee_fin. + rewrite ger0_norm; last first. + by rewrite !mulr_ge0// exprn_ge0// onem_ge0. + by rewrite mulr_ile1// ?exprn_ge0 ?onem_ge0// exprn_ile1// ?onem_ge0// onem_le1. +rewrite integral_cst//= mul1e. +rewrite -ge0_fin_numE//. +by apply: beta_nat_fin_num. Qed. -End letin'A. +Lemma beta_nat_integrable_onem a' b' : + (beta_nat a b).-integrable `[0, 1] + (fun x : salgebraType (R.-ocitv.-measurable) => (`1-(x ^+ a' * `1-x ^+ b')%:E)). +Proof. +apply: (eq_integrable _ (cst 1 \- (fun x : salgebraType (R.-ocitv.-measurable) => (x ^+ a' * `1-x ^+ b')%:E))%E) => //. +apply: (@integrableB _ (salgebraType R.-ocitv.-measurable)) => //=. + (* TODO: lemma? *) + apply/integrableP; split => //. + rewrite (eq_integral (fun x => (\1_setT x)%:E))/=; last first. + by move=> x _; rewrite /= indicT normr1. + rewrite integral_indic//= setTI /beta_nat /mscale/= lte_mul_pinfty//. + by rewrite lee_fin invr_ge0 beta_nat_norm_ge0. + have /integrableP[_] := @integrable_ubeta_nat_pdf R a b. + under eq_integral. + move=> x _. + rewrite gee0_abs//; last first. + by rewrite lee_fin ubeta_nat_pdf_ge0. + over. + by rewrite /= integral_ubeta_nat_pdfT. +exact: beta_nat_integrable. +Qed. + +Lemma beta_nat_integrable_dirac a' b' (c : bool) U : + (beta_nat a b).-integrable `[0, 1] + (fun x : salgebraType (R.-ocitv.-measurable) => ((x ^+ a' * `1-x ^+ b')%:E * \d_c U)%E). +Proof. +apply: integrableMl => //=; last first. + exists 1; split => // x x1/= _ _; rewrite (le_trans _ (ltW x1))//. + by rewrite ger0_norm// indicE; case: (_ \in _). +exact: beta_nat_integrable. +Qed. + +Lemma beta_nat_integrable_onem_dirac a' b' (c : bool) U : + (beta_nat a b).-integrable `[0, 1] + (fun x : salgebraType (R.-ocitv.-measurable) => (`1-(x ^+ a' * `1-x ^+ b')%:E * \d_c U)%E). +Proof. +apply: integrableMl => //=; last first. + exists 1; split => // x x1/= _ _; rewrite (le_trans _ (ltW x1))//. + by rewrite ger0_norm// indicE; case: (_ \in _). +exact: beta_nat_integrable_onem. +Qed. + +Lemma normr_onem (x : R) : 0 <= x <= 1 -> `|1 - x| <= 1. +Proof. +move=> /andP[x0 x1]; rewrite ler_norml; apply/andP; split. + by rewrite lerBrDl lerBlDr (le_trans x1)// lerDl. +by rewrite lerBlDr lerDl. +Qed. + +Lemma beta_nat_bernE a' b' U : (a > 0)%N -> (b > 0)%N -> + beta_nat_bernoulli a' b' U = bernoulli (div_beta_nat_norm a' b') U. +Proof. +move=> a0 b0. +rewrite /beta_nat_bernoulli. +under eq_integral => x. + rewrite inE/= in_itv/= => x01. + rewrite bernoulliE_ext/= ?ubeta_nat_pdf_ge0 ?ubeta_nat_pdf_le1//. + over. +rewrite /=. +rewrite [in RHS]bernoulliE_ext/= ?div_beta_nat_norm_ge0 ?div_beta_nat_norm_le1//=. +under eq_integral => x x01. + rewrite /ubeta_nat_pdf. + rewrite inE /=in_itv/= in x01. + rewrite x01. + over. +rewrite /=. +rewrite integralD//=; last 2 first. + exact: beta_nat_integrable_dirac. + exact: beta_nat_integrable_onem_dirac. +congr (_ + _). + under eq_integral do rewrite muleC. + rewrite integralZl//=; last first. + exact: beta_nat_integrable. + rewrite muleC. (* TODO: use integralZr *) + congr (_ * _)%E. + rewrite integral_beta_nat//; last 2 first. + apply/measurable_funTS/measurableT_comp => //. + exact: measurable_fun_expn_onem. + by have /integrableP[_] := beta_nat_integrable a' b'. + rewrite /beta_nat_pdf. + under eq_integral do rewrite EFinM -muleA muleC -muleA. + rewrite /=. + transitivity (((beta_nat_norm a b)^-1)%:E * + \int[mu]_(x in `[0%R, 1%R]) ((ubeta_nat_pdf (a+a') (b+b') x)%:E) : \bar R)%E. + rewrite -integralZl//=; last first. + apply/integrableP; split. + apply/EFin_measurable_fun. + have := measurable_ubeta_nat_pdf (R:=R) (a + a') (b + b'). + exact: measurable_funS. + under eq_integral. + move=> x x01. + rewrite gee0_abs; last first. + rewrite lee_fin. + exact: ubeta_nat_pdf_ge0. + over. + by rewrite /= -integral_ubeta_nat_pdfT integral_ubeta_nat_pdf_lty. + apply: eq_integral => x x01. + rewrite /ubeta_nat_pdf muleC /onem -EFinM/=. + rewrite inE /= in_itv /= in x01. + rewrite x01. + rewrite (mulrC _ (_^-1)). + rewrite -!EFinM -!mulrA; congr ((_ * _)%:E). + rewrite (mulrCA _ (_ ^+ a')). + rewrite !mulrA. + rewrite -exprD. + rewrite -mulrA. + rewrite -exprD. + congr (_ ^+ _ * _ ^+ _). + by rewrite addnC -!subn1 subDnCA//. + by rewrite addnC -!subn1 subDnCA//. + rewrite -integral_ubeta_nat_pdfT integral_ubeta_nat_pdfE. + by rewrite -EFinM mulrC. +under eq_integral do rewrite muleC. +rewrite /=. +rewrite integralZl//=; last first. + exact: beta_nat_integrable_onem. +rewrite muleC. (* TODO: use integralZr *) +congr (_ * _)%E. +rewrite integral_beta_nat//=; last 2 first. + apply/measurable_funTS/measurableT_comp => //=. + by apply/measurable_funB => //; exact: measurable_fun_expn_onem. + by have /integrableP[] := beta_nat_integrable_onem a' b'. +rewrite /beta_nat_pdf. +under eq_integral do rewrite EFinM muleA muleC. +rewrite integralZl//=; last first. + apply: integrableMr => //=. + - apply/measurable_funTS/measurable_funB => //=. + exact: measurable_fun_expn_onem. + - apply/ex_bound => //. + + apply: (@globally_properfilter _ _ 0%R) => //=. + by apply: inferP; rewrite in_itv/= lexx ler01. + + exists 1 => t. + rewrite /= in_itv/= => t01. + apply: normr_onem; apply/andP; split. + by rewrite mulr_ge0// exprn_ge0// ?onem_ge0//; case/andP: t01. + by rewrite mulr_ile1// ?exprn_ge0 ?exprn_ile1// ?onem_ge0 ?onem_le1//; case/andP: t01. + - exact: integrableS (integrable_ubeta_nat_pdf _ _). +transitivity (((beta_nat_norm a b)^-1)%:E * + \int[mu]_(x in `[0%R, 1%R]) ((ubeta_nat_pdf a b x)%:E - (ubeta_nat_pdf (a+a') (b+b') x)%:E) : \bar R)%E. + congr (_ * _)%E. + apply: eq_integral => x x01. + rewrite /onem -EFinM mulrBl mul1r EFinB. + congr (_ - _)%E. + rewrite /ubeta_nat_pdf /=. + rewrite inE /= in_itv /= in x01. + rewrite x01. + rewrite mulrCA -mulrA -exprD mulrA -exprD. + congr (_ ^+ _ * _ ^+ _)%:E. + by rewrite addnC -!subn1 subDnCA//. + by rewrite -!subn1 subDnCA//. +rewrite integralB_EFin//=; last 2 first. + exact: integrableS (integrable_ubeta_nat_pdf _ _). + exact: integrableS (integrable_ubeta_nat_pdf _ _). +rewrite -!integral_ubeta_nat_pdfT !integral_ubeta_nat_pdfE. +rewrite -EFinM mulrBr /onem mulVf; last first. + by rewrite gt_eqF// beta_nat_norm_gt0. +by rewrite mulrC. +Qed. + +End integral_beta. Declare Scope lang_scope. Delimit Scope lang_scope with P. @@ -377,8 +928,6 @@ match b with | binop_mult => Real end. -(* Import Notations. *) - Definition fun_of_binop g (b : binop) : (mctx g -> mtyp (type_of_binop b)) -> (mctx g -> mtyp (type_of_binop b)) -> @mctx R g -> @mtyp R (type_of_binop b) := match b with @@ -441,16 +990,10 @@ Inductive exp : flag -> ctx -> typ -> Type := | exp_proj1 g t1 t2 : exp D g (Pair t1 t2) -> exp D g t1 | exp_proj2 g t1 t2 : exp D g (Pair t1 t2) -> exp D g t2 | exp_var g str t : t = lookup Unit g str -> exp D g t -| exp_bernoulli g (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : - exp D g (Prob Bool) -| exp_bernoulli_trunc g : - exp D g Real -> exp D g (Prob Bool) -| exp_binomial g (n : nat) (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : - exp D g (Prob Nat) -| exp_binomial_trunc g (n : nat) : - exp D g Real -> exp D g (Prob Nat) -| exp_uniform g (a b : R) (ab0 : (0 < b - a)%R) : exp D g (Prob Real) -| exp_beta g (a b : nat) (* NB: shound be R *) : exp D g (Prob Real) +| exp_bernoulli g : exp D g Real -> exp D g (Prob Bool) +| exp_binomial g (n : nat) : exp D g Real -> exp D g (Prob Nat) +| exp_uniform g (a b : R) (ab : (a < b)%R) : exp D g (Prob Real) +| exp_beta g (a b : nat) (* NB: should be R *) : exp D g (Prob Real) | exp_poisson g : nat -> exp D g Real -> exp D g Real | exp_normalize g t : exp P g t -> exp D g (Prob t) | exp_letin g t1 t2 str : exp P g t1 -> exp P ((str, t1) :: g) t2 -> @@ -482,12 +1025,10 @@ Arguments exp_bin {R} b {g} &. Arguments exp_rel {R} r {g} &. Arguments exp_pair {R g} & {t1 t2}. Arguments exp_var {R g} _ {t} & H. -Arguments exp_bernoulli {R g}. -Arguments exp_bernoulli_trunc {R g} &. -Arguments exp_binomial {R g}. +Arguments exp_bernoulli {R g} &. +Arguments exp_binomial {R g} &. Arguments exp_uniform {R g} &. Arguments exp_beta {R g} &. -Arguments exp_binomial_trunc {R g} &. Arguments exp_poisson {R g}. Arguments exp_normalize {R g _}. Arguments exp_letin {R g} & {_ _}. @@ -572,12 +1113,10 @@ Fixpoint free_vars k g t (e : @exp R k g t) : seq string := | exp_proj1 _ _ _ e => free_vars e | exp_proj2 _ _ _ e => free_vars e | exp_var _ x _ _ => [:: x] - | exp_bernoulli _ _ _ => [::] - | exp_bernoulli_trunc _ e => free_vars e - | exp_binomial _ _ _ _ => [::] + | exp_bernoulli _ e => free_vars e + | exp_binomial _ _ e => free_vars e | exp_uniform _ _ _ _ => [::] | exp_beta _ _ _ => [::] - | exp_binomial_trunc _ _ e => free_vars e | exp_poisson _ _ e => free_vars e | exp_normalize _ _ e => free_vars e | exp_letin _ _ _ x e1 e2 => free_vars e1 ++ rem x (free_vars e2) @@ -683,14 +1222,14 @@ Implicit Type (g : ctx) (str : string). Local Open Scope lang_scope. Local Open Scope ring_scope. -Definition bernoulli0 := @bernoulli R 0%R%:nng ler01. +(*Definition bernoulli0 := @bernoulli R 0%R%:nng ler01. -HB.instance Definition _ := Probability.on bernoulli0. +HB.instance Definition _ := Probability.on bernoulli0.*) Lemma __ : Measurable.sort (pprobability - [the measurableType (R.-ocitv.-measurable).-sigma of - salgebraType (R.-ocitv.-measurable)] R) = + [the measurableType (R.-ocitv.-measurable).-sigma of + salgebraType (R.-ocitv.-measurable)] R) = Measurable.sort (@mtyp R (Prob Real)). rewrite /=. (* done. *) @@ -706,7 +1245,7 @@ Inductive evalD : forall g t, exp D g t -> | eval_real g r : ([r:R] : exp D g _) -D> cst r ; kr r -| eval_pow g n (e : exp D g _) f mf : e -D> f ; mf -> +| eval_pow g n (e : exp D g _) f mf : e -D> f ; mf -> [e ^+ {n}] -D> (fun x => f x ^+ n) ; (measurable_fun_pow n mf) | eval_bin g bop (e1 : exp D g _) f1 mf1 e2 f2 mf2 : @@ -735,35 +1274,25 @@ Inductive evalD : forall g t, exp D g t -> | eval_var g x H : let i := index x (dom g) in exp_var x H -D> acc_typ (map snd g) i ; measurable_acc_typ (map snd g) i -| eval_bernoulli g r r1 : - (exp_bernoulli r r1 : exp D g _) -D> cst (bernoulli r1) ; - measurable_cst _ - -| eval_bernoulli_trunc g e r mr : - e -D> r ; mr -> - (exp_bernoulli_trunc e : exp D g _) -D> bernoulli_trunc \o r ; - measurableT_comp measurable_bernoulli_trunc mr +| eval_bernoulli g e r mr : + e -D> r ; mr -> (exp_bernoulli e : exp D g _) -D> bernoulli \o r ; + measurableT_comp measurable_bernoulli mr -| eval_binomial g n (p : {nonneg R}) (p1 : (p%:num <= 1)%R) : - (exp_binomial n p p1 : exp D g _) -D> cst (binomial_probability n p1) ; - measurable_cst _ +| eval_binomial g n e r mr : + e -D> r ; mr -> (exp_binomial n e : exp D g _) -D> binomial_prob n \o r ; + measurableT_comp (measurable_binomial_probT n) mr -| eval_binomial_trunc g n e r mr : - e -D> r ; mr -> - (exp_binomial_trunc n e : exp D g _) -D> binomial_probability_trunc n \o r ; - measurableT_comp (measurable_binomial_probability_trunc n) mr - -| eval_uniform g (a b : R) (ab0 : (0 < b - a)%R) : - (exp_uniform a b ab0 : exp D g _) -D> cst (uniform_probability ab0) ; - measurable_cst _ +| eval_uniform g (a b : R) (ab : (a < b)%R) : + (exp_uniform a b ab : exp D g _) -D> cst (uniform_prob ab) ; + measurable_cst _ | eval_beta g (a b : nat) : (exp_beta a b : exp D g _) -D> cst (beta_nat a b) ; measurable_cst _ | eval_poisson g n (e : exp D g _) f mf : e -D> f ; mf -> - exp_poisson n e -D> poisson n \o f ; - measurableT_comp (measurable_poisson n) mf + exp_poisson n e -D> poisson_pdf n \o f ; + measurableT_comp (measurable_poisson_pdf n) mf | eval_normalize g t (e : exp P g t) k : e -P> k -> @@ -884,29 +1413,20 @@ all: (rewrite {g t e u v mu mv hu}). inversion 1; subst g0. inj_ex H9; rewrite -H9. by inj_ex H10. -- move=> g r r1 {}v {}mv. - inversion 1; subst g0 r0. - inj_ex H3; subst v. - by have -> : r1 = r3 by []. - move=> g e r mr ev IH {}v {}mv. inversion 1; subst g0. inj_ex H0; subst e0. - inj_ex H4; subst v. - by rewrite (IH _ _ H2). -- move=> g n p p1 {}v {}mv. - inversion 1; subst g0 n0 p0. - inj_ex H4; subst v. - by have -> : p1 = p3 by []. + inj_ex H3; subst v. + by rewrite (IH _ _ H4). - move=> g n e f mf ev IH {}v {}mv. inversion 1; subst g0 n0. inj_ex H2; subst e0. inj_ex H4; subst v. - inj_ex H5; subst mv. - by rewrite (IH _ _ H3). -- move=> g a b ab0 {}v {}mv. + by rewrite (IH _ _ H5). +- move=> g a b ab {}v {}mv. inversion 1; subst g0 a0 b0. inj_ex H4; subst v. - by have -> : ab0 = ab2. + by have -> : ab = ab1. - (* TODO: beta *) move=> g a b {}v {}mv. inversion 1; subst g0 a0 b0. by inj_ex H4; subst v. @@ -1042,29 +1562,20 @@ all: rewrite {g t e u v eu}. inversion 1; subst g0. inj_ex H9; rewrite -H9. by inj_ex H10. -- move=> g r r1 {}v {}mv. - inversion 1; subst g0 r0. - inj_ex H3; subst v. - by have -> : r1 = r3 by []. - move=> g e r mr ev IH {}v {}mv. inversion 1; subst g0. inj_ex H0; subst e0. - inj_ex H4; subst v. - by rewrite (IH _ _ H2). -- move=> g n p p1 {}v {}mv. - inversion 1; subst g0 n0 p0. - inj_ex H4; subst v. - by have -> : p1 = p3 by []. + inj_ex H3; subst v. + by rewrite (IH _ _ H4). - move=> g n e f mf ev IH {}v {}mv. inversion 1; subst g0 n0. inj_ex H2; subst e0. inj_ex H4; subst v. - inj_ex H5; subst mv. - by rewrite (IH _ _ H3). -- move=> g a b ab0 {}v {}mv. + by rewrite (IH _ _ H5). +- move=> g a b ab {}v {}mv. inversion 1; subst g0 a0 b0. inj_ex H4; subst v. - by have -> : ab0 = ab2. + by have -> : ab = ab1. - (* TODO: beta case*) move=> g a b {}v {}mv. inversion 1; subst g0 a0 b0. by inj_ex H4; subst v. @@ -1161,17 +1672,16 @@ all: rewrite {z g t}. - move=> g t1 t2 e [f [mf H]]. by exists (snd \o f); eexists; exact: eval_proj2. - by move=> g x t tE; subst t; eexists; eexists; exact: eval_var. -- by move=> r r1; eexists; eexists; exact: eval_bernoulli. - move=> g e [p [mp H]]. - by exists (bernoulli_trunc \o p); eexists; exact: eval_bernoulli_trunc. -- by move=> p p1; eexists; eexists; exact: eval_binomial. + exists ((bernoulli : R -> pprobability bool R) \o p). + by eexists; exact: eval_bernoulli. - move=> g n e [p [mp H]]. - exists (binomial_probability_trunc n \o p). - eexists; exact: (eval_binomial_trunc n). + exists ((binomial_prob n : R -> pprobability nat R) \o p). + by eexists; exact: (eval_binomial n). - by eexists; eexists; exact: eval_uniform. - by eexists; eexists; exact: eval_beta. - move=> g h e [f [mf H]]. - by exists (poisson h \o f); eexists; exact: eval_poisson. + by exists (poisson_pdf h \o f); eexists; exact: eval_poisson. - move=> g t e [k ek]. by exists (normalize_pt k); eexists; exact: eval_normalize. - move=> g t1 t2 x e1 [k1 ev1] e2 [k2 ev2]. @@ -1339,30 +1849,21 @@ Lemma execD_var g x (H : nth Unit (map snd g) (index x (dom g)) = lookup Unit g (measurable_acc_typ (map snd g) i). Proof. by move=> i; apply/execD_evalD; exact: eval_var. Qed. -Lemma execD_bernoulli g r (r1 : (r%:num <= 1)%R) : - @execD g _ (exp_bernoulli r r1) = - existT _ (cst [the probability _ _ of bernoulli r1]) (measurable_cst _). -Proof. exact/execD_evalD/eval_bernoulli. Qed. - -Lemma execD_bernoulli_trunc g e : - @execD g _ (exp_bernoulli_trunc e) = - existT _ (bernoulli_trunc \o projT1 (execD e)) (measurableT_comp measurable_bernoulli_trunc (projT2 (execD e))). -Proof. exact/execD_evalD/eval_bernoulli_trunc/evalD_execD. Qed. +Lemma execD_bernoulli g e : + @execD g _ (exp_bernoulli e) = + existT _ ((bernoulli : R -> pprobability bool R) \o projT1 (execD e)) + (measurableT_comp measurable_bernoulli (projT2 (execD e))). +Proof. exact/execD_evalD/eval_bernoulli/evalD_execD. Qed. -Lemma execD_binomial g n p (p1 : (p%:num <= 1)%R) : - @execD g _ (exp_binomial n p p1) = - existT _ (cst [the probability _ _ of binomial_probability n p1]) (measurable_cst _). -Proof. exact/execD_evalD/eval_binomial. Qed. - -Lemma execD_binomial_trunc g n e : - @execD g _ (exp_binomial_trunc n e) = - existT _ (binomial_probability_trunc n \o projT1 (execD e)) - (measurableT_comp (measurable_binomial_probability_trunc n) (projT2 (execD e))). -Proof. exact/execD_evalD/eval_binomial_trunc/evalD_execD. Qed. +Lemma execD_binomial g n e : + @execD g _ (exp_binomial n e) = + existT _ ((binomial_prob n : R -> pprobability nat R) \o projT1 (execD e)) + (measurableT_comp (measurable_binomial_probT n) (projT2 (execD e))). +Proof. exact/execD_evalD/eval_binomial/evalD_execD. Qed. Lemma execD_uniform g a b ab0 : @execD g _ (exp_uniform a b ab0) = - existT _ (cst [the probability _ _ of uniform_probability ab0]) (measurable_cst _). + existT _ (cst [the probability _ _ of uniform_prob ab0]) (measurable_cst _). Proof. exact/execD_evalD/eval_uniform. Qed. Lemma execD_beta_nat g a b : @@ -1378,8 +1879,8 @@ Proof. exact/execD_evalD/eval_normalize/evalP_execP. Qed. Lemma execD_poisson g n (e : exp D g Real) : execD (exp_poisson n e) = - existT _ (poisson n \o (projT1 (execD e))) - (measurableT_comp (measurable_poisson n) (projT2 (execD e))). + existT _ (poisson_pdf n \o projT1 (execD e)) + (measurableT_comp (measurable_poisson_pdf n) (projT2 (execD e))). Proof. exact/execD_evalD/eval_poisson/evalD_execD. Qed. Lemma execP_if g st e1 e2 e3 : @@ -1415,3 +1916,29 @@ End execution_functions. Arguments execD_var_erefl {R g} str. Arguments execP_weak {R} g h x {t} e. Arguments exp_var'E {R} str. + +Local Open Scope lang_scope. +Lemma congr_letinl {R : realType} g t1 t2 str (e1 e2 : @exp _ _ g t1) + (e : @exp _ _ (_ :: g) t2) x U : + (forall y V, execP e1 y V = execP e2 y V) -> + measurable U -> + @execP R g t2 [let str := e1 in e] x U = + @execP R g t2 [let str := e2 in e] x U. +Proof. by move=> + mU; move/eq_sfkernel => He; rewrite !execP_letin He. Qed. + +Lemma congr_letinr {R : realType} g t1 t2 str (e : @exp _ _ _ t1) (e1 e2 : @exp _ _ (_ :: g) t2) x U : + (forall y V, execP e1 (y, x) V = execP e2 (y, x) V) -> + @execP R g t2 [let str := e in e1] x U = @execP R g t2 [let str := e in e2] x U. +Proof. by move=> He; rewrite !execP_letin !letin'E; apply: eq_integral => ? _; exact: He. Qed. + +Lemma congr_normalize {R : realType} g t (e1 e2 : @exp R _ g t) : + (forall x U, execP e1 x U = execP e2 x U) -> + execD [Normalize e1] = execD [Normalize e2]. +Proof. +move=> He; apply: eq_execD. +rewrite !execD_normalize_pt /=. +f_equal. +apply: eq_kernel => y V. +exact: He. +Qed. +Local Close Scope lang_scope. diff --git a/theories/lang_syntax_examples.v b/theories/lang_syntax_examples.v index 0803b6a52..1dd864a7e 100644 --- a/theories/lang_syntax_examples.v +++ b/theories/lang_syntax_examples.v @@ -8,26 +8,37 @@ Require Import lebesgue_measure numfun lebesgue_integral kernel prob_lang. Require Import lang_syntax_util lang_syntax. From mathcomp Require Import ring lra. -(******************************************************************************) -(* Examples using the Probabilistic Programming Language of lang_syntax.v *) +(**md**************************************************************************) +(* # Examples using the Probabilistic Programming Language of lang_syntax.v *) (* *) -(* sample_pair_syntax := normalize ( *) +(* sample_pair1213 := normalize ( *) (* let x := sample (bernoulli 1/2) in *) (* let y := sample (bernoulli 1/3) in *) (* return (x, y)) *) (* *) +(* sample_and1213 := normalize ( *) +(* let x := sample (bernoulli 1/2) in *) +(* let y := sample (bernoulli 1/3) in *) +(* return (x && y)) *) +(* *) (* bernoulli13_score := normalize ( *) (* let x := sample (bernoulli 1/3) in *) (* let _ := if x then score (1/3) else score (2/3) in *) (* return x) *) (* *) -(* bernoulli12_score := normalize ( *) -(* let x := sample (bernoulli 1/2) in *) -(* let _ := if x then score (1/3) else score (2/3) in *) -(* return x) *) +(* sample_binomial3 := *) +(* let x := sample (binomial 3 1/2) in *) +(* return x *) (* *) (* hard_constraint := let x := Score {0}:R in return TT *) (* *) +(* guard := *) +(* let p := sample (bernoulli (1 / 3)) in *) +(* let _ := if p then return TT else score 0 in *) +(* return p *) +(* *) +(* more examples about uniform, beta, and bernoulli distributions *) +(* *) (* associativity of let-in expressions *) (* *) (* staton_bus_syntax == example from [Staton, ESOP 2017] *) @@ -50,90 +61,8 @@ Local Open Scope classical_set_scope. Local Open Scope ring_scope. Local Open Scope ereal_scope. -(* letin' versions of rewriting laws *) -Lemma letin'_sample_bernoulli d d' (T : measurableType d) - (T' : measurableType d') (R : realType)(r : {nonneg R}) (r1 : (r%:num <= 1)%R) - (u : R.-sfker bool * T ~> T') x y : - letin' (sample_cst (bernoulli r1)) u x y = - r%:num%:E * u (true, x) y + (`1- (r%:num))%:E * u (false, x) y. -Proof. -rewrite letin'E/=. -rewrite ge0_integral_measure_sum// 2!big_ord_recl/= big_ord0 adde0/=. -by rewrite !ge0_integral_mscale//= !integral_dirac//= !diracT 2!mul1e. -Qed. - -Section letin'_return. -Context d d' d3 (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). - -Lemma letin'_kret (k : R.-sfker X ~> Y) - (f : Y * X -> Z) (mf : measurable_fun setT f) x U : - measurable U -> - letin' k (ret mf) x U = k x (curry f ^~ x @^-1` U). -Proof. -move=> mU; rewrite letin'E. -under eq_integral do rewrite retE. -rewrite integral_indic ?setIT// -[X in measurable X]setTI. -exact: (measurableT_comp mf). -Qed. - -Lemma letin'_retk (f : X -> Y) (mf : measurable_fun setT f) - (k : R.-sfker Y * X ~> Z) x U : - measurable U -> letin' (ret mf) k x U = k (f x, x) U. -Proof. -move=> mU; rewrite letin'E retE integral_dirac ?diracT ?mul1e//. -exact: (measurableT_comp (measurable_kernel k _ mU)). -Qed. - -End letin'_return. - -Section letin'_ite. -Context d d2 d3 (T : measurableType d) (T2 : measurableType d2) - (Z : measurableType d3) (R : realType). -Variables (k1 k2 : R.-sfker T ~> Z) - (u : R.-sfker Z * T ~> T2) - (f : T -> bool) (mf : measurable_fun setT f) - (t : T) (U : set T2). - -Lemma letin'_iteT : f t -> letin' (ite mf k1 k2) u t U = letin' k1 u t U. -Proof. -move=> ftT. -rewrite !letin'E/=. -apply: eq_measure_integral => V mV _. -by rewrite iteE ftT. -Qed. - -Lemma letin'_iteF : ~~ f t -> letin' (ite mf k1 k2) u t U = letin' k2 u t U. -Proof. -move=> ftF. -rewrite !letin'E/=. -apply: eq_measure_integral => V mV _. -by rewrite iteE (negbTE ftF). -Qed. - -End letin'_ite. -(* /letin' versions of rewriting laws *) - Local Open Scope lang_scope. -Lemma execP_letinL {R : realType} g t1 t2 x (e1 : @exp R P g t1) (e1' : exp P g t1) - (e2 : exp P ((x, t1) :: g) t2) : - forall U, measurable U -> - execP e1 = execP e1' -> - execP [let x := e1 in e2] ^~ U = execP [let x := e1' in e2] ^~ U. -Proof. -by move=> U mU e1e1'; rewrite !execP_letin e1e1'. -Qed. - -Lemma execP_letinR {R : realType} g t1 t2 x (e1 : @exp R P g t1) - (e2 : exp P _ t2) (e2' : exp P ((x, t1) :: g) t2) : - forall U, measurable U -> - execP e2 = execP e2' -> - execP [let x := e1 in e2] ^~ U = execP [let x := e1 in e2'] ^~ U. -Proof. -by move=> U mU e1e1'; rewrite !execP_letin e1e1'. -Qed. - Local Close Scope lang_scope. (* simple tests to check bidirectional hints *) @@ -184,9 +113,9 @@ Import Notations. Context {R : realType}. Lemma exec_normalize_return g x r : - projT1 (@execD _ g _ [Normalize return r:R]) x = + projT1 (@execD _ g _ [Normalize return r:R]) x = @dirac _ (measurableTypeR R) r _ :> probability _ R. - (* TODO: try to use the notation \d_r *) + (* NB: \d_r notation? *) Proof. by rewrite execD_normalize_pt execP_return execD_real//=; exact: normalize_kdirac. Qed. @@ -199,16 +128,15 @@ Local Open Scope ring_scope. Import Notations. Context {R : realType}. -Definition sample_pair_syntax0 : @exp R _ [::] _ := - [let "x" := Sample {exp_bernoulli (1 / 2)%:nng (p1S 1)} in - let "y" := Sample {exp_bernoulli (1 / 3%:R)%:nng (p1S 2)} in +Definition sample_pair1213' : @exp R _ [::] _ := + [let "x" := Sample {exp_bernoulli [{1 / 2}:R]} in + let "y" := Sample {exp_bernoulli [{1 / 3}:R]} in return (#{"x"}, #{"y"})]. -Definition sample_pair_syntax : exp _ [::] _ := - [Normalize {sample_pair_syntax0}]. +Definition sample_pair1213 : exp _ [::] _ := [Normalize {sample_pair1213'}]. -Lemma exec_sample_pair0 (A : set (bool * bool)) : - @execP R [::] _ sample_pair_syntax0 tt A = +Lemma exec_sample_pair1213' (A : set (bool * bool)) : + @execP R [::] _ sample_pair1213' tt A = ((1 / 2)%:E * ((1 / 3)%:E * \d_(true, true) A + (1 - 1 / 3)%:E * \d_(true, false) A) + @@ -216,110 +144,116 @@ Lemma exec_sample_pair0 (A : set (bool * bool)) : ((1 / 3)%:E * \d_(false, true) A + (1 - 1 / 3)%:E * \d_(false, false) A))%E. Proof. -rewrite !execP_letin !execP_sample !execD_bernoulli execP_return /=. +rewrite !execP_letin !execP_sample !execD_bernoulli !execP_return /=. rewrite execD_pair !exp_var'E (execD_var_erefl "x") (execD_var_erefl "y") /=. -rewrite letin'E integral_measure_add//= !ge0_integral_mscale//= /onem. -rewrite !integral_dirac//= !diracT !mul1e. -rewrite !letin'E !integral_measure_add//= !ge0_integral_mscale//= /onem. -by rewrite !integral_dirac//= !diracT !mul1e. +rewrite !execD_real//=. +do 2 (rewrite letin'E/= integral_bernoulli//=; last lra). +by rewrite letin'E/= integral_bernoulli//=; lra. Qed. -Lemma exec_sample_pair0_TandT : - @execP R [::] _ sample_pair_syntax0 tt [set (true, true)] = (1 / 6)%:E. +Lemma exec_sample_pair1213'_TandT : + @execP R [::] _ sample_pair1213' tt [set (true, true)] = (1 / 6)%:E. Proof. -rewrite exec_sample_pair0 !diracE mem_set//; do 3 rewrite memNset//=. +rewrite exec_sample_pair1213' !diracE mem_set//; do 3 rewrite memNset//=. by rewrite /= !mule0 mule1 !add0e mule0 adde0; congr (_%:E); lra. Qed. -Lemma exec_sample_pair0_TandF : - @execP R [::] _ sample_pair_syntax0 tt [set (true, false)] = (1 / 3)%:E. +Lemma exec_sample_pair1213'_TandT' : + @execP R [::] _ sample_pair1213' tt [set p | p.1 && p.2] = (1 / 6)%:E. Proof. -rewrite exec_sample_pair0 !diracE memNset// mem_set//; do 2 rewrite memNset//. +rewrite exec_sample_pair1213' !diracE mem_set//; do 3 rewrite memNset//=. by rewrite /= !mule0 mule1 !add0e mule0 adde0; congr (_%:E); lra. Qed. -Lemma exec_sample_pair0_TandT' : - @execP R [::] _ sample_pair_syntax0 tt [set p | p.1 && p.2] = (1 / 6)%:E. +Lemma exec_sample_pair1213'_TandF : + @execP R [::] _ sample_pair1213' tt [set (true, false)] = (1 / 3)%:E. Proof. -rewrite exec_sample_pair0 !diracE mem_set//; do 3 rewrite memNset//=. +rewrite exec_sample_pair1213' !diracE memNset// mem_set//; do 2 rewrite memNset//. by rewrite /= !mule0 mule1 !add0e mule0 adde0; congr (_%:E); lra. Qed. -Lemma exec_sample_pair_TorT : - (projT1 (execD sample_pair_syntax)) tt [set p | p.1 || p.2] = (2 / 3)%:E. +Lemma exec_sample_pair1213_TorT : + (projT1 (execD sample_pair1213)) tt [set p | p.1 || p.2] = (2 / 3)%:E. Proof. -rewrite execD_normalize_pt normalizeE/= exec_sample_pair0. +rewrite execD_normalize_pt normalizeE/= exec_sample_pair1213'. rewrite !diracE; do 4 rewrite mem_set//=. rewrite eqe ifF; last by apply/negbTE/negP => /orP[/eqP|//]; lra. -rewrite exec_sample_pair0 !diracE; do 3 rewrite mem_set//; rewrite memNset//=. +rewrite exec_sample_pair1213' !diracE; do 3 rewrite mem_set//; rewrite memNset//=. by rewrite !mule1; congr (_%:E); field. Qed. -Definition sample_and_syntax0 : @exp R _ [::] _ := - [let "x" := Sample {exp_bernoulli (1 / 2)%:nng (p1S 1)} in - let "y" := Sample {exp_bernoulli (1 / 3%:R)%:nng (p1S 2)} in +End sample_pair. + +Section sample_and. +Local Open Scope lang_scope. +Local Open Scope ring_scope. +Import Notations. +Context {R : realType}. + +Definition sample_and1213' : @exp R _ [::] _ := + [let "x" := Sample {exp_bernoulli [{1 / 2}:R]} in + let "y" := Sample {exp_bernoulli [{1 / 3}:R]} in return #{"x"} && #{"y"}]. -Lemma exec_sample_and0 (A : set bool) : - @execP R [::] _ sample_and_syntax0 tt A = ((1 / 6)%:E * \d_true A + - (1 - 1 / 6)%:E * \d_false A)%E. -Proof. -rewrite !execP_letin !execP_sample !execD_bernoulli execP_return /=. -rewrite !(@execD_bin _ _ binop_and) !exp_var'E (execD_var_erefl "x") (execD_var_erefl "y") /=. -rewrite letin'E integral_measure_add//= !ge0_integral_mscale//= /onem. -rewrite !integral_dirac//= !diracT !mul1e. -rewrite !letin'E !integral_measure_add//= !ge0_integral_mscale//= /onem. -rewrite !integral_dirac//= !diracT !mul1e. +Lemma exec_sample_and1213' (A : set bool) : + @execP R [::] _ sample_and1213' tt A = ((1 / 6)%:E * \d_true A + + (1 - 1 / 6)%:E * \d_false A)%E. +Proof. +rewrite !execP_letin !execP_sample/= !execD_bernoulli execP_return /=. +rewrite !(@execD_bin _ _ binop_and) !exp_var'E (execD_var_erefl "x"). +rewrite (execD_var_erefl "y") /= !letin'E/= !execD_real/=. +rewrite integral_bernoulli//=; last lra. +rewrite !letin'E/= integral_bernoulli//=; last lra. +rewrite integral_bernoulli//=; last lra. +rewrite /onem. rewrite muleDr// -addeA; congr (_ + _)%E. by rewrite !muleA; congr (_%:E); congr (_ * _); field. rewrite -muleDl// !muleA -muleDl//. by congr (_%:E); congr (_ * _); field. Qed. -Definition sample_bernoulli_and3 : @exp R _ [::] _ := - [let "x" := Sample {exp_bernoulli (1 / 2)%:nng (p1S 1)} in - let "y" := Sample {exp_bernoulli (1 / 2)%:nng (p1S 1)} in - let "z" := Sample {exp_bernoulli (1 / 2)%:nng (p1S 1)} in +Definition sample_and121212 : @exp R _ [::] _ := + [let "x" := Sample {exp_bernoulli [{1 / 2}:R]} in + let "y" := Sample {exp_bernoulli [{1 / 2}:R]} in + let "z" := Sample {exp_bernoulli [{1 / 2}:R]} in return #{"x"} && #{"y"} && #{"z"}]. -Lemma exec_sample_bernoulli_and3 t U : - execP sample_bernoulli_and3 t U = ((1 / 8)%:E * \d_true U + - (1 - 1 / 8)%:E * \d_false U)%E. -Proof. -rewrite !execP_letin !execP_sample !execD_bernoulli execP_return /=. -rewrite !(@execD_bin _ _ binop_and) !exp_var'E. -rewrite (execD_var_erefl "x") (execD_var_erefl "y") (execD_var_erefl "z") /=. -rewrite letin'E integral_measure_add//= !ge0_integral_mscale//= /onem. -rewrite !integral_dirac//= !diracT !mul1e. -rewrite !letin'E !integral_measure_add//= !ge0_integral_mscale//= /onem. -rewrite !integral_dirac//= !diracT !mul1e. -rewrite !letin'E !integral_measure_add//= !ge0_integral_mscale//= /onem. -rewrite !integral_dirac//= !diracT !mul1e. -rewrite !muleDr// -!addeA. -by congr (_ + _)%E; rewrite ?addeA !muleA -?muleDl//; -congr (_ * _)%E; congr (_%:E); field. +Lemma exec_sample_and121212 t U : + execP sample_and121212 t U = ((1 / 8)%:E * \d_true U + + (1 - 1 / 8)%:E * \d_false U)%E. +Proof. +rewrite !execP_letin !execP_sample !execD_bernoulli !execP_return /=. +rewrite !(@execD_bin _ _ binop_and) !exp_var'E (execD_var_erefl "x"). +rewrite (execD_var_erefl "y") (execD_var_erefl "z") /= !execD_real/=. +do 3 (rewrite !letin'E/= integral_bernoulli//=; last lra). +do 2 (rewrite integral_bernoulli//=; last lra). +rewrite !letin'E/= integral_bernoulli//=; last lra. +rewrite !muleDr// -!addeA; congr (_ + _)%E. + by rewrite !muleA; congr *%E; congr EFin; field. +rewrite !muleA -!muleDl//; congr *%E; congr EFin. +by rewrite /onem; field. Qed. -End sample_pair. +End sample_and. -Section bernoulli_examples. +Section sample_score. Local Open Scope ring_scope. Local Open Scope lang_scope. Import Notations. Context {R : realType}. Definition bernoulli13_score := [Normalize - let "x" := Sample {@exp_bernoulli R [::] (1 / 3%:R)%:nng (p1S 2)} in - let "_" := if #{"x"} then Score {(1 / 3)}:R else Score {(2 / 3)}:R in + let "x" := Sample {@exp_bernoulli R [::] [{1 / 3}:R]} in + let "_" := if #{"x"} then Score {1 / 3}:R else Score {2 / 3}:R in return #{"x"}]. Lemma exec_bernoulli13_score : - execD bernoulli13_score = execD (exp_bernoulli (1 / 5%:R)%:nng (p1S 4)). + execD bernoulli13_score = execD (exp_bernoulli [{1 / 5}:R]). Proof. apply: eq_execD. rewrite execD_bernoulli/= /bernoulli13_score execD_normalize_pt 2!execP_letin. rewrite execP_sample/= execD_bernoulli/= execP_if /= exp_var'E. -rewrite (execD_var_erefl "x")/= !execP_return/= 2!execP_score 2!execD_real/=. +rewrite (execD_var_erefl "x")/= !execP_return/= 2!execP_score !execD_real/=. apply: funext=> g; apply: eq_probability => U. rewrite normalizeE !letin'E/=. under eq_integral. @@ -327,41 +261,40 @@ under eq_integral. rewrite !letin'E. under eq_integral do rewrite retE /=. over. -rewrite !integral_measure_add //=; last by move=> b _; rewrite integral_ge0. -rewrite !ge0_integral_mscale //=; last 2 first. - by move=> b _; rewrite integral_ge0. - by move=> b _; rewrite integral_ge0. -rewrite !integral_dirac// !diracT !mul1e. +rewrite /=. +rewrite integral_bernoulli//=; [|lra|by move=> b; rewrite integral_ge0]. rewrite iteE/= !ge0_integral_mscale//=. rewrite ger0_norm//. rewrite !integral_indic//= !iteE/= /mscale/=. rewrite setTI !diracT !mule1. rewrite ger0_norm//. rewrite -EFinD/= eqe ifF; last first. - apply/negbTE/negP => /orP[/eqP|//]; rewrite /onem. lra. + by apply/negbTE/negP => /orP[/eqP|//]; rewrite /onem; lra. +rewrite integral_bernoulli//=; last lra. rewrite !letin'E/= !iteE/=. rewrite !ge0_integral_mscale//=. rewrite ger0_norm//. rewrite !integral_dirac//= !diracT !mul1e ger0_norm//. rewrite exp_var'E (execD_var_erefl "x")/=. -rewrite /bernoulli/= measure_addE/= /mscale/= !mul1r. +rewrite !indicT/= !mulr1. +rewrite bernoulliE_ext//=; last lra. by rewrite muleDl//; congr (_ + _)%E; rewrite -!EFinM; congr (_%:E); - rewrite !indicT !indicE /onem /=; case: (_ \in _); field. + rewrite !indicE /onem /=; case: (_ \in _); field. Qed. Definition bernoulli12_score := [Normalize - let "x" := Sample {@exp_bernoulli R [::] (1 / 2)%:nng (p1S 1)} in - let "r" := if #{"x"} then Score {(1 / 3)}:R else Score {(2 / 3)}:R in + let "x" := Sample {@exp_bernoulli R [::] [{1 / 2}:R]} in + let "r" := if #{"x"} then Score {1 / 3}:R else Score {2 / 3}:R in return #{"x"}]. Lemma exec_bernoulli12_score : - execD bernoulli12_score = execD (exp_bernoulli (1 / 3%:R)%:nng (p1S 2)). + execD bernoulli12_score = execD (exp_bernoulli [{1 / 3}:R]). Proof. apply: eq_execD. rewrite execD_bernoulli/= /bernoulli12_score execD_normalize_pt 2!execP_letin. rewrite execP_sample/= execD_bernoulli/= execP_if /= exp_var'E. -rewrite (execD_var_erefl "x")/= !execP_return/= 2!execP_score 2!execD_real/=. +rewrite (execD_var_erefl "x")/= !execP_return/= 2!execP_score !execD_real/=. apply: funext=> g; apply: eq_probability => U. rewrite normalizeE !letin'E/=. under eq_integral. @@ -369,11 +302,7 @@ under eq_integral. rewrite !letin'E. under eq_integral do rewrite retE /=. over. -rewrite !integral_measure_add //=; last by move=> b _; rewrite integral_ge0. -rewrite !ge0_integral_mscale //=; last 2 first. - by move=> b _; rewrite integral_ge0. - by move=> b _; rewrite integral_ge0. -rewrite !integral_dirac// !diracT !mul1e. +rewrite /= integral_bernoulli//=; [|lra|by move=> b; rewrite integral_ge0]. rewrite iteE/= !ge0_integral_mscale//=. rewrite ger0_norm//. rewrite !integral_indic//= !iteE/= /mscale/=. @@ -382,12 +311,14 @@ rewrite ger0_norm//. rewrite -EFinD/= eqe ifF; last first. apply/negbTE/negP => /orP[/eqP|//]. by rewrite /onem; lra. +rewrite integral_bernoulli//=; last lra. rewrite !letin'E/= !iteE/=. rewrite !ge0_integral_mscale//=. rewrite ger0_norm//. rewrite !integral_dirac//= !diracT !mul1e ger0_norm//. rewrite exp_var'E (execD_var_erefl "x")/=. -rewrite /bernoulli/= measure_addE/= /mscale/= !mul1r. +rewrite bernoulliE_ext//=; last lra. +rewrite !mul1r. rewrite muleDl//; congr (_ + _)%E; rewrite -!EFinM; congr (_%:E); @@ -396,20 +327,17 @@ Qed. (* https://dl.acm.org/doi/pdf/10.1145/2933575.2935313 (Sect. 4) *) Definition bernoulli14_score := [Normalize - let "x" := Sample {@exp_bernoulli R [::] (1 / 4%:R)%:nng (p1S 3)} in + let "x" := Sample {@exp_bernoulli R [::] [{1 / 4}:R]} in let "r" := if #{"x"} then Score {5}:R else Score {2}:R in return #{"x"}]. -Let p511 : ((5%:R / 11%:R)%:nng%:num <= (1 : R)). -Proof. by rewrite /=; lra. Qed. - Lemma exec_bernoulli14_score : - execD bernoulli14_score = execD (exp_bernoulli (5%:R / 11%:R)%:nng p511). + execD bernoulli14_score = execD (exp_bernoulli [{5%:R / 11%:R}:R]). Proof. apply: eq_execD. rewrite execD_bernoulli/= execD_normalize_pt 2!execP_letin. rewrite execP_sample/= execD_bernoulli/= execP_if /= !exp_var'E. -rewrite !execP_return/= 2!execP_score 2!execD_real/=. +rewrite !execP_return/= 2!execP_score !execD_real/=. rewrite !(execD_var_erefl "x")/=. apply: funext=> g; apply: eq_probability => U. rewrite normalizeE !letin'E/=. @@ -418,39 +346,37 @@ under eq_integral. rewrite !letin'E. under eq_integral do rewrite retE /=. over. -rewrite !integral_measure_add //=; last by move=> b _; rewrite integral_ge0. -rewrite !ge0_integral_mscale //=; last 2 first. - by move=> b _; exact: integral_ge0. - by move=> b _; exact: integral_ge0. -rewrite !integral_dirac// !diracT !mul1e. +rewrite /= integral_bernoulli//=; [|lra|by move=> b; rewrite integral_ge0]. rewrite iteE/= !ge0_integral_mscale//=. rewrite ger0_norm//. rewrite !integral_cst//= !diracT !(mule1,mul1e). rewrite !iteE/= /mscale/= !diracT !mule1. rewrite ger0_norm//. +rewrite !indicT/= !mul1r. rewrite -EFinD/= eqe ifF; last first. apply/negbTE/negP => /orP[/eqP|//]. by rewrite /onem; lra. +rewrite integral_bernoulli//=; last lra. rewrite !letin'E/= !iteE/=. rewrite !ge0_integral_mscale//=. rewrite ger0_norm//. rewrite !integral_dirac//= !diracT !mul1e ger0_norm//. -rewrite /bernoulli/= measure_addE/= /mscale/= !mul1r. +rewrite bernoulliE_ext//=; last lra. rewrite muleDl//; congr (_ + _)%E; rewrite -!EFinM; congr (_%:E); - by rewrite !indicT !indicE /onem /=; case: (_ \in _); field. + by rewrite !indicE /onem /=; case: (_ \in _); field. Qed. -End bernoulli_examples. +End sample_score. -Section binomial_examples. +Section sample_binomial. Context {R : realType}. Open Scope lang_scope. Open Scope ring_scope. Definition sample_binomial3 : @exp R _ [::] _ := - [let "x" := Sample {exp_binomial 3 (1 / 2)%:nng (p1S 1)} in + [let "x" := Sample {exp_binomial 3 [{1 / 2}:R]} in return #{"x"}]. Lemma exec_sample_binomial3 t U : measurable U -> @@ -460,46 +386,19 @@ Lemma exec_sample_binomial3 t U : measurable U -> (1 / 8)%:E * \d_3%N U)%E. Proof. move=> mU; rewrite /sample_binomial3 execP_letin execP_sample execP_return. -rewrite exp_var'E (execD_var_erefl "x") !execD_binomial/=. -rewrite letin'E ge0_integral_measure_sum//=. -rewrite !big_ord_recl big_ord0 !ge0_integral_mscale//=; [|exact: measurable_fun_dirac..]. -rewrite !integral_dirac// /bump; [|exact: measurable_fun_dirac..]. +rewrite exp_var'E (execD_var_erefl "x") !execD_binomial/= execD_real//=. +rewrite letin'E/= /= integral_binomial//=; [lra|move=> _]. +rewrite !big_ord_recl big_ord0/=. +rewrite /bump. rewrite !binS/= !bin0 bin1 bin2 bin_small// addn0. rewrite expr0 mulr1 mul1r subn0. rewrite -2!addeA !mul1r. congr _%:E. -rewrite indicT !mul1r /onem !addrA addr0 expr1/=. +rewrite !indicE /onem !addrA addr0 expr1/=. by congr (_ + _ + _ + _); congr (_ * _); field. Qed. -End binomial_examples. - -Section hard_constraint'. -Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). - -Definition fail' := - letin' (score (@measurable_cst _ _ X _ setT (0%R : R))) - (ret (@measurable_cst _ _ _ Y setT point)). - -Lemma fail'E x U : fail' x U = 0. -Proof. by rewrite /fail' letin'E ge0_integral_mscale//= normr0 mul0e. Qed. - -End hard_constraint'. -Arguments fail' {d d' X Y R}. - -(* hard constraints to express score below 1 *) -Lemma score_fail' d (X : measurableType d) {R : realType} - (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : - score (kr r%:num) = - letin' (sample_cst (bernoulli r1) : R.-pker X ~> _) - (ite macc0of2 (ret ktt) fail'). -Proof. -apply/eq_sfkernel => x U. -rewrite letin'E/= /sample; unlock. -rewrite integral_measure_add//= ge0_integral_mscale//= ge0_integral_mscale//=. -rewrite !integral_dirac//= !diracT/= !mul1e. -by rewrite /mscale/= iteE//= iteE//= fail'E mule0 adde0 ger0_norm. -Qed. +End sample_binomial. Section hard_constraint. Local Open Scope ring_scope. @@ -518,18 +417,20 @@ rewrite letin'E integral_indic//= /mscale/= normr0 mul0e. by rewrite /fail' letin'E/= ge0_integral_mscale//= normr0 mul0e. Qed. -Lemma exec_score_fail (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : - execP (g := [::]) [Score {r%:num}:R] = - execP [let str := Sample {exp_bernoulli r r1} in +Lemma exec_score_fail (r : R) (r01 : (0 <= r <= 1)%R) : + execP (g := [::]) [Score {r}:R] = + execP [let str := Sample {exp_bernoulli [{r}:R]} in if #str then return TT else {hard_constraint _}]. Proof. -rewrite execP_score execD_real /= score_fail'. +move: r01 => /andP[r0 r1]//. +rewrite execP_score execD_real /= score_fail' ?r0 ?r1//. rewrite execP_letin execP_sample/= execD_bernoulli execP_if execP_return. rewrite execD_unit/= exp_var'E /=. - apply/ctx_prf_head. + exact/ctx_prf_head (* TODO *). move=> h. apply: eq_sfkernel=> /= -[] U. -rewrite 2!letin'E/=. +rewrite [LHS]letin'E/= [RHS]letin'E/=. +rewrite execD_real/=. apply: eq_integral => b _. rewrite 2!iteE//=. case: b => //=. @@ -546,6 +447,217 @@ Qed. End hard_constraint. +Section test_uniform. +Local Open Scope ring_scope. +Local Open Scope lang_scope. +Context (R : realType). + +Definition uniform_syntax : @exp R _ [::] _ := + [let "p" := Sample {exp_uniform 0 1 (@ltr01 R)} in + return #{"p"}]. + +Lemma exec_uniform_syntax t U : measurable U -> + execP uniform_syntax t U = uniform_prob (@ltr01 R) U. +Proof. +move=> mU. +rewrite /uniform_syntax execP_letin execP_sample execP_return !execD_uniform. +rewrite exp_var'E (execD_var_erefl "p")/=. +rewrite letin'E /=. +rewrite integral_uniform//=; last exact: measurable_fun_dirac. +rewrite subr0 invr1 mul1e. +rewrite {1}/uniform_prob. +rewrite integral_mkcond//=. +rewrite [in RHS]integral_mkcond//=. +apply: eq_integral => x _. +rewrite !patchE. +case: ifPn => //; case: ifPn => //. +- move=> xU. + rewrite inE/= in_itv/= => x01. + by rewrite /uniform_pdf x01 diracE xU subr0 invr1. +- by rewrite diracE => /negbTE ->. +- move=> xU. + rewrite notin_setE/= in_itv/= => /negP/negbTE x01. + by rewrite /uniform_pdf x01. +Qed. + +End test_uniform. + +Section guard. +Local Open Scope ring_scope. +Local Open Scope lang_scope. +Context (R : realType). + +Definition guard : @exp R _ [::] _ := [ + let "p" := Sample {exp_bernoulli [{1 / 3}:R]} in + let "_" := if #{"p"} then return TT else Score {0}:R in + return #{"p"} +]. + +Lemma exec_guard t U : execP guard t U = ((1 / 3)%:E * \d_true U)%E. +Proof. +rewrite /guard 2!execP_letin execP_sample execD_bernoulli execD_real. +rewrite execP_if/= !execP_return !exp_var'E !(execD_var_erefl "p") execD_unit. +rewrite execP_score execD_real/=. +rewrite letin'E/= integral_bernoulli//=; last lra. +rewrite !letin'E !iteE/= integral_dirac// ge0_integral_mscale//=. +by rewrite normr0 mul0e !mule0 !adde0 !diracT !mul1e. +Qed. + +End guard. + +Section test_binomial. +Local Open Scope ring_scope. +Local Open Scope lang_scope. +Context (R : realType). + +Definition binomial_le : @exp R _ [::] Bool := + [let "a2" := Sample {exp_binomial 3 [{1 / 2}:R]} in + return {1}:N <= #{"a2"}]. + +Lemma exec_binomial_le t U : + execP binomial_le t U = ((7 / 8)%:E * \d_true U + + (1 / 8)%:E * \d_false U)%E. +Proof. +rewrite /binomial_le execP_letin execP_sample execP_return execD_rel execD_nat. +rewrite exp_var'E (execD_var_erefl "a2") execD_binomial/= !execD_real/=. +rewrite letin'E//= integral_binomial//=; [lra|move=> _]. +rewrite !big_ord_recl big_ord0//=. +rewrite /bump. +rewrite !binS/= !bin0 bin1 bin2 bin_small// addn0. +rewrite addeC adde0. +congr (_ + _)%:E. + rewrite !indicE !(mul0n,add0n,lt0n,mul1r)/=. + rewrite -!mulrDl; congr (_ * _). + rewrite /onem. + lra. +rewrite !expr0 ltnn indicE/= !(mul1r,mul1e) /onem. +lra. +Qed. + +Definition binomial_guard : @exp R _ [::] Nat := + [let "a1" := Sample {exp_binomial 3 [{1 / 2}:R]} in + let "_" := if #{"a1"} == {1}:N then return TT else Score {0}:R in + return #{"a1"}]. + +Lemma exec_binomial_guard t U : + execP binomial_guard t U = ((3 / 8)%:E * \d_1%N U)%E. +Proof. +rewrite /binomial_guard !execP_letin execP_sample execP_return execP_if. +rewrite !exp_var'E execD_rel !(execD_var_erefl "a1") execP_return. +rewrite execD_unit execD_binomial execD_nat execP_score !execD_real. +rewrite !letin'E//=. +rewrite integral_binomial//=; [lra|move=> _]. +rewrite !big_ord_recl big_ord0. +rewrite /bump/=. +rewrite !binS/= !bin0 bin1 bin2 bin_small//. +rewrite !letin'E//= !iteE/=. +rewrite !ge0_integral_mscale//=. +rewrite !integral_dirac//= !diracE/=. +rewrite /bump/=. +rewrite !(normr0,mul0e,mule0,add0e,add0n,mul1e,adde0). +rewrite mem_set//=. +rewrite /onem mul1e. +congr (_%:E * _)%E. +lra. +Qed. + +End test_binomial. + +Section test_beta. +Local Open Scope ring_scope. +Local Open Scope lang_scope. +Context (R : realType). +Local Notation mu := (@lebesgue_measure R). + +Lemma integral_beta_nat_bernoulli_lty a b U : + (\int[beta_nat a b]_x `|bernoulli (x : R) U| < +oo)%E. +Proof. +apply: (@le_lt_trans _ _ (\int[beta_nat a b]_x cst 1 x))%E. + apply: ge0_le_integral => //=. + by apply: measurableT_comp => //=; exact: measurable_bernoulli2. + by move=> x _; rewrite gee0_abs// probability_le1. +rewrite integral_cst//= mul1e. +by rewrite -ge0_fin_numE// beta_nat_fin_num. +Qed. + +Lemma integrable_bernoulli_ubeta_nat_pdf a b U + (mu : {measure set (salgebraType (R.-ocitv.-measurable)) -> \bar R}) : + measurable U -> (mu `[0%R, 1%R]%classic < +oo)%E -> + mu.-integrable `[0, 1] (fun x => bernoulli (ubeta_nat_pdf a b x) U). +Proof. +move=> mU mu01oo. +apply/integrableP; split. + apply: (measurableT_comp (measurable_bernoulli2 _)) => //=. + by apply: measurable_funTS; exact: measurable_ubeta_nat_pdf. +apply: (@le_lt_trans _ _ (\int[mu]_(x in `[0%R, 1%R]) cst 1 x)%E). + apply: ge0_le_integral => //=. + apply/measurable_funTS/measurableT_comp => //=. + apply: (measurableT_comp (measurable_bernoulli2 _)) => //=. + exact: measurable_ubeta_nat_pdf. + by move=> x _; rewrite gee0_abs// probability_le1. +by rewrite integral_cst//= mul1e. +Qed. + +Lemma beta_bernoulli_bernoulli U : measurable U -> + @execP R [::] _ [let "p" := Sample {exp_beta 6 4} in + Sample {exp_bernoulli [#{"p"}]}] tt U = + @execP R [::] _ [Sample {exp_bernoulli [{3 / 5}:R]}] tt U. +Proof. +move=> mU. +rewrite execP_letin !execP_sample execD_beta_nat !execD_bernoulli/=. +rewrite !execD_real/= exp_var'E (execD_var_erefl "p")/=. +transitivity (beta_nat_bernoulli 6 4 1 0 U : \bar R). + rewrite /beta_nat_bernoulli !letin'E/=. + rewrite integral_beta_nat//=; last 2 first. + exact: measurable_bernoulli2. + exact: integral_beta_nat_bernoulli_lty. + rewrite integral_beta_nat//=; last 2 first. + apply: measurable_funTS => /=. + apply: (measurableT_comp (measurable_bernoulli2 _)) => //=. + exact: measurable_ubeta_nat_pdf. + rewrite integral_beta_nat//=. + + suff: mu.-integrable `[0%R, 1%R] + (fun x => (bernoulli (ubeta_nat_pdf 2 1 x) U * (beta_nat_pdf 6 4 x)%:E))%E. + move=> /integrableP[_]. + under eq_integral. + move=> x _. + rewrite gee0_abs//; last first. + by rewrite mule_ge0// lee_fin beta_nat_pdf_ge0. + over. + move=> ?. + by under eq_integral do rewrite gee0_abs//. + + apply: integrableMl => //=. + * apply: integrable_bernoulli_ubeta_nat_pdf => //=. + by rewrite lebesgue_measure_itv//= lte01 EFinN sube0 ltry. + * by apply: measurable_funTS; exact: measurable_beta_nat_pdf. + * exact: bounded_beta_nat_pdf_01. + + apply: measurable_funTS => /=; apply/measurableT_comp => //. + apply: (measurableT_comp (measurable_bernoulli2 _)) => //=. + exact: measurable_ubeta_nat_pdf. + + under eq_integral do rewrite gee0_abs//=. + have : (beta_nat 6 4 `[0%R, 1%R]%classic < +oo :> \bar R)%E. + by rewrite -ge0_fin_numE// beta_nat_fin_num. + move=> /(@integrable_bernoulli_ubeta_nat_pdf 2 1 _ (beta_nat 6 4) mU). + by move=> /integrableP[]. + rewrite [RHS]integral_mkcond. + apply: eq_integral => x _ /=. + rewrite patchE. + rewrite /beta_nat_pdf /ubeta_nat_pdf. + case: ifPn => [/andP[x0 x1]|]. + rewrite ifT; last by rewrite inE/= in_itv/= x0. + by rewrite expr0 expr1 mulr1. + rewrite !mul0r !mule0. + by case: ifPn. +rewrite beta_nat_bernE// !bernoulliE_ext//=; last 2 first. + lra. + by rewrite div_beta_nat_norm_ge0 div_beta_nat_norm_le1. +congr (_ * _ + _ * _)%:E. + by rewrite /div_beta_nat_norm/= !beta_nat_normE/= !factE/=; field. +by rewrite /onem /div_beta_nat_norm !beta_nat_normE/= !factE/=; field. +Qed. + +End test_beta. + Section letinA. Local Open Scope lang_scope. Variable R : realType. @@ -594,20 +706,21 @@ Import Notations. Context {R : realType}. Definition staton_bus_syntax0 : @exp R _ [::] _ := - [let "x" := Sample {exp_bernoulli (2 / 7%:R)%:nng p27} in + [let "x" := Sample {exp_bernoulli [{2 / 7}:R]} in let "r" := if #{"x"} then return {3}:R else return {10}:R in let "_" := Score {exp_poisson 4 [#{"r"}]} in return #{"x"}]. Definition staton_bus_syntax := [Normalize {staton_bus_syntax0}]. -Let sample_bern : R.-sfker munit ~> mbool := sample_cst (bernoulli p27). +Let sample_bern : R.-sfker munit ~> mbool := + sample _ (measurableT_comp measurable_bernoulli (measurable_cst (2 / 7 : R)%R)). Let ite_3_10 : R.-sfker mbool * munit ~> measurableTypeR R := ite macc0of2 (@ret _ _ _ (measurableTypeR R) R _ (kr 3)) (@ret _ _ _ (measurableTypeR R) R _ (kr 10)). Let score_poisson4 : R.-sfker measurableTypeR R * (mbool * munit) ~> munit := - score (measurableT_comp (measurable_poisson 4) (@macc0of2 _ _ (measurableTypeR R) _)). + score (measurableT_comp (measurable_poisson_pdf 4) (@macc0of2 _ _ (measurableTypeR R) _)). Let kstaton_bus' := letin' sample_bern @@ -616,7 +729,10 @@ Let kstaton_bus' := Lemma eval_staton_bus0 : staton_bus_syntax0 -P> kstaton_bus'. Proof. -apply: eval_letin; first by apply: eval_sample; exact: eval_bernoulli. +apply: eval_letin. + apply: eval_sample. + apply: eval_bernoulli. + exact: eval_real. apply: eval_letin. apply/evalP_if; [|exact/eval_return/eval_real..]. rewrite exp_var'E. @@ -631,7 +747,7 @@ Qed. Lemma exec_staton_bus0' : execP staton_bus_syntax0 = kstaton_bus'. Proof. -rewrite 3!execP_letin execP_sample/= execD_bernoulli. +rewrite 3!execP_letin execP_sample/= execD_bernoulli/= !execD_real. rewrite /kstaton_bus'; congr letin'. rewrite !execP_if !execP_return !execD_real/=. rewrite exp_var'E (execD_var_erefl "x")/=. @@ -648,7 +764,7 @@ Lemma exec_staton_bus : execD staton_bus_syntax = existT _ (normalize_pt kstaton_bus') (measurable_normalize_pt _). Proof. by rewrite execD_normalize_pt exec_staton_bus0'. Qed. -Let poisson4 := @poisson R 4%N. +Let poisson4 := @poisson_pdf R 4%N. Let staton_bus_probability U := ((2 / 7)%:E * (poisson4 3)%:E * \d_true U + @@ -658,19 +774,21 @@ Lemma exec_staton_bus0 (U : set bool) : execP staton_bus_syntax0 tt U = staton_bus_probability U. Proof. rewrite exec_staton_bus0' /staton_bus_probability /kstaton_bus'. -rewrite letin'_sample_bernoulli. +rewrite /sample_bern. +rewrite letin'E/=. +rewrite integral_bernoulli//=; last lra. rewrite -!muleA; congr (_ * _ + _ * _)%E. - rewrite letin'_iteT//. rewrite letin'_retk//. rewrite letin'_kret//. rewrite /score_poisson4. - by rewrite /score/= /mscale/= ger0_norm//= poisson_ge0. + by rewrite /score/= /mscale/= ger0_norm//= poisson_pdf_ge0. - by rewrite onem27. - rewrite letin'_iteF//. rewrite letin'_retk//. rewrite letin'_kret//. rewrite /score_poisson4. - by rewrite /score/= /mscale/= ger0_norm//= poisson_ge0. + by rewrite /score/= /mscale/= ger0_norm//= poisson_pdf_ge0. Qed. End staton_bus. @@ -683,7 +801,7 @@ Import Notations. Context {R : realType}. Definition staton_busA_syntax0 : @exp R _ [::] _ := - [let "x" := Sample {exp_bernoulli (2 / 7%:R)%:nng p27} in + [let "x" := Sample {exp_bernoulli [{2 / 7}:R]} in let "_" := let "r" := if #{"x"} then return {3}:R else return {10}:R in Score {exp_poisson 4 [#{"r"}]} in @@ -692,13 +810,14 @@ Definition staton_busA_syntax0 : @exp R _ [::] _ := Definition staton_busA_syntax : exp _ [::] _ := [Normalize {staton_busA_syntax0}]. -Let sample_bern : R.-sfker munit ~> mbool := sample_cst (bernoulli p27). +Let sample_bern : R.-sfker munit ~> mbool := + sample _ (measurableT_comp measurable_bernoulli (measurable_cst (2 / 7 : R)%R)). Let ite_3_10 : R.-sfker mbool * munit ~> measurableTypeR R := ite macc0of2 (@ret _ _ _ (measurableTypeR R) R _ (kr 3)) (@ret _ _ _ (measurableTypeR R) R _ (kr 10)). Let score_poisson4 : R.-sfker measurableTypeR R * (mbool * munit) ~> munit := - score (measurableT_comp (measurable_poisson 4) (@macc0of3' _ _ _ (measurableTypeR R) _ _)). + score (measurableT_comp (measurable_poisson_pdf 4) (@macc0of3' _ _ _ (measurableTypeR R) _ _)). (* same as kstaton_bus _ (measurable_poisson 4) but expressed with letin' instead of letin *) @@ -709,19 +828,10 @@ Let kstaton_busA' := score_poisson4) (ret macc1of3')). -(*Lemma kstaton_busA'E : kstaton_busA' = kstaton_bus _ (measurable_poisson 4). -Proof. -apply/eq_sfkernel => -[] U. -rewrite /kstaton_busA' /kstaton_bus. -rewrite letin'_letin. -rewrite /sample_bern. -congr (letin _ _ tt U). -rewrite 2!letin'_letin/=. -Abort.*) - Lemma eval_staton_busA0 : staton_busA_syntax0 -P> kstaton_busA'. Proof. -apply: eval_letin; first by apply: eval_sample; exact: eval_bernoulli. +apply: eval_letin. + by apply: eval_sample; apply: eval_bernoulli; exact: eval_real. apply: eval_letin. apply: eval_letin. apply/evalP_if; [|exact/eval_return/eval_real..]. @@ -736,7 +846,7 @@ Qed. Lemma exec_staton_busA0' : execP staton_busA_syntax0 = kstaton_busA'. Proof. -rewrite 3!execP_letin execP_sample/= execD_bernoulli. +rewrite 3!execP_letin execP_sample/= execD_bernoulli execD_real. rewrite /kstaton_busA'; congr letin'. rewrite !execP_if !execP_return !execD_real/=. rewrite exp_var'E (execD_var_erefl "x")/=. @@ -783,7 +893,7 @@ rewrite execP_return exp_var'E/= (execD_var_erefl "x") //=. by apply/eq_sfkernel => /= -[[] [a [b []]]] U0. Qed. -Let poisson4 := @poisson R 4%N. +Let poisson4 := @poisson_pdf R 4%N. Lemma exec_staton_busA0 U : execP staton_busA_syntax0 tt U = ((2 / 7%:R)%:E * (poisson4 3%:R)%:E * \d_true U + @@ -796,8 +906,6 @@ Section letinC. Local Open Scope lang_scope. Variable (R : realType). -Require Import Classical_Prop. (* TODO: mv *) - Let weak_head g {t1 t2} x (e : @exp R P g t2) (xg : x \notin dom g) := exp_weak P [::] _ (x, t1) e xg. diff --git a/theories/lang_syntax_examples_wip.v b/theories/lang_syntax_examples_wip.v deleted file mode 100644 index 475897e7d..000000000 --- a/theories/lang_syntax_examples_wip.v +++ /dev/null @@ -1,694 +0,0 @@ -Require Import String. -From HB Require Import structures. -From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval. -From mathcomp.classical Require Import mathcomp_extra boolp classical_sets. -From mathcomp.classical Require Import functions cardinality fsbigop. -Require Import signed reals ereal topology normedtype sequences esum measure. -Require Import charge lebesgue_measure numfun lebesgue_integral kernel. -Require Import prob_lang lang_syntax_util lang_syntax lang_syntax_examples. -From mathcomp Require Import ring lra. - -(******************************************************************************) -(* Casino example *) -(* some steps *) - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Import Order.TTheory GRing.Theory Num.Def Num.Theory. -Import numFieldTopology.Exports. - -Local Open Scope classical_set_scope. -Local Open Scope ring_scope. -(* Local Open Scope ereal_scope. *) - -Section beta_example. -Open Scope ring_scope. -Open Scope lang_scope. -Context {R : realType}. - -Lemma beta_bern610 : - @execP R [::] _ - [let "p" := - Sample {exp_beta 6 4} in Sample {exp_bernoulli_trunc [#{"p"}]}] = - execP [Sample {exp_bernoulli_trunc [{6 / 10}:R]}]. -Proof. -rewrite execP_letin !execP_sample !execD_beta_nat !execD_bernoulli_trunc/=. -rewrite execD_real exp_var'E !(execD_var_erefl "p")/=. -apply: eq_sfkernel=> x U. -rewrite letin'E/=. -transitivity ((\int[beta_nat 6 4]_(y in `[0%R, 1%R]) bernoulli_trunc y U)%E : \bar R). - rewrite [in RHS]integral_mkcond /=. - apply: eq_integral => y _. - rewrite patchE. - case: ifPn => //. - (* Unset Printing Notations. *) - simpl in *. - rewrite mem_setE /= in_itv /= negb_and -!ltNge => /orP[y0|y1]; - rewrite /bernoulli_trunc/=. - case: sumbool_ler. - move=> a. - by rewrite ltNge a in y0. - rewrite /prob_lang.bernoulli0 /bernoulli => _. - rewrite [LHS]measure_addE/= /mscale/=. - (* match default value *) - admit. - admit. - rewrite integral_beta_nat. -under eq_integral => y y01. - rewrite bernoulli_truncE. - rewrite muleC muleDr// !muleA muleC [X in _ + X]muleC. - over. - admit. -rewrite /= bernoulli_truncE. -rewrite integralD//. -congr (_ + _)%E. -rewrite integralZl//. -rewrite muleC. -congr (_ * _)%E. -(* rewrite /= setTI. *) -rewrite /beta_nat_pdf. -rewrite /ubeta_nat_pdf/ubeta_nat_pdf'/=. -transitivity (\int[@lebesgue_measure R]_(x0 in `[0%R, 1%R]) - ((ubeta_nat_pdf 7 4 x0 / beta_nat_norm 6 4)%:E))%E. - apply: eq_integral => p _. - rewrite muleC -EFinM. - rewrite -[X in X * _]divr1 mulf_div. - congr (_ / _)%:E; last by rewrite mul1r. - by rewrite /ubeta_nat_pdf/= /ubeta_nat_pdf' mulrA -exprS. -under eq_integral do rewrite mulrC EFinM. -rewrite integralZl//=. -rewrite -beta_nat_normE /beta_nat_norm/= factE. -rewrite -!EFinM/=. -congr _%:E; lra. - admit. - admit. -rewrite integralZl//. -rewrite muleC. -congr (_ * _)%E. -rewrite /beta_nat_pdf. -rewrite /ubeta_nat_pdf/ubeta_nat_pdf'/=. -transitivity (\int[@lebesgue_measure R]_(x0 in `[0%R, 1%R]) - ((ubeta_nat_pdf 6 5 x0 / beta_nat_norm 6 4)%:E))%E. - apply: eq_integral => p _. - by rewrite mulrC -EFinM -2!mulrA -exprSr mulrC. -under eq_integral do rewrite mulrC EFinM. -rewrite integralZl//=. -rewrite -beta_nat_normE /beta_nat_norm/= factE. -rewrite -!EFinM/onem/=. -congr _%:E; lra. - admit. - admit. - admit. - admit. - lra. -Admitted. - -End beta_example. - -Section casino_example. -Open Scope ring_scope. -Open Scope lang_scope. -Context (R : realType). -Lemma a01 : 0 < 1 - 0 :> R. Proof. by []. Qed. - -(* guard test *) -Definition test_guard : @exp R _ [::] _ := [ - let "p" := Sample {exp_bernoulli (1 / 3)%:nng (p1S 2)} in - let "_" := if #{"p"} then return TT else Score {0}:R in - return #{"p"} -]. - -Lemma exec_guard t U : execP test_guard t U = ((1 / 3)%:E * \d_true U)%E. -Proof. -rewrite /test_guard 2!execP_letin execP_sample execD_bernoulli execP_if/=. -rewrite !execP_return !exp_var'E !(execD_var_erefl "p") execD_unit execP_score execD_real/=. -rewrite letin'E ge0_integral_measure_sum//. -rewrite !big_ord_recl big_ord0 !ge0_integral_mscale//= !integral_dirac//. -rewrite !letin'E !iteE/= integral_dirac// ge0_integral_mscale//=. -by rewrite normr0 mul0e !mule0 !adde0 !diracT !mul1e. -Qed. - -Lemma binomial_over1 n p U : - 0 <= p <= 1 -> - (\int[binomial_probability_trunc n p]_y0 \d_(0 < y0)%N U = - bernoulli_trunc (1 - `1-p ^+ n) U :> \bar R)%E. -Proof. -move=> /andP[p0 p1]. -rewrite bernoulli_truncE; last first. - apply/andP; split. - apply/onemX_ge0; rewrite /onem; lra. - apply/onem_le1/exprn_ge0; rewrite /onem; lra. -rewrite (@integral_binomial_probabilty_trunc _ n p _ _ (fun y => \d_(1 <= y)%N U))//; last first. -rewrite !big_ord_recl/=. -rewrite /bump. -under eq_bigr => i _. - rewrite /=. - have -> : (0 < 1 + i)%N => //. - over. -rewrite addeC -ge0_sume_distrl. - congr (_ + _)%E; congr (_ * _)%E. - have -> : (\sum_(i < n) (p ^+ (1 + i) * `1-p ^+ (n - (1 + i)) *+ 'C(n, 1 + i))%:E)%E = - (\sum_(i < n.+1) (p ^+ i * `1-p ^+ (n - i) *+ 'C(n, i))%:E - (`1-p ^+ n)%:E)%E. - rewrite big_ord_recl/= expr0 subn0 mul1r bin0 mulr1n addeC addeA. - have <- : 0%E = ((- `1-p ^+ n)%:E + (`1-p ^+ n)%:E)%E. - rewrite EFinN. - congr _%:E. - lra. - by rewrite add0e. - congr _%E. - rewrite sumEFin. - rewrite !EFinB EFin_expe. - congr (_ - _)%E. - under eq_bigr do rewrite mulrC. - rewrite -(@exprDn_comm _ `1-p p n); last first. - by rewrite /GRing.comm/onem; lra. - rewrite /onem addrC. - have -> : p + (1 - p) = 1 by lra. - by rewrite expr1n. - rewrite subn0 expr0 bin0 mulr1n. - rewrite /onem. - congr _%:E. - set pn := (1-p) ^+ n. - lra. -move=> i _. -apply/mulrn_wge0/mulr_ge0; apply/exprn_ge0. -exact: p0. -apply/onem_ge0/p1. -Qed. - -Lemma binomial_le1 n p U : - 0 <= p <= 1 -> - (\int[binomial_probability_trunc n p]_y0 \d_(0 < y0)%N U = - \int[bernoulli_trunc (1 - `1-p ^+ n)]_y0 \d_y0 U :> \bar R)%E. -Proof. -move=> /andP[p0 p1]. -rewrite (@integral_bernoulli_trunc _ _ (fun x => \d_x U))//; last first. - apply/andP; split. - apply: onemX_ge0; rewrite /onem; lra. - apply/onem_le1/exprn_ge0; rewrite /onem; lra. -rewrite (@integral_binomial_probabilty_trunc _ n p _ _ (fun y => \d_(1 <= y)%N U))//; last first. -rewrite !big_ord_recl/=. -rewrite /bump. -under eq_bigr => i _. - rewrite /=. - have -> : (0 < 1 + i)%N => //. - over. -rewrite addeC -ge0_sume_distrl. - congr (_ + _)%E; congr (_ * _)%E. - have -> : (\sum_(i < n) (p ^+ (1 + i) * `1-p ^+ (n - (1 + i)) *+ 'C(n, 1 + i))%:E)%E = - (\sum_(i < n.+1) (p ^+ i * `1-p ^+ (n - i) *+ 'C(n, i))%:E - (`1-p ^+ n)%:E)%E. - rewrite big_ord_recl/= expr0 subn0 mul1r bin0 mulr1n addeC addeA. - have <- : 0%E = ((- `1-p ^+ n)%:E + (`1-p ^+ n)%:E)%E. - rewrite EFinN. - congr _%:E. - lra. - by rewrite add0e. - congr _%E. - rewrite sumEFin. - rewrite !EFinB EFin_expe. - congr (_ - _)%E. - under eq_bigr do rewrite mulrC. - rewrite -(@exprDn_comm _ `1-p p n); last first. - by rewrite /GRing.comm/onem; lra. - rewrite /onem addrC. - have -> : p + (1 - p) = 1 by lra. - by rewrite expr1n. - rewrite subn0 expr0 bin0 mulr1n. - rewrite /onem. - congr _%:E. - set pn := (1-p) ^+ n. - lra. -move=> i _. -apply/mulrn_wge0/mulr_ge0; apply/exprn_ge0. -exact: p0. -apply/onem_ge0/p1. -Qed. - -Lemma __ : uniform_probability a01 `[0, (1 / 2)] = (1 / 2)%:E. -Proof. -rewrite /uniform_probability /mscale/= /mrestr. -Abort. - -Lemma letin'_sample_uniform d d' (T : measurableType d) - (T' : measurableType d') (a b : R) (ab0 : (0 < b - a)%R) - (u : R.-sfker [the measurableType _ of (_ * T)%type] ~> T') x y : - measurable y -> - letin' (sample_cst (uniform_probability ab0)) u x y = - ((b - a)^-1%:E * \int[lebesgue_measure]_(x0 in `[a, b]) u (x0, x) y)%E. -Proof. -move=> my; rewrite letin'E/=. -rewrite integral_uniform//= => _ /= Y mY /=. -have /= := measurable_kernel u _ my measurableT _ mY. -move/measurable_ysection => /(_ R x) /=. -set A := (X in measurable X). -set B := (X in _ -> measurable X). -suff : A = B by move=> ->. -rewrite {}/A {}/B !setTI /ysection/= (*TODO: lemma?*) /preimage/=. -by apply/seteqP; split => [z|z] /=; rewrite inE/=. -Qed. - -Lemma execP_letin_uniform g t str (s0 s1 : exp P ((str, Real) :: g) t) : - (forall (p : R) x U, 0 <= p <= 1 -> - execP s0 (p, x) U = execP s1 (p, x) U) -> - forall x U, measurable U -> - execP [let str := Sample {@exp_uniform _ g 0 1 a01} in {s0}] x U = - execP [let str := Sample {@exp_uniform _ g 0 1 a01} in {s1}] x U. -Proof. -move=> s01 x U mU. -rewrite !execP_letin execP_sample execD_uniform/=. -rewrite !letin'_sample_uniform//. -congr (_ * _)%E. -apply: eq_integral => p p01. -apply: s01. -by rewrite inE in p01. -Qed. - -(* Lemma measurable_mtyp (t : typ) (U : set (@mtyp R t)) : measurable U. -Proof. -induction t => //. *) - -Lemma congr_letinl g t1 t2 str (e1 e2 : @exp _ _ g t1) -(e : @exp _ _ (_ :: g) t2) x U : - (forall y V, execP e1 y V = execP e2 y V) -> - measurable U -> - @execP R g t2 [let str := e1 in e] x U = - @execP R g t2 [let str := e2 in e] x U. -Proof. -move=> He mU. -apply eq_sfkernel in He. -by rewrite !execP_letin He. -Qed. - -Lemma congr_letin g t1 t2 str (e : @exp _ _ _ t1) (e1 e2 : @exp _ _ (_ :: g) t2) x U : - (forall y V, execP e1 (y, x) V = execP e2 (y, x) V) -> - @execP R g t2 [let str := e in e1] x U = @execP R g t2 [let str := e in e2] x U. -Proof. -move=> He. -rewrite !execP_letin !letin'E. -apply: eq_integral => ? _. -apply: He. -Qed. - -Lemma congr_normalize g t (e1 e2 : @exp R _ g t) : - (forall x U, execP e1 x U = execP e2 x U) -> - execD [Normalize e1] = execD [Normalize e2]. -Proof. -move=> He. -apply: eq_execD. -rewrite !execD_normalize_pt /=. -f_equal. -apply: eq_kernel => y V. -apply: He. -Qed. - -Definition uniform_syntax : @exp R _ [::] _ := - [let "p" := Sample {exp_uniform 0 1 a01} in - return #{"p"}]. - -Lemma exec_uniform_syntax t U : measurable U -> - execP uniform_syntax t U = uniform_probability a01 U. -Proof. -move=> mU. -rewrite /uniform_syntax execP_letin execP_sample execP_return !execD_uniform. -rewrite exp_var'E (execD_var_erefl "p")/=. -rewrite letin'E /=. -rewrite integral_uniform//=; last exact: measurable_fun_dirac. -rewrite subr0 invr1 mul1e. -rewrite {1}/uniform_probability. -rewrite /mscale/= subr0 invr1 mul1e. -by rewrite integral_indic. -Qed. - -Definition binomial_le : @exp R _ [::] Bool := - [let "a2" := Sample {exp_binomial 3 (1 / 2)%:nng (p1S 1)} in - return {1}:N <= #{"a2"}]. - -Lemma exec_binomial_le t U : - execP binomial_le t U = ((7 / 8)%:E * \d_true U + - (1 / 8)%:E * \d_false U)%E. -Proof. -rewrite /binomial_le execP_letin execP_sample execP_return execD_rel execD_nat. -rewrite exp_var'E (execD_var_erefl "a2") execD_binomial. -rewrite letin'E//= /binomial_probability ge0_integral_measure_sum//=. -rewrite !big_ord_recl big_ord0 !ge0_integral_mscale//=. -rewrite !integral_dirac// /bump. -rewrite !binS/= !bin0 bin1 bin2 bin_small// addn0. -rewrite addeC adde0. -congr (_ + _)%:E. - rewrite !indicT !(mul0n,add0n,lt0n,mul1r)/=. - rewrite -!mulrDl; congr (_ * _). - rewrite /onem. - lra. -rewrite !expr0 ltnn indicT/= !(mul1r,mul1e) /onem. -lra. -Qed. - -Definition binomial_guard : @exp R _ [::] Nat := - [let "a1" := Sample {exp_binomial 3 (1 / 2)%:nng (p1S 1)} in - let "_" := if #{"a1"} == {1}:N then return TT else Score {0}:R in - return #{"a1"}]. - -Lemma exec_binomial_guard t U : - execP binomial_guard t U = ((3 / 8)%:E * \d_1%N U(* + - (1 / 8)%:E * \d_0%N U*))%E. -Proof. -rewrite /binomial_guard !execP_letin execP_sample execP_return execP_if. -rewrite !exp_var'E execD_rel !(execD_var_erefl "a1") execP_return. -rewrite execD_unit execD_binomial execD_nat execP_score execD_real. -rewrite !letin'E//= /binomial_probability ge0_integral_measure_sum//=. -rewrite !big_ord_recl big_ord0 !ge0_integral_mscale//=. -rewrite !integral_dirac//. -rewrite /bump/=. -rewrite !binS/= !bin0 bin1 bin2 bin_small//. -rewrite !diracT !addn0 !expr0 !subn0 !mulr1n !mul1r !expr1 !mul1e. -rewrite !letin'E//= !iteE/= !diracE/=. -rewrite !ge0_integral_mscale//=. -rewrite !integral_dirac// !diracT//. -rewrite !(normr0,mul0e,mule0,add0e,add0n,mul1e,adde0). -rewrite /onem. -congr (_%:E * _)%E. -lra. -Qed. - -Lemma exec_beta_a1 U : - @execP R [::] _ [let "p" := Sample {exp_beta 6 4} in - Sample {exp_bernoulli_trunc [#{"p"}]}] tt U = - @execP R [::] _ [Sample {exp_bernoulli_trunc [{3 / 5}:R]}] tt U. -Proof. -rewrite execP_letin !execP_sample execD_beta_nat !execD_bernoulli_trunc/=. -rewrite !execD_real/= exp_var'E (execD_var_erefl "p")/=. -transitivity (beta_nat_bern 6 4 1 0 U : \bar R). - rewrite /beta_nat_bern !letin'E/= /ubeta_nat_pdf/= /onem. - apply: eq_integral => x _. - rewrite /=. - do 2 f_equal. - by rewrite /ubeta_nat_pdf' expr1 expr0 mulr1. -rewrite beta_nat_bern_bern// !bernoulli_truncE; last 2 first. - by lra. - apply/andP; split. - by apply/Baa'bb'Bab_ge0. - by apply/Baa'bb'Bab_le1. -congr (_ * _ + _ * _)%:E. - rewrite /Baa'bb'Bab /beta_nat_norm/=. - rewrite !factS/= fact0. - by field. -rewrite /onem; rewrite /Baa'bb'Bab /beta_nat_norm/=; -rewrite !factS/= fact0. -by field. -Qed. - -Definition casino0 : @exp R _ [::] _ := - [Normalize - let "p" := Sample {exp_uniform 0 1 a01} in - let "a1" := Sample {exp_binomial_trunc 8 [#{"p"}]} in - let "_" := if #{"a1"} == {5}:N then return TT else Score {0}:R in - let "a2" := Sample {exp_binomial_trunc 3 [#{"p"}]} in - return {1}:N <= #{"a2"}]. - -Definition casino1 : @exp R _ [::] _ := - [Normalize - let "p" := Sample {exp_uniform 0 1 a01} in - let "a1" := Sample {exp_binomial_trunc 8 [#{"p"}]} in - let "_" := if #{"a1"} == {5}:N then return TT else Score {0}:R in - Sample {exp_bernoulli_trunc [{1}:R - {[{1}:R - #{"p"}]} ^+ {3%nat}]}]. - -Definition casino2 : @exp R _ [::] _ := - [Normalize - let "p" := Sample {exp_uniform 0 1 a01} in - let "_" := - Score {[{56}:R * #{"p"} ^+ {5%nat} * {[{1}:R - #{"p"}]} ^+ {3%nat}]} in - Sample {exp_bernoulli_trunc [{1}:R - {[{1}:R - #{"p"}]} ^+ {3%nat}]}]. - -Definition casino2' : @exp R _ [::] _ := - [Normalize - let "p" := Sample {exp_beta 1 1} in - let "_" := Score - {[{56}:R * #{"p"} ^+ {5%nat} * {[{1}:R - #{"p"}]} ^+ {3%nat}]} in - Sample {exp_bernoulli_trunc [{1}:R - {[{1}:R - #{"p"}]} ^+ {3%nat}]}]. - -Definition casino3 : @exp R _ [::] _ := - [Normalize - let "_" := Score {1 / 9}:R in - let "p" := Sample {exp_beta 6 4} in - Sample {exp_bernoulli_trunc [{1}:R - {[{1}:R - #{"p"}]} ^+ {3%nat}]}]. - -Definition casino4 : @exp R _ [::] _ := - [Normalize - let "_" := Score {1 / 9}:R in - Sample {exp_bernoulli_trunc [{10 / 11}:R]}]. - -Definition casino5 : @exp R _ [::] _ := - [Normalize Sample {exp_bernoulli_trunc [{10 / 11}:R]}]. - -Lemma casino01 : - execD casino0 = execD casino1. -Proof. -rewrite /casino0 /casino1. -apply: eq_execD. -f_equal. -apply: congr_normalize => y V. -apply: execP_letin_uniform => //. -move=> p x U r01. -apply: congr_letin => y0 V0. -apply: congr_letin => y1 V1. -rewrite !execP_letin !execP_sample !execD_binomial_trunc /=. -rewrite !execP_return !execD_bernoulli_trunc/=. -rewrite !execD_rel (@execD_bin _ _ binop_minus) execD_pow. -rewrite (@execD_bin _ _ binop_minus) !execD_real/= !execD_nat. -rewrite !exp_var'E !(execD_var_erefl "p") !(execD_var_erefl "a2")/=. -rewrite !letin'E/=. -move: r01 => /andP[r0 r1]. -by apply/binomial_over1/andP. -Qed. - -Lemma casino12 : - execD casino1 = execD casino2. -Proof. -apply: eq_execD. -f_equal. -apply: congr_normalize => y V. -apply: execP_letin_uniform => //. -move=> p x U /andP[p0 p1]. -rewrite !execP_letin !execP_sample execP_if execD_rel/=. -rewrite !execP_score !(@execD_bin _ _ binop_mult). -rewrite !execD_bernoulli_trunc/= !(@execD_bin _ _ binop_minus) !execD_pow. -rewrite !(@execD_bin _ _ binop_minus)/=. -rewrite !execD_real !execD_nat/= execP_return execD_unit. -rewrite !execD_binomial_trunc/=. -rewrite !exp_var'E !(execD_var_erefl "p") !(execD_var_erefl "a1")/=. -rewrite !letin'E/=. -rewrite integral_binomial_probabilty_trunc//=. -rewrite (bigD1 (inord 5))//=. - rewrite big1; last first. - move=> [[|[|[|[|[|[|[|[|[|//]]]]]]]]]]//= Hi Hi5; rewrite letin'E iteE; - rewrite ?ge0_integral_mscale//= ?normr0 ?mul0e ?mule0 ?add0e//. - suff: false by []. - move/negbTE: Hi5 => <-. - by apply/eqP/val_inj => /=; rewrite inordK. -rewrite letin'E iteE ge0_integral_mscale//= inordK//= adde0 /onem. -congr (_ * _)%E. -rewrite ger0_norm. - by rewrite -mulrA mulr_natl. -apply/mulr_ge0. - exact/mulr_ge0/exprn_ge0. -apply/exprn_ge0. -by rewrite subr_ge0. -Qed. - -Lemma casino22' : - execD casino2 = execD casino2'. -Proof. -apply: eq_execD. -f_equal. -apply: congr_normalize => //= x U. -apply: congr_letinl => //= y V. -rewrite !execP_sample execD_uniform execD_beta_nat/=. -rewrite beta11_uniform//. -rewrite /=. -apply: sub_sigma_algebra. -rewrite //. -admit. -Admitted. - -Lemma casino23 : - execD casino2' = execD casino3. -Proof. -apply: eq_execD. -f_equal. -apply: congr_normalize => x U. -rewrite !execP_letin !execP_sample !execP_score !execD_beta_nat. -rewrite !execD_bernoulli_trunc/= !(@execD_bin _ _ binop_mult). -rewrite !execD_pow !(@execD_bin _ _ binop_minus) !execD_real/=. -rewrite !execD_pow !(@execD_bin _ _ binop_minus) !execD_real/=. -rewrite !exp_var'E !(execD_var_erefl "p")/=. -rewrite !letin'E/= ![in RHS]ge0_integral_mscale//=. -rewrite /=. -under eq_integral => y _. - rewrite letin'E/= /mscale/=. - over. -rewrite /=. -(* set f := letin' _ _. *) -transitivity (\int[beta_nat 1 1]_(y in `[0%R, 1%R]) f (y, x) U)%E. - rewrite [in RHS]integral_mkcond /=. - apply: eq_integral => y _. - rewrite patchE. - case: ifPn => //. - simpl in *. - rewrite mem_setE /= in_itv /= negb_and -!ltNge => /orP[y0|y1]; - rewrite /bernoulli_trunc/=. - case: sumbool_ler. - move=> a. - by rewrite ltNge a in y0. - rewrite /prob_lang.bernoulli0 /bernoulli => _. - rewrite [LHS]measure_addE/= /mscale/=. - (* match default value *) - admit. - admit. - rewrite integral_beta_nat. - admit. -rewrite (integral_beta_nat 6 4). - rewrite ger0_norm// integral_dirac// diracT mul1e letin'E/=. - transitivity (((1 / 9)%:E * \int[beta_nat 6 4]_(y in `[0%R, 1%R]) - bernoulli_trunc (1 - (1 - y) ^+ 3) U)%E : \bar R); last first. - admit. -rewrite (integral_beta_nat 6 4)//=. -rewrite -integralZl//=. - apply: eq_integral => y y01. - rewrite /f letin'E /= !ge0_integral_mscale//= integral_dirac// diracT mul1e. - rewrite -muleAC muleC -[in RHS]muleCA. - congr (_ * _)%E. - rewrite ger0_norm. - rewrite /beta_nat_pdf ubeta_nat_pdf11/= muleC -!EFinM. - rewrite !div1r. - rewrite /beta_nat_norm/= /ubeta_nat_pdf/ubeta_nat_pdf' factE/=/onem. - congr _%:E; lra. - rewrite inE/= in_itv/= in y01. - move: y01 => /andP[y0 y1]. - apply/mulr_ge0/exprn_ge0 => //. - apply/mulr_ge0/exprn_ge0 => //. - lra. -admit. -admit. -admit. -apply: (@measurableT_comp _ _ _ _ _ _ (fun x0 => f x0 U)). - apply: measurable_kernel. - done. -apply: measurable_pair2. -admit. -Admitted. - -Lemma casino34' U : - @execP R [::] _ [let "p" := Sample {exp_beta 6 4} in - Sample {exp_bernoulli_trunc [{[{1}:R - #{"p"}]} ^+ {3%nat}]}] tt U = - @execP R [::] _ [Sample {exp_bernoulli_trunc [{1 / 11}:R]}] tt U. -Proof. -rewrite execP_letin !execP_sample execD_beta_nat !execD_bernoulli_trunc/=. -rewrite execD_pow/= (@execD_bin _ _ binop_minus) !execD_real/=. -rewrite exp_var'E (execD_var_erefl "p")/=. -(* TODO: generalize *) -rewrite letin'E/=. -have := (@beta_nat_bern_bern R 6 4 0 3 U). -rewrite /beta_nat_bern /ubeta_nat_pdf/ubeta_nat_pdf'/=. -under eq_integral do rewrite expr0 mul1r. -move=> ->//. -rewrite /Baa'bb'Bab addn0 /beta_nat_norm/= factE/=. -by congr (bernoulli_trunc _ _); field. -Qed. - -Lemma bern_onem (f : _ -> R) U p : - (forall x, 0 <= f x <= 1) -> - (\int[beta_nat 6 4]_y bernoulli_trunc (f y) U = - p%:E * \d_true U + `1-p%:E * \d_false U)%E -> - (\int[beta_nat 6 4]_y bernoulli_trunc (1 - f y) U - = `1-p%:E * \d_true U + p%:E * \d_false U)%E. -Proof. -move=> f01. -under eq_integral => x _. - rewrite bernoulli_truncE. - over. -done. -move=> h1. -rewrite /= in h1. -rewrite /bernoulli_trunc. -(* /beta_nat/mscale/= /beta_nat_norm/= /ubeta_nat/ubeta_nat_pdf/=. *) -Admitted. - -Lemma casino34 : - execD casino3 = execD casino4. -Proof. -apply: eq_execD. -f_equal. -apply: congr_normalize => y V. -apply: congr_letin => x U. -rewrite execP_letin !execP_sample execD_beta_nat !execD_bernoulli_trunc/=. -rewrite (@execD_bin _ _ binop_minus) execD_pow/= (@execD_bin _ _ binop_minus). -rewrite !execD_real/= exp_var'E (execD_var_erefl "p")/=. -transitivity (\int[beta_nat 6 4]_y bernoulli_trunc (1 - (1 - y) ^+ 3) U : \bar R)%E. - by rewrite /beta_nat_bern !letin'E/= /onem. -rewrite bernoulli_truncE; last by lra. -have -> := (@bern_onem (fun x => (1 - x) ^+ 3) U (1 / 11) _). - congr (_ * _ + _ * _)%E; congr _%:E; rewrite /onem; lra. - admit. -transitivity (beta_nat_bern 6 4 0 3 U : \bar R). - rewrite /beta_nat_bern /ubeta_nat_pdf/= /onem. - apply: eq_integral => y0 _. - do 2 f_equal. - rewrite /ubeta_nat_pdf'/=. - rewrite expr0. - by rewrite mul1r. -rewrite beta_nat_bern_bern//= bernoulli_truncE; last first. - apply/andP; split. - apply/Baa'bb'Bab_ge0. - apply/Baa'bb'Bab_le1. -congr (_ * _ + _ * _)%:E; rewrite /onem. - rewrite /Baa'bb'Bab /beta_nat_norm/=. - by rewrite !factS/= fact0; field. -rewrite /Baa'bb'Bab /beta_nat_norm/=. -by rewrite !factS/= fact0; field. -Admitted. - -Lemma norm_score_bern g p1 p2 (p10 : p1 != 0) (p1_ge0 : 0 <= p1) -(p201 : 0 <= p2 <= 1) : - @execD R g _ - [Normalize let "_" := Score {p1}:R in - Sample {exp_bernoulli_trunc [{p2}:R]}] = - execD [Normalize Sample {exp_bernoulli_trunc [{p2}:R]}]. -Proof. -apply: eq_execD. -rewrite !execD_normalize_pt/= !execP_letin !execP_score. -rewrite !execP_sample !execD_bernoulli_trunc !execD_real/=. -apply: funext=> x. -apply: eq_probability=> /= y. -rewrite /normalize_pt !normalizeE/=. -rewrite !bernoulli_truncE; last lra; last lra. -rewrite !diracT !mule1 /onem -EFinD addrCA subrr addr0. -rewrite !letin'E. -under eq_integral. - move=> x0 _ /=. - rewrite !bernoulli_truncE; last lra. - rewrite !diracT !mule1 /onem -EFinD addrCA subrr addr0. - over. -rewrite !ge0_integral_mscale//= ger0_norm//. -rewrite integral_dirac// diracT !mule1. -rewrite !ifF; last first. - rewrite eqe. - apply/negbTE/negP => /orP[/eqP|//]. - by rewrite /onem; lra. - rewrite eqe. - apply/negbTE/negP => /orP[/eqP|//]. - by rewrite /onem; lra. -rewrite !bernoulli_truncE; last lra. -rewrite integral_dirac//= diracT !diracE. -by rewrite muleC muleA -EFinM mulVf// invr1 /onem !(mul1r, mule1). -Qed. - -Lemma casino45 : - execD casino4 = execD casino5. -Proof. -rewrite norm_score_bern//. -lra. -Qed. - -End casino_example. diff --git a/theories/lang_syntax_table_game.v b/theories/lang_syntax_table_game.v new file mode 100644 index 000000000..b40a114fb --- /dev/null +++ b/theories/lang_syntax_table_game.v @@ -0,0 +1,758 @@ +Require Import String. +From HB Require Import structures. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval. +From mathcomp.classical Require Import mathcomp_extra boolp classical_sets. +From mathcomp.classical Require Import functions cardinality fsbigop. +Require Import signed reals ereal topology normedtype sequences esum measure. +Require Import charge lebesgue_measure numfun lebesgue_integral kernel. +Require Import prob_lang lang_syntax_util lang_syntax lang_syntax_examples. +From mathcomp Require Import ring lra. + +(**md**************************************************************************) +(* # Edd's table game example *) +(* *) +(* ref: *) +(* - Chung-chieh Shan, Equational reasoning for probabilistic programming, *) +(* POPL TutorialFest 2018 *) +(* https://homes.luddy.indiana.edu/ccshan/rational/equational-handout.pdf *) +(* - Sean R Eddy, What is Bayesian statistics?, Nature Biotechnology 22(9), *) +(* 1177--1178 (2004) *) +(* *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import Order.TTheory GRing.Theory Num.Def Num.Theory. +Import numFieldTopology.Exports. + +Local Open Scope classical_set_scope. +Local Open Scope ring_scope. + +Local Open Scope ereal_scope. +Lemma letin'_sample_uniform {R : realType} d d' (T : measurableType d) + (T' : measurableType d') (a b : R) (ab : (a < b)%R) + (u : R.-sfker [the measurableType _ of (_ * T)%type] ~> T') x y : + measurable y -> + letin' (sample_cst (uniform_prob ab)) u x y = + (b - a)^-1%:E * \int[lebesgue_measure]_(x0 in `[a, b]) u (x0, x) y. +Proof. +move=> my; rewrite letin'E/=. +rewrite integral_uniform//=. +move => _ /= Y mY /=. +have /= := measurable_kernel u _ my measurableT _ mY. +move/measurable_ysection => /(_ R x) /=. +set A := (X in measurable X). +set B := (X in _ -> measurable X). +suff : A = B by move=> ->. +rewrite {}/A {}/B !setTI /ysection/= (*TODO: lemma?*) /preimage/=. +by apply/seteqP; split => [z|z] /=; rewrite inE/=. +Qed. + +Local Open Scope lang_scope. +Lemma execP_letin_uniform {R : realType} + g t str (s0 s1 : exp P ((str, Real) :: g) t) : + (forall (p : R) x U, (0 <= p <= 1)%R -> + execP s0 (p, x) U = execP s1 (p, x) U) -> + forall x U, measurable U -> + execP [let str := Sample {@exp_uniform _ g 0 1 (@ltr01 R)} in {s0}] x U = + execP [let str := Sample {@exp_uniform _ g 0 1 (@ltr01 R)} in {s1}] x U. +Proof. +move=> s01 x U mU. +rewrite !execP_letin execP_sample execD_uniform/=. +rewrite !letin'_sample_uniform//. +congr *%E. +apply: eq_integral => p p01. +apply: s01. +by rewrite inE in p01. +Qed. +Local Close Scope lang_scope. +Local Close Scope ereal_scope. + +Section bounded. +Local Open Scope ring_scope. +Local Open Scope lang_scope. +Local Open Scope ereal_scope. +Context {R : realType}. + +Lemma bounded_id_01 : [bounded x0 | x0 in `[0%R, 1%R]%classic : set R]. +Proof. +exists 1%R; split => // y y1. +near=> M => /=. +rewrite (le_trans _ (ltW y1))//. +near: M. +move=> M /=. +rewrite in_itv/= => /andP[M0 M1]. +by rewrite ler_norml M1 andbT (le_trans _ M0). +Unshelve. all: by end_near. Qed. + +Lemma bounded_onem_01 : [bounded (`1- x : R) | x in `[0%R, 1%R]%classic : set R]. +Proof. +exists 1%R; split => // y y1. +near=> M => /=. +rewrite (le_trans _ (ltW y1))//. +near: M. +move=> M /=. +rewrite in_itv/= => /andP[M0 M1]. +rewrite ler_norml (@le_trans _ _ 0%R)//=. + by rewrite lerBlDr addrC -lerBlDr subrr. +by rewrite onem_ge0. +Unshelve. all: by end_near. Qed. + +Lemma bounded_cst_01 (x : R) : [bounded x | _ in `[0%R, 1%R]%classic : set R]. +Proof. +exists `|x|%R; split. + by rewrite num_real. +move=> y y1/= z. +rewrite in_itv/= => /andP[z0 z1]. +by rewrite (le_trans _ (ltW y1)). +Qed. + +Lemma bounded_norm (f : R -> R) : + [bounded f x | x in (`[0%R, 1%R]%classic : set R)] <-> + [bounded normr (f x) | x in (`[0%R, 1%R]%classic : set R)]. +Proof. +split. + move=> [M [Mreal HM]]. + exists `|M|%R; split; first by rewrite normr_real. + move=> r Mr x/= x01. + by rewrite ger0_norm// HM// (le_lt_trans _ Mr)// ler_norm. +move=> [M [Mreal HM]]. +exists `|M|%R; split; first by rewrite normr_real. +move=> r Mr x/= x01. +rewrite -[leLHS]ger0_norm// HM//. +by rewrite (le_lt_trans _ Mr)// ler_norm. +Qed. + +Lemma boundedMl k (f : R -> R) : + [bounded f x | x in (`[0%R, 1%R]%classic : set R)] -> + [bounded (k * f x)%R | x in (`[0%R, 1%R]%classic : set R)]. +Proof. +move=> [M [Mreal HM]]. +exists `|k * M|%R; split; first by rewrite normr_real. +move=> r kMr x/= x01. +rewrite normrM. +have [->|k0] := eqVneq k 0%R. + by rewrite normr0 mul0r (le_trans _ (ltW kMr)). +rewrite -ler_pdivlMl ?normr_gt0//. +apply: HM => //. +rewrite ltr_pdivlMl ?normr_gt0//. +rewrite (le_lt_trans _ kMr)//. +by rewrite normrM ler_pM2l ?normr_gt0// ler_norm. +Qed. + +Lemma bounded_casino23 : + [bounded normr (56 * x ^+ 5 * (1 - x) ^+ 3)%R : R | + x in (`[0%R, 1%R]%classic : set R)]. +Proof. +rewrite (@eq_fun _ _ _ (fun x => normr (56 * (x ^+ 5 * (1 - x) ^+ 3))))//; last first. + by move=> x; rewrite -mulrA. +apply/(bounded_norm _).1. +apply: boundedMl. +apply/(bounded_norm _).2. +exact: bounded_norm_expn_onem. +Qed. + +End bounded. + +Lemma measurable_bernoulli_expn {R : realType} U n : + measurable_fun [set: salgebraType (R.-ocitv.-measurable)] + (fun x : salgebraType (R.-ocitv.-measurable) => bernoulli ((1 - x) ^+ n) U). +Proof. +apply: (measurableT_comp (measurable_bernoulli2 _)) => //=. +by apply: measurable_fun_pow => //=; exact: measurable_funB. +Qed. + +Lemma integrable_bernoulli_beta_nat_pdf {R : realType} U : measurable U -> + (@lebesgue_measure R).-integrable [set: salgebraType (R.-ocitv.-measurable)] + (fun x => (bernoulli (1 - (1 - x) ^+ 3) U * (beta_nat_pdf 6 4 x)%:E)%E). +Proof. +move=> mU. +have ? : measurable_fun [set: salgebraType (R.-ocitv.-measurable)] + (fun x => bernoulli (1 - (1 - x) ^+ 3) U). + apply: (measurableT_comp (measurable_bernoulli2 _)) => //=. + apply: measurable_funB => //; apply: measurable_fun_pow => //. + exact: measurable_funB. +apply/integrableP; split => /=. + apply: emeasurable_funM => //. + apply/EFin_measurable_fun. + exact: measurable_beta_nat_pdf. +apply: (@le_lt_trans _ _ (\int[lebesgue_measure]_(x in `[0%R, 1%R]) (beta_nat_pdf 6 4 x)%:E))%E. + rewrite [leRHS]integral_mkcond /=. + apply: ge0_le_integral => //=. + - apply: measurableT_comp => //; apply: emeasurable_funM => //. + by apply/EFin_measurable_fun; exact: measurable_beta_nat_pdf. + - move=> x _ /=; rewrite patchE; case: ifPn => // _. + by rewrite lee_fin beta_nat_pdf_ge0. + - apply: (measurable_restrict (E := setT) _ _ _ _).1 => //. + apply/measurable_funTS/measurableT_comp => //. + exact: measurable_beta_nat_pdf. + - move=> x _. + rewrite patchE; case: ifPn. + rewrite inE/= in_itv/= => /andP[x0 x1]. + rewrite gee0_abs//. + rewrite gee_pMl// ?probability_le1//. + by rewrite ge0_fin_numE// (le_lt_trans (probability_le1 _ _))// ltry. + by rewrite lee_fin beta_nat_pdf_ge0. + by rewrite mule_ge0// lee_fin beta_nat_pdf_ge0. + rewrite notin_setE/= in_itv/= => /negP; rewrite negb_and -!ltNge => /orP[x0|x1]. + by rewrite /beta_nat_pdf /ubeta_nat_pdf (leNgt 0) x0/= mul0r mule0 abse0. + by rewrite /beta_nat_pdf /ubeta_nat_pdf (leNgt x) x1/= andbF mul0r mule0 abse0. +apply: (@le_lt_trans _ _ + (\int[lebesgue_measure]_(x in `[0%R, 1%R]) (beta_nat_norm 6 4)^-1%:E)%E); last first. + by rewrite integral_cst//= lebesgue_measure_itv/= lte01 EFinN sube0 mule1 ltry. +apply: ge0_le_integral => //=. +- by move=> ? _; rewrite lee_fin beta_nat_pdf_ge0. +- by apply/measurable_funTS/measurableT_comp => //; exact: measurable_beta_nat_pdf. +- by move=> ? _; rewrite lee_fin invr_ge0// beta_nat_norm_ge0. +- by move=> x _; rewrite lee_fin beta_nat_pdf_le_beta_nat_norm. +Qed. + +Section casino_example. +Local Open Scope ring_scope. +Local Open Scope ereal_scope. +Local Open Scope lang_scope. +Context (R : realType). +Local Notation mu := lebesgue_measure. + +Definition casino0 : @exp R _ [::] _ := + [Normalize + let "p" := Sample {exp_uniform 0 1 (@ltr01 R)} in + let "a1" := Sample {exp_binomial 8 [#{"p"}]} in + let "_" := if #{"a1"} == {5}:N then return TT else Score {0}:R in + let "a2" := Sample {exp_binomial 3 [#{"p"}]} in + return {1}:N <= #{"a2"}]. + +Definition casino1 : @exp R _ [::] _ := + [Normalize + let "p" := Sample {exp_uniform 0 1 (@ltr01 R)} in + let "a1" := Sample {exp_binomial 8 [#{"p"}]} in + let "_" := if #{"a1"} == {5}:N then return TT else Score {0}:R in + Sample {exp_bernoulli [{1}:R - {[{1}:R - #{"p"}]} ^+ {3%nat}]}]. + +Definition casino2 : @exp R _ [::] _ := + [Normalize + let "p" := Sample {exp_uniform 0 1 (@ltr01 R)} in + let "_" := + Score {[{56}:R * #{"p"} ^+ {5%nat} * {[{1}:R - #{"p"}]} ^+ {3%nat}]} in + Sample {exp_bernoulli [{1}:R - {[{1}:R - #{"p"}]} ^+ {3%nat}]}]. + +Definition casino2' : @exp R _ [::] _ := + [Normalize + let "p" := Sample {exp_beta 1 1} in + let "_" := Score + {[{56}:R * #{"p"} ^+ {5%nat} * {[{1}:R - #{"p"}]} ^+ {3%N}]} in + Sample {exp_bernoulli [{1}:R - {[{1}:R - #{"p"}]} ^+ {3%N}]}]. + +Definition casino3 : @exp R _ [::] _ := + [Normalize + let "_" := Score {1 / 9}:R in + let "p" := Sample {exp_beta 6 4} in + Sample {exp_bernoulli [{1}:R - {[{1}:R - #{"p"}]} ^+ {3%nat}]}]. + +Definition casino4 : @exp R _ [::] _ := + [Normalize + let "_" := Score {1 / 9}:R in + Sample {exp_bernoulli [{10 / 11}:R]}]. + +Definition casino5 : @exp R _ [::] _ := + [Normalize Sample {exp_bernoulli [{10 / 11}:R]}]. + +Lemma casino01 : execD casino0 = execD casino1. +Proof. +rewrite /casino0 /casino1. +apply: eq_execD. +f_equal. +apply: congr_normalize => y V. +apply: execP_letin_uniform => //. +move=> p x U r01. +apply: congr_letinr => y0 V0. +apply: congr_letinr => y1 V1. +rewrite !execP_letin !execP_sample !execD_binomial /=. +rewrite !execP_return !execD_bernoulli/=. +rewrite !execD_rel (@execD_bin _ _ binop_minus) execD_pow. +rewrite (@execD_bin _ _ binop_minus) !execD_real/= !execD_nat. +rewrite !exp_var'E !(execD_var_erefl "p") !(execD_var_erefl "a2")/=. +rewrite !letin'E/=. +move: r01 => /andP[r0 r1]. +by apply/integral_binomial_bernoulli/andP. +Qed. + +Lemma casino12 : execD casino1 = execD casino2. +Proof. +apply: eq_execD. +f_equal. +apply: congr_normalize => y V. +apply: execP_letin_uniform => //. +move=> p x U /andP[p0 p1]. +rewrite !execP_letin !execP_sample execP_if execD_rel/=. +rewrite !execP_score !(@execD_bin _ _ binop_mult). +rewrite !execD_bernoulli/= !(@execD_bin _ _ binop_minus) !execD_pow. +rewrite !(@execD_bin _ _ binop_minus)/=. +rewrite !execD_real !execD_nat/= execP_return execD_unit. +rewrite !execD_binomial/=. +rewrite !exp_var'E !(execD_var_erefl "p") !(execD_var_erefl "a1")/=. +rewrite !letin'E/=. +rewrite integral_binomial//=. +rewrite (bigD1 (inord 5))//=. + rewrite big1; last first. + move=> [[|[|[|[|[|[|[|[|[|//]]]]]]]]]]//= Hi Hi5; rewrite letin'E iteE; + rewrite ?ge0_integral_mscale//= ?normr0 ?mul0e ?mule0 ?add0e//. + suff: false by []. + move/negbTE: Hi5 => <-. + by apply/eqP/val_inj => /=; rewrite inordK. +rewrite letin'E iteE ge0_integral_mscale//= inordK//= adde0 /onem. +congr *%E. +rewrite ger0_norm. + by rewrite -mulrA mulr_natl. +apply/mulr_ge0. + exact/mulr_ge0/exprn_ge0. +apply/exprn_ge0. +by rewrite subr_ge0. +Qed. + +Lemma casino22' : execD casino2 = execD casino2'. +Proof. +apply: eq_execD. +congr projT1. +apply: congr_normalize => // x U. +apply: congr_letinl => // y V. +rewrite !execP_sample execD_uniform execD_beta_nat. +rewrite /=. +by rewrite beta11_uniform//. +Qed. + +Lemma casino23 : execD casino2' = execD casino3. +Proof. +apply: eq_execD. +f_equal. +apply: congr_normalize => x U. +rewrite !execP_letin !execP_sample !execP_score !execD_beta_nat. +rewrite !execD_bernoulli/= !(@execD_bin _ _ binop_mult). +do 2 (rewrite !execD_pow !(@execD_bin _ _ binop_minus) !execD_real/=). +rewrite !exp_var'E !(execD_var_erefl "p")/=. +rewrite !letin'E/= ![in RHS]ge0_integral_mscale//=. +under eq_integral => y _. + rewrite letin'E/=. + rewrite integral_cst//= /mscale/= diracT mule1. + over. +rewrite /=. +have H1 : measurable_fun [set: salgebraType (R.-ocitv.-measurable)] + (fun x0 : salgebraType (R.-ocitv.-measurable) => bernoulli (1 - (1 - x0) ^+ 3) U). + apply: (measurableT_comp (measurable_bernoulli2 _)) => //=. + apply: measurable_funB => //. + apply: measurable_fun_pow. + exact: measurable_funB. +have H2 a b : (\int[beta_nat a b]_x0 `|bernoulli (1 - (1 - x0) ^+ 3) U| < +oo :> \bar R)%E. + apply: (@le_lt_trans _ _ (\int[beta_nat a b]_x0 1)%E). + apply: ge0_le_integral => //=. + exact/measurableT_comp. + move=> x0 _. + by rewrite gee0_abs// probability_le1. + by rewrite integral_cst//= mul1e -ge0_fin_numE// beta_nat_fin_num. +rewrite integral_beta_nat//=; last 2 first. + - apply: emeasurable_funM => //. + apply/EFin_measurable_fun. + apply: measurableT_comp => //. + apply: measurable_funM => //. + exact: measurable_funM. + apply: measurable_fun_pow => //. + exact: measurable_funB. + - suff: (beta_nat 1 1).-integrable setT + (fun x0 => bernoulli (1 - (1 - x0) ^+ 3) U * + (normr (56 * x0 ^+ 5 * (1 - x0) ^+ 3))%:E : \bar R)%E. + by move=> /integrableP[]. + rewrite /=. + apply/integrableP; split. + apply: emeasurable_funM => //. + apply/EFin_measurable_fun => //. + apply: measurableT_comp => //. + apply: measurable_funM => //. + exact: measurable_funM. + apply: measurable_fun_pow => //. + exact: measurable_funB. + rewrite beta11_uniform. + rewrite integral_uniform//=. + rewrite subr0 invr1 mul1e. + suff : ((@lebesgue_measure R).-integrable `[0%R, 1%R] + (fun y => bernoulli (1 - (1 - y) ^+ 3) U * (normr (56 * y ^+ 5 * (1 - y) ^+ 3))%:E))%E. + by move=> /integrableP[]. + apply: integrableMl => //=. + + apply/integrableP; split. + apply: measurable_funTS => /=. + exact: H1. + have := H2 1%N 1%N. + rewrite beta11_uniform. + rewrite integral_uniform//=; last first. + exact: measurableT_comp. + by rewrite subr0 invr1 mul1e. + apply: @measurableT_comp => //. + apply: measurable_funM => //. + exact: measurable_funM. + apply: measurable_fun_pow => //. + exact: measurable_funB. + + exact: bounded_casino23. + apply: @measurableT_comp => //. + apply: emeasurable_funM => //. + do 2 apply: @measurableT_comp => //. + apply: measurable_funM => //. + exact: measurable_funM. + by apply: measurable_fun_pow => //; exact: measurable_funB. +rewrite ger0_norm// integral_dirac// diracT mul1e letin'E/=. +rewrite integral_beta_nat/=; [|by []|by []|exact: H2]. +rewrite -integralZl//=; last exact: integrable_bernoulli_beta_nat_pdf. +apply: eq_integral => y _. +rewrite /beta_nat_pdf /ubeta_nat_pdf. +case: ifPn; last first. + by rewrite !(mul0r,mulr0,mule0). +move=> /andP[y0 y1]. +rewrite [RHS]muleCA -!muleA. +congr *%E. +rewrite /= !expr0 mulr1 !div1r. +rewrite ger0_norm//; last first. + rewrite mulr_ge0//. + by rewrite mulr_ge0// exprn_ge0. + by rewrite exprn_ge0// subr_ge0. +rewrite -!EFinM; congr EFin. +by rewrite !beta_nat_normE/= /=factE/= /onem; lra. +Qed. + +Lemma casino34' U : + @execP R [::] _ [let "p" := Sample {exp_beta 6 4} in + Sample {exp_bernoulli [{[{1}:R - #{"p"}]} ^+ {3%N}]}] tt U = + @execP R [::] _ [Sample {exp_bernoulli [{1 / 11}:R]}] tt U. +Proof. +rewrite execP_letin !execP_sample execD_beta_nat !execD_bernoulli/=. +rewrite execD_pow/= (@execD_bin _ _ binop_minus) !execD_real/=. +rewrite exp_var'E (execD_var_erefl "p")/=. +(* TODO: generalize *) +rewrite letin'E/=. +transitivity (\int[beta_nat 6 4]_(y in `[0%R, 1%R]%classic : set R) + bernoulli ((1 - y) ^+ 3) U)%E. + rewrite integral_beta_nat//; last 2 first. + by apply: measurable_funTS; apply: measurable_bernoulli_expn. + apply: (le_lt_trans _ (integral_beta_bernoulli_expn_lty 3 6 4 U)). + apply: ge0_subset_integral => //=; apply: measurableT_comp => //=. + apply: (measurableT_comp (measurable_bernoulli2 _)) => //=. + by apply: measurable_fun_pow => //=; exact: measurable_funB. + rewrite integral_beta_nat//; last 2 first. + exact: measurable_bernoulli_expn. + exact: integral_beta_bernoulli_expn_lty. + rewrite [RHS]integral_mkcond/=; apply: eq_integral => x _ /=. + rewrite patchE; case: ifPn => //. + rewrite /beta_nat_pdf /ubeta_nat_pdf notin_setE/= in_itv/= => /negP/negbTE ->. + by rewrite mul0r mule0. +have := (@beta_nat_bernE R 6 4 0 3 U) isT isT. +rewrite /beta_nat_bernoulli /ubeta_nat_pdf /=. +under eq_integral. + move=> x. + rewrite inE /=in_itv/= => ->. + rewrite expr0 mul1r. + over. +rewrite /= => ->; congr bernoulli. +by rewrite /div_beta_nat_norm addn0 !beta_nat_normE/= !factE/=; field. +Qed. + +Lemma integral_bernoulli_beta_nat_pdf' (f : _ -> R) U : measurable_fun setT f -> + (forall x, x \in (`[0%R, 1%R]%classic : set R) -> 0 <= f x <= 1)%R -> + \int[mu]_(y in `[0%R, 1%R]) (bernoulli (1 - f y) U * (beta_nat_pdf 6 4 y)%:E) = + (\d_true U + \d_false U) * beta_nat 6 4 setT - + \int[mu]_(y in `[0%R, 1%R]) + (bernoulli (f y) U * (beta_nat_pdf 6 4 y)%:E). +Proof. +move=> mf f01. +have f0 x : x \in (`[0%R, 1%R]%classic : set R) -> (0 <= f x)%R. + by move => /f01/andP[]. +have f1 x : x \in (`[0%R, 1%R]%classic : set R) -> (f x <= 1)%R. + by move => /f01/andP[]. +under eq_integral => x. + move=> x01. + rewrite bernoulliE_ext//=; last first. + by rewrite subr_ge0 f1//= lerBlDr addrC -lerBlDr subrr f0. + over. +rewrite /=. +under [LHS]eq_integral. + rewrite /= => x _. + rewrite onemK muleDl//. + over. +rewrite /=. +rewrite ge0_integralD//=; last 4 first. + move=> x x01; rewrite mule_ge0// ?lee_fin ?beta_nat_pdf_ge0//. + by rewrite mulr_ge0// subr_ge0// f1// inE. + apply: measurable_funTS; apply: emeasurable_funM => //. + by apply: emeasurable_funM => //; apply/EFin_measurable_fun/measurable_funB. + by apply/EFin_measurable_fun; apply: measurable_beta_nat_pdf. + by move=> x x01; rewrite mule_ge0// ?lee_fin ?beta_nat_pdf_ge0// mulr_ge0// f0// inE. + apply: measurable_funTS; apply: emeasurable_funM => //. + by apply: emeasurable_funM; apply/EFin_measurable_fun. + by apply/EFin_measurable_fun; exact: measurable_beta_nat_pdf. +under eq_integral do rewrite muleAC/=. +rewrite ge0_integralZr//=; last 2 first. + apply: measurable_funTS; apply: emeasurable_funM => //. + by apply/EFin_measurable_fun/measurable_funB. + by apply/EFin_measurable_fun; exact: measurable_beta_nat_pdf. + move=> x x01. + by rewrite mule_ge0// lee_fin// ?subr_ge0// ?f1// ?inE// beta_nat_pdf_ge0. +under [X in _ + X = _]eq_integral do rewrite muleAC/=. +rewrite [X in _ + X = _]ge0_integralZr//=; last 2 first. + apply: measurable_funTS; apply: emeasurable_funM => //. + exact/EFin_measurable_fun. + by apply/EFin_measurable_fun; exact: measurable_beta_nat_pdf. + by move=> x x01; rewrite mule_ge0// lee_fin// ?f0// ?inE// beta_nat_pdf_ge0. +under [in RHS]eq_integral => x x01. + rewrite bernoulliE_ext//=; last first. + by rewrite f0//= f1. + rewrite muleDl//. + over. +rewrite /= ge0_integralD//=; last 4 first. + move=> x x01; rewrite mule_ge0// ?lee_fin ?beta_nat_pdf_ge0// mulr_ge0// f0//. + by rewrite inE. + apply: measurable_funTS; apply: emeasurable_funM => //. + by apply: emeasurable_funM => //; apply/EFin_measurable_fun. + by apply/EFin_measurable_fun; exact: measurable_beta_nat_pdf. + move=> x x01; rewrite mule_ge0// ?lee_fin ?beta_nat_pdf_ge0// mulr_ge0//. + by rewrite subr_ge0 f1// inE. + apply: measurable_funTS;apply: emeasurable_funM => //. + by apply: emeasurable_funM => //; apply/EFin_measurable_fun/measurable_funB. + by apply/EFin_measurable_fun; exact: measurable_beta_nat_pdf. +under [X in _ = _ - (X + _)]eq_integral do rewrite muleAC/=. +rewrite [X in _ = _ - (X + _)]ge0_integralZr//=; last 2 first. + apply: measurable_funTS => //; apply: emeasurable_funM => //. + by apply/EFin_measurable_fun. + by apply/EFin_measurable_fun; exact: measurable_beta_nat_pdf. + by move=> x x01; rewrite mule_ge0// lee_fin// ?f0// ?inE// beta_nat_pdf_ge0. +under [X in _ = _ - (_ + X)]eq_integral do rewrite muleAC/=. +rewrite [X in _ = _ - (_ + X)]ge0_integralZr//=; last 2 first. + apply: measurable_funTS => //; apply: emeasurable_funM => //. + by apply/EFin_measurable_fun/measurable_funB. + by apply/EFin_measurable_fun; exact: measurable_beta_nat_pdf. + move=> x x01; rewrite mule_ge0// lee_fin// ?beta_nat_pdf_ge0//. + by rewrite subr_ge0 f1// inE. +rewrite oppeD//; last first. + rewrite ge0_adde_def// inE mule_ge0// integral_ge0//= => x x01; + by rewrite mule_ge0 ?lee_fin ?beta_nat_pdf_ge0// ?subr_ge0 ?f0 ?f1 ?inE//. +rewrite addrA. +rewrite -mulNe. + rewrite -integral_ge0N//=; last first. + by move=> x x01; rewrite mule_ge0 ?lee_fin ?beta_nat_pdf_ge0// f0// inE. +rewrite -mulNe. +rewrite -integral_ge0N//=; last first. + by move=> x x01; rewrite mule_ge0 ?lee_fin ?beta_nat_pdf_ge0// subr_ge0 f1// inE. +under [X in _ = (_ + _ + X * _)%E]eq_integral. + move=> /= y _. + rewrite /onem mulrBl mul1r opprB EFinB. + over. +rewrite /=. +rewrite [in RHS]muleDl//; last first. + by rewrite beta_nat_fin_num. +rewrite -addeA. +rewrite addeACA. +rewrite [in RHS](muleC _ (\d_false U)). +rewrite -muleDr//; last first. + by rewrite fin_num_adde_defr// beta_nat_fin_num. +rewrite [in RHS](muleC _ (\d_true U)). +rewrite -muleDr//; last first. + by rewrite fin_num_adde_defr// beta_nat_fin_num. +have ? : (beta_nat 6 4).-integrable [set: salgebraType (R.-ocitv.-measurable)] (EFin \o (fun=> 1%R)). + apply/integrableP; split. + exact/EFin_measurable_fun. + rewrite integral_beta_nat//=. + under eq_integral do rewrite normr1 mul1e. + rewrite /=. + have /integrableP[_] := @integrable_beta_nat_pdf R 6 4. + under eq_integral. + move=> /= x. + rewrite ger0_norm ?beta_nat_pdf_ge0//. + over. + by rewrite /=. + rewrite integral_cst//= !normr1 mul1e. + by rewrite -ge0_fin_numE// beta_nat_fin_num. +have ? : lebesgue_measure.-integrable [set: salgebraType (R.-ocitv.-measurable)] + (EFin \o (fun x : salgebraType (R.-ocitv.-measurable) => (f x * beta_nat_pdf 6 4 x)%R)). + apply/integrableP; split. + apply/EFin_measurable_fun. + apply/measurable_funM => //. + exact: measurable_beta_nat_pdf. + rewrite /=. + rewrite [ltLHS](_ : _ = \int[lebesgue_measure]_(x in `[0%R, 1%R]) + (normr (f x * beta_nat_pdf 6 4 x))%:E); last first. + rewrite [RHS]integral_mkcond /=. + apply: eq_integral => x _. + rewrite patchE; case: ifPn => //. + rewrite notin_setE/= in_itv/= => /negP; rewrite negb_and -!ltNge => /orP[x0|x1]. + by rewrite /beta_nat_pdf /ubeta_nat_pdf leNgt x0/= mul0r mulr0 normr0. + by rewrite /beta_nat_pdf /ubeta_nat_pdf (leNgt x) x1 andbF mul0r mulr0 normr0. + apply: (@le_lt_trans _ _ (\int[lebesgue_measure]_(x in `[0%R, 1%R]) (beta_nat_norm 6 4)^-1%:E)). + apply: ge0_le_integral => //=. + apply: measurable_funTS; apply: measurableT_comp => //=. + apply: measurableT_comp => //=; apply: measurable_funM => //=. + exact: measurable_beta_nat_pdf. + by move=> _ _; rewrite lee_fin invr_ge0// beta_nat_norm_ge0. + move=> x x01. + rewrite ger0_norm//; last first. + by rewrite mulr_ge0// ?f0 ?inE// beta_nat_pdf_ge0. + rewrite lee_fin. + rewrite -[leRHS]mul1r. + rewrite ler_pM// ?beta_nat_pdf_ge0// ?f0 ?f1 ?inE//. + exact: beta_nat_pdf_le_beta_nat_norm. + rewrite integral_cst//=. + by rewrite lebesgue_measure_itv//= lte01 EFinN sube0 mule1 ltry. +rewrite [in LHS](muleC _ (\d_false U)). +rewrite [in LHS](muleC _ (\d_true U)). +congr (_ * _ + _ * _). + under eq_integral do rewrite EFinB muleBl// mul1e. + rewrite integralB_EFin//=; last first. + by apply: (@integrableS _ _ _ _ setT) => //. + apply: (@integrableS _ _ _ _ setT) => //. + exact: integrable_beta_nat_pdf. + under [in RHS]eq_integral do rewrite EFinN EFinM. + rewrite [X in _ = _ + X]integral_ge0N //; last first. + move=> x x01. + by rewrite mule_ge0// lee_fin// ?f0 ?inE// beta_nat_pdf_ge0. + rewrite /=. + congr (_ - _). + by rewrite -integral_beta_nat_pdf// int_beta_nat_pdf01. +rewrite integralB_EFin//=. +- rewrite addeCA. + rewrite -integral_beta_nat_pdf// int_beta_nat_pdf01 subee ?adde0//. + by rewrite integral_beta_nat_pdf// beta_nat_fin_num. +- exact: (@integrableS _ _ _ _ setT). +- by apply: (@integrableS _ _ _ _ setT) => //; exact: integrable_beta_nat_pdf. +Qed. + +Lemma integral_bernoulli_beta_nat_pdf (f : _ -> R) U p : + measurable_fun setT f -> + (forall x, x \in (`[0%R, 1%R]%classic : set R) -> 0 <= f x <= 1)%R -> + (\int[mu]_(y in `[0%R, 1%R]) (bernoulli (f y) U * (beta_nat_pdf 6 4 y)%:E) = + p%:E * \d_true U + + (beta_nat 6 4 [set: _] - p%:E) * \d_false U)%E + -> + (\int[mu]_(y in `[0%R, 1%R]) (bernoulli (1 - f y) U * (beta_nat_pdf 6 4 y)%:E) = + (beta_nat 6 4 [set: _] - p%:E) * \d_true U + + p%:E * \d_false U)%E. +Proof. +move=> mf f01 H. +rewrite integral_bernoulli_beta_nat_pdf'//= H. +rewrite oppeD// muleDl ?beta_nat_fin_num//=. +rewrite addeACA EFinN EFinM muleC -muleBl//; last first. + by rewrite fin_num_adde_defr// beta_nat_fin_num. +rewrite (muleC (\d_false U)) -muleBl//; last first. + by rewrite fin_num_adde_defr// beta_nat_fin_num. +congr +%E. +rewrite oppeD// ?fin_num_adde_defr ?beta_nat_fin_num//. +by rewrite addeA subee ?beta_nat_fin_num// EFinN oppeK add0e. +Qed. + +Lemma casino34 : execD casino3 = execD casino4. +Proof. +apply: congr_normalize => y V. +apply: congr_letinr => x U. +rewrite execP_letin !execP_sample execD_beta_nat !execD_bernoulli/=. +rewrite (@execD_bin _ _ binop_minus) execD_pow/= (@execD_bin _ _ binop_minus). +rewrite !execD_real/= exp_var'E (execD_var_erefl "p")/=. +transitivity (\int[beta_nat 6 4]_y bernoulli (1 - (1 - y) ^+ 3) U : \bar R)%E. + by rewrite /beta_nat_bernoulli !letin'E/= /onem. +rewrite bernoulliE_ext//=; last lra. +rewrite integral_beta_nat//; last first. + by have := @integral_beta_bernoulli_onem_lty R _ _ _ U. + apply: (measurableT_comp (measurable_bernoulli2 _)) => //. + apply: measurable_funB => //; apply: measurable_fun_pow => //. + exact: measurable_funB. +transitivity (\int[mu]_(x in `[0%R, 1%R]) (bernoulli (1 - (1 - x) ^+ 3) U * + (beta_nat_pdf 6 4 x)%:E) : \bar R)%E. + rewrite [RHS]integral_mkcond; apply: eq_integral => z _. + rewrite /= patchE; case: ifPn => //. + rewrite notin_setE /= in_itv /= => /negP. + rewrite negb_and -!ltNge => /orP[z0|z1]. + by rewrite /beta_nat_pdf /ubeta_nat_pdf leNgt z0/= mul0r mule0. + by rewrite /beta_nat_pdf /ubeta_nat_pdf (leNgt z) z1/= andbF mul0r mule0. +rewrite (@integral_bernoulli_beta_nat_pdf (fun x => (1 - x) ^+ 3)%R U (1 / 11))//=; last 3 first. + by apply: measurable_fun_pow => //; exact: measurable_funB. + move=> z. + rewrite inE/= in_itv/= => /andP[z0 z1]. + rewrite exprn_ge0 ?subr_ge0//= exprn_ile1// ?subr_ge0//. + by rewrite lerBlDr addrC -lerBlDr subrr. + transitivity (beta_nat_bernoulli 6 4 0 3 U : \bar R). + rewrite /beta_nat_bernoulli /ubeta_nat_pdf/= /onem. + rewrite [RHS]integral_beta_nat//; last 2 first. + apply: (measurableT_comp (measurable_bernoulli2 _)) => //. + apply: measurable_fun_if => //. + apply: measurable_and => //. + apply: (measurable_fun_bool true) => //=. + rewrite (_ : _ @^-1` _ = `[0%R, +oo[%classic)//. + by apply/seteqP; split => [z|z] /=; rewrite in_itv/= andbT. + apply: (measurable_fun_bool true) => //=. + by rewrite (_ : _ @^-1` _ = `]-oo, 1%R]%classic). + apply: measurable_funTS; apply: measurable_funM => //. + apply: measurable_fun_pow => //. + by apply: measurable_funB => //. + rewrite (le_lt_trans _ (integral_beta_bernoulli_expn_lty 3 6 4 U))//. + rewrite integral_mkcond /=; apply: ge0_le_integral => //=. + by move=> z _; rewrite patchE expr0 mul1r; case: ifPn. + apply: (measurable_restrict _ _ _ _).1 => //. + apply: measurable_funTS; apply: measurableT_comp => //=. + apply: (measurableT_comp (measurable_bernoulli2 _)) => //=. + apply: measurable_fun_if => //=. + apply: measurable_and => //. + apply: (measurable_fun_bool true) => //=. + rewrite (_ : _ @^-1` _ = `[0%R, +oo[%classic)//. + by apply/seteqP; split => [z|z] /=; rewrite in_itv/= andbT. + apply: (measurable_fun_bool true) => //=. + by rewrite (_ : _ @^-1` _ = `]-oo, 1%R]%classic). + apply: measurable_funTS; apply: measurable_funM => //. + by apply: measurable_fun_pow => //; exact: measurable_funB. + by apply/measurableT_comp => //; exact: measurable_bernoulli_expn. + move=> z _; rewrite patchE; case: ifPn => //. + by rewrite inE/= in_itv /= => ->; rewrite expr0 mul1r. + by move=> _; exact: abse_ge0. + apply: eq_integral => z z01. + rewrite inE/= in_itv/= in z01. + by rewrite z01 expr0 mul1r. + rewrite beta_nat_bernE//= bernoulliE_ext//=; last first. + by rewrite div_beta_nat_norm_ge0// div_beta_nat_norm_le1. + rewrite probability_setT. + by congr (_ * _ + _ * _)%:E; rewrite /onem; + rewrite /div_beta_nat_norm !beta_nat_normE/= !factE/=; field. +congr (_ * _ + _ * _)%E. + by rewrite probability_setT -EFinD; congr EFin; lra. +by congr _%:E; rewrite /onem; lra. +Qed. + +Lemma normalize_score_bernoulli g p q (p0 : (0 < p)%R) (q01 : (0 <= q <= 1)%R) : + @execD R g _ [Normalize let "_" := Score {p}:R in + Sample {exp_bernoulli [{q}:R]}] = + execD [Normalize Sample {exp_bernoulli [{q}:R]}]. +Proof. +apply: eq_execD. +rewrite !execD_normalize_pt/= !execP_letin !execP_score. +rewrite !execP_sample !execD_bernoulli !execD_real/=. +apply: funext=> x. +apply: eq_probability=> /= y. +rewrite !normalizeE/=. +rewrite !bernoulliE_ext//=; [|lra..]. +rewrite !diracT !mule1 -EFinD add_onemK onee_eq0/=. +rewrite !letin'E. +under eq_integral. + move=> x0 _ /=. + rewrite !bernoulliE_ext//=; [|lra..]. + rewrite !diracT !mule1 -EFinD add_onemK. + over. +rewrite !ge0_integral_mscale//= (ger0_norm (ltW p0))//. +rewrite integral_dirac// !diracT !indicT /= !mule1. +rewrite gt_eqF ?lte_fin//=. +rewrite integral_dirac//= diracT !mul1e !mulr1. +rewrite addrCA subrr addr0 invr1 mule1. +rewrite !bernoulliE_ext//=; [|lra..]. +by rewrite muleAC -EFinM divff// ?gt_eqF// mul1r EFinD. +Qed. + +Lemma casino45 : execD casino4 = execD casino5. +Proof. by rewrite normalize_score_bernoulli//; lra. Qed. + +Lemma casino : projT1 (execD casino0) tt = projT1 (execD casino5) tt. +Proof. +by rewrite casino01 casino12 casino22' casino23 casino34 casino45. +Qed. + +End casino_example. diff --git a/theories/lebesgue_integral.v b/theories/lebesgue_integral.v index 2adb25c0e..451e8a314 100644 --- a/theories/lebesgue_integral.v +++ b/theories/lebesgue_integral.v @@ -5261,7 +5261,7 @@ rewrite ge0_integralZl//; last by rewrite lee_fin. - by move=> y _; rewrite lee_fin. Qed. -Lemma sfun_measurable_fun_fubini_tonelli_F : measurable_fun setT F. +Lemma sfun_measurable_fun_fubini_tonelli_F : measurable_fun [set: T1] F. Proof. rewrite sfun_fubini_tonelli_FE//; apply: emeasurable_fun_fsum => // r. exact/measurable_funeM/measurable_fun_xsection. diff --git a/theories/lebesgue_measure.v b/theories/lebesgue_measure.v index 84fc74379..b76c58aef 100644 --- a/theories/lebesgue_measure.v +++ b/theories/lebesgue_measure.v @@ -1694,7 +1694,7 @@ have [Y0|Y0] := boolP (0%E \in Y). apply/seteqP; split => [//= r /= YrU|r]. move/mem_set; move: YrU; rewrite diracE. case: (_ \in _) => //=. - move/mem_set. + move/mem_set. by rewrite (negbTE Y1). move/mem_set. rewrite inE/=. diff --git a/theories/measure.v b/theories/measure.v index b2846071d..847202423 100644 --- a/theories/measure.v +++ b/theories/measure.v @@ -1677,6 +1677,18 @@ HB.instance Definition _ := Content_isMeasure.Build d T R mu measure_semi_sigma_additive. HB.end. +(*Lemma eq_measure d (T : measurableType d) (R : realFieldType) + (m1 m2 : {measure set T -> \bar R}) : + (forall U, measurable U -> m1 U = m2 U) -> m1 = m2. +Proof. +move: m1 m2 => [m1 [[m10 m1ge0 [m1sa]]]] [m2 [[m20 m2ge0 [m2sa]]]] /= m1m2. +have : forall U : set T, measurable U. + move=> U. + +rewrite -{}m1m2 => m10' m1ge0' m1sa'; f_equal. +by rewrite (_ : m10' = m10)// (_ : m1ge0' = m1ge0)// (_ : m1sa' = m1sa). +Qed.*) + Lemma eq_measure d (T : measurableType d) (R : realFieldType) (m1 m2 : {measure set T -> \bar R}) : (m1 = m2 :> (set T -> \bar R)) -> m1 = m2. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 04cdcb5c0..0300613dd 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -5,38 +5,49 @@ From mathcomp Require Import rat. From mathcomp Require Import mathcomp_extra boolp classical_sets. From mathcomp Require Import functions cardinality fsbigop. Require Import reals ereal signed topology normedtype sequences esum measure. -Require Import charge lebesgue_measure numfun lebesgue_integral exp kernel. +Require Import lebesgue_measure numfun lebesgue_integral exp kernel. From mathcomp Require Import ring lra. (**md**************************************************************************) (* # Semantics of a probabilistic programming language using s-finite kernels *) -(* bernoulli p1 == Bernoulli probability with p1 a proof that *) -(* p : {nonneg R} is smaller than 1 *) -(* bernoulli_trunc r == Bernoulli probability with real number r *) -(* bino_term n k p == $\binom{n}{k}p^k (1-p)^(n-k)$ *) -(* Computes a binomial distribution term for *) -(* k successes in n trials with success rate p *) -(* binomial_probability n p1 == binomial probability with n and p1 a proof *) -(* that p : {nonneg R} is smaller than 1 *) -(* binomial_probability_trunc n r == binomial probability with n and real *) -(* number r *) -(* uniform_probability a b ab0 == uniform probability over the interval [a,b] *) -(* sample mP == sample according to the probability P where mP is a *) -(* proof that P is a measurable function *) -(* letin l k == execute l, augment the context, and execute k *) -(* ret mf == access the context with f and return the result *) -(* score mf == observe t from d, where f is the density of d and *) -(* t occurs in f *) -(* e.g., score (r e^(-r * t)) = observe t from exp(r) *) -(* normalize k P == normalize the kernel k into a probability kernel, *) -(* P is a default probability in case normalization is *) -(* not possible *) -(* ite mf k1 k2 == access the context with the boolean function f and *) -(* behaves as k1 or k2 according to the result *) (* *) -(* poisson == Poisson distribution function *) -(* exp_density == density function for exponential distribution *) +(* Reference: *) +(* - R. Affeldt, C. Cohen, A. Saito. Semantics of probabilistic programs *) +(* using s-finite kernels in Coq. CPP 2023 *) (* *) +(* ``` *) +(* bernoulli_pmf p == Bernoulli pmf *) +(* bernoulli p == Bernoulli probability measure when 0 <= p <= 1 *) +(* binomial_pmf n p == binomial pmf *) +(* binomial_prob n p == binomial probability measure when 0 <= p <= 1 *) +(* bin_prob n k p == $\binom{n}{k}p^k (1-p)^(n-k)$ *) +(* Computes a binomial distribution term for *) +(* k successes in n trials with success rate p *) +(* uniform_pdf a b == uniform pdf *) +(* uniform_prob a b ab0 == uniform probability over the interval [a,b] *) +(* with ab0 a proof that 0 < b - a *) +(* poisson_pdf == Poisson pdf *) +(* exponential_pdf == exponential distribution pdf *) +(* *) +(* sample mP == sample according to the probability P where mP is *) +(* a proof that P is a measurable function *) +(* sample_cst P == sample according to the probability P *) +(* letin l k == execute l, augment the context, and execute k *) +(* ret mf == access the context with f and return the result *) +(* score mf == observe t from d, where f is the density of d and *) +(* t occurs in f *) +(* e.g., score (r e^(-r * t)) = observe t from exp(r) *) +(* normalize k P == normalize the kernel k into a probability kernel, *) +(* P is a default probability in case normalization *) +(* is not possible *) +(* ite mf k1 k2 == access the context with the boolean function f and *) +(* behaves as k1 or k2 according to the result *) +(* case_nat == case analysis on the nat datatype *) +(* *) +(* mkswap k == given a kernel k : (Y * X) ~> Z, *) +(* returns a kernel of type (X * Y) ~> Z *) +(* letin' := mkcomp \o mkswap *) +(* ``` *) (******************************************************************************) Set Implicit Arguments. @@ -49,28 +60,7 @@ Local Open Scope classical_set_scope. Local Open Scope ring_scope. Local Open Scope ereal_scope. -(* Definition mR (R : realType) : Type := R. -HB.instance Definition _ (R : realType) := Measurable.on (mR R). -(* [the measurableType (R.-ocitv.-measurable).-sigma of - salgebraType (R.-ocitv.-measurable)]. *) *) - -Module Notations. -(*Notation var1of2 := (@measurable_fst _ _ _ _). -Notation var2of2 := (@measurable_snd _ _ _ _). -Notation var1of3 := (measurableT_comp (@measurable_fst _ _ _ _) - (@measurable_fst _ _ _ _)). -Notation var2of3 := (measurableT_comp (@measurable_snd _ _ _ _) - (@measurable_fst _ _ _ _)). -Notation var3of3 := (@measurable_snd _ _ _ _).*) - -(* Definition mR R := [the measurableType (R.-ocitv.-measurable).-sigma of - salgebraType (R.-ocitv.-measurable)]. *) -Notation munit := Datatypes_unit__canonical__measure_Measurable. -Notation mbool := Datatypes_bool__canonical__measure_Measurable. -Notation mnat := Datatypes_nat__canonical__measure_Measurable. -End Notations. - -(* TODO: PR *) +(* TODO: PR? *) Lemma onem_nonneg_proof (R : numDomainType) (p : {nonneg R}) : (p%:num <= 1 -> 0 <= `1-(p%:num))%R. Proof. by rewrite /onem/= subr_ge0. Qed. @@ -78,16 +68,24 @@ Proof. by rewrite /onem/= subr_ge0. Qed. Definition onem_nonneg (R : numDomainType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R) := NngNum (onem_nonneg_proof p1). -(* /TODO: PR *) - -Lemma invr_nonneg_proof (R : numDomainType) (p : {nonneg R}) : - (0 <= (p%:num)^-1)%R. -Proof. by rewrite invr_ge0. Qed. +(* /TODO: PR? *) -Definition invr_nonneg (R : numDomainType) (p : {nonneg R}) := - NngNum (invr_nonneg_proof p). +Lemma nneseries_sum_bigcup {R : realType} (T : choiceType) (F : (set T)^nat) + (f : T -> \bar R) : + trivIset [set: nat] F -> + (forall i, 0 <= f i)%E -> + (\esum_(i in \bigcup_n F n) f i)%R = + \big[+%R/0%R]_(0 <= i (*finUF*) tF f0. +rewrite esum_bigcupT//. +rewrite nneseries_esum//; last first. + move=> k _. + by apply: esum_ge0. +rewrite fun_true. +by apply: eq_esum => /= i _. +Qed. -(* TODO: move *) Lemma eq_probability R d (Y : measurableType d) (m1 m2 : probability Y R) : (m1 =1 m2 :> (set Y -> \bar R)) -> m1 = m2. Proof. @@ -113,48 +111,74 @@ subst p2. by f_equal. Qed. -Section constants. -Variable R : realType. +Definition dep_uncurry (A : Type) (B : A -> Type) (C : Type) : + (forall a : A, B a -> C) -> {a : A & B a} -> C := + fun f p => let (a, Ba) := p in f a Ba. + +Section bernoulli_pmf. +Context {R : realType} (p : R). Local Open Scope ring_scope. -Lemma onem1S n : `1- (1 / n.+1%:R) = (n%:R / n.+1%:R)%:nng%:num :> R. +Definition bernoulli_pmf b := if b then p else 1 - p. + +Lemma bernoulli_pmf_ge0 (p01 : 0 <= p <= 1) b : 0 <= bernoulli_pmf b. Proof. -by rewrite /onem/= -{1}(@divrr _ n.+1%:R) ?unitfE// -mulrBl -natr1 addrK. +rewrite /bernoulli_pmf. +by move: p01 => /andP[p0 p1]; case: ifPn => // _; rewrite subr_ge0. Qed. -Lemma p1S n : (1 / n.+1%:R)%:nng%:num <= 1 :> R. -Proof. by rewrite ler_pdivrMr//= mul1r ler1n. Qed. +Lemma bernoulli_pmf1 (p01 : 0 <= p <= 1) : + \sum_(i \in [set: bool]) (bernoulli_pmf i)%:E = 1%E. +Proof. +rewrite setT_bool fsbigU//=; last by move=> x [/= ->]. +by rewrite !fsbig_set1/= -EFinD addrCA subrr addr0. +Qed. -Lemma p12 : (1 / 2%:R)%:nng%:num <= 1 :> R. Proof. by rewrite p1S. Qed. +End bernoulli_pmf. -Lemma p14 : (1 / 4%:R)%:nng%:num <= 1 :> R. Proof. by rewrite p1S. Qed. +Definition bernoulli {R : realType} (p : R) : set bool -> \bar R := fun A => + if (0 <= p <= 1)%R then \sum_(b \in A) (bernoulli_pmf p b)%:E else \d_false A. -Lemma onem27 : `1- (2 / 7%:R) = (5%:R / 7%:R)%:nng%:num :> R. -Proof. by apply/eqP; rewrite subr_eq/= -mulrDl -natrD divrr// unitfE. Qed. +Section bernoulli. +Context {R : realType} (p : R). -Lemma p27 : (2 / 7%:R)%:nng%:num <= 1 :> R. -Proof. by rewrite /= lter_pdivrMr// mul1r ler_nat. Qed. +Local Notation bernoulli := (bernoulli p). -End constants. -Arguments p12 {R}. -Arguments p14 {R}. -Arguments p27 {R}. -Arguments p1S {R}. +Let bernoulli0 : bernoulli set0 = 0. +Proof. +by rewrite /bernoulli; case: ifPn => // p01; rewrite fsbig_set0. +Qed. -Section bernoulli. -Variables (R : realType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R). +Let bernoulli_ge0 U : (0 <= bernoulli U)%E. +Proof. +rewrite /bernoulli; case: ifPn => // p01. +rewrite fsbig_finite//= sumEFin lee_fin. +by apply: sumr_ge0 => /= b _; exact: bernoulli_pmf_ge0. +Qed. -Definition bernoulli : set bool -> \bar R := - measure_add - [the measure _ _ of mscale p [the measure _ _ of dirac true]] - [the measure _ _ of mscale (onem_nonneg p1) [the measure _ _ of dirac false]]. +Let bernoulli_sigma_additive : semi_sigma_additive bernoulli. +Proof. +move=> F mF tF mUF; rewrite /bernoulli; case: ifPn => p01; last first. + exact: measure_semi_sigma_additive. +apply: cvg_toP. + apply: ereal_nondecreasing_is_cvgn => m n mn. + apply: lee_sum_nneg_natr => // k _ _. + rewrite fsbig_finite//= sumEFin lee_fin. + by apply: sumr_ge0 => /= b _; exact: bernoulli_pmf_ge0. +transitivity (\big[+%R/0%R]_(0 <= i k _; rewrite esum_fset//= => b _. + by rewrite lee_fin bernoulli_pmf_ge0. +rewrite -nneseries_sum_bigcup//=; last by move=> b; rewrite lee_fin bernoulli_pmf_ge0. +by rewrite esum_fset//= => b _; rewrite lee_fin bernoulli_pmf_ge0. +Qed. -HB.instance Definition _ := Measure.on bernoulli. +HB.instance Definition _ := isMeasure.Build _ _ _ bernoulli + bernoulli0 bernoulli_ge0 bernoulli_sigma_additive. Let bernoulli_setT : bernoulli [set: _] = 1. Proof. -rewrite /bernoulli/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. -by rewrite /mscale/= !diracT !mule1 -EFinD add_onemK. +rewrite /bernoulli/=; case: ifPn => p01; last by rewrite probability_setT. +by rewrite bernoulli_pmf1. Qed. HB.instance Definition _ := @@ -162,75 +186,67 @@ HB.instance Definition _ := End bernoulli. -Lemma integral_bernoulli {R : realType} (p : {nonneg R}) (p1 : (p%:num <= 1)%R) - (f : bool -> \bar R) : (forall x, 0 <= f x) -> - \int[bernoulli p1]_y (f y) = - p%:num%:E * f true + (`1-(p%:num))%:E * f false. -Proof. -move=> f0. -rewrite ge0_integral_measure_sum// 2!big_ord_recl/= big_ord0 adde0/=. -by rewrite !ge0_integral_mscale//= !integral_dirac//= !diracT !mul1e. -Qed. - -Section bernoulli_trunc. -Variables (R : realType). -Local Open Scope ring_scope. +Section bernoulli_measure. +Context {R : realType}. +Variables (p : R) (p0 : (0 <= p)%R) (p1 : ((NngNum p0)%:num <= 1)%R). -Lemma sumbool_ler (x y : R) : (x <= y)%R + (x > y)%R. +Lemma bernoulliE : bernoulli p = measure_add + (mscale (NngNum p0) (dirac true)) (mscale (onem_nonneg p1) (dirac false)). Proof. -have [_|_] := leP x y. -by apply (*left*) inl. -by apply (*right*) inr. -Qed. - -(* TODO: move? *) -Definition dep_uncurry := -(fun (A : Type) (B : A -> Type) (C : Type) (f : forall a : A, B a -> C) (p : {a : A & B a}) => let (a, Ba) := p in f a Ba) : -forall [A : Type] [B : A -> Type] [C : Type], -(forall a : A, B a -> C) -> {a : A & B a} -> C. - -Definition bernoulli0 := @bernoulli R 0%R%:nng ler01. - -HB.instance Definition _ := Probability.on bernoulli0. +apply/funext => U; rewrite /bernoulli; case: ifPn => [p01|]; last first. + by rewrite p0/= p1. +rewrite measure_addE/= /mscale/=. +have := @subsetT _ U; rewrite setT_bool => UT. +have [->|->|->|->] /= := subset_set2 UT. +- rewrite -esum_fset//=; last by move=> b; rewrite lee_fin bernoulli_pmf_ge0. + by rewrite esum_set0 2!measure0 2!mule0 adde0. +- rewrite -esum_fset//=; last by move=> b; rewrite lee_fin bernoulli_pmf_ge0. + rewrite esum_set1/= ?lee_fin// 2!diracE mem_set//= memNset//= mule0 adde0. + by rewrite mule1. +- rewrite -esum_fset//=; last by move=> b; rewrite lee_fin bernoulli_pmf_ge0. + rewrite esum_set1/= ?lee_fin ?subr_ge0// 2!diracE memNset//= mem_set//=. + by rewrite mule0 add0e mule1. +- rewrite fsbigU//=; last by move=> x [->]. + by rewrite 2!fsbig_set1/= -setT_bool 2!diracT !mule1. +Qed. + +End bernoulli_measure. +Arguments bernoulli {R}. + +Section integral_bernoulli. +Context {R : realType}. +Variables (p : R) (p01 : (0 <= p <= 1)%R). -Definition bernoulli_trunc (p : R) := match sumbool_ler 0%R p with -| inl l0p => match sumbool_ler (NngNum l0p)%:num 1%R with - | inl lp1 => [the probability _ _ of @bernoulli R (NngNum l0p) lp1] - | inr _ => bernoulli0 - end -| inr _ => bernoulli0 -end. +Lemma bernoulliE_ext A : + bernoulli p A = p%:E * \d_true A + (`1-p)%:E * \d_false A. +Proof. by case/andP : p01 => p0 p1; rewrite bernoulliE// measure_addE. Qed. -Lemma bernoulli_truncE (p : R) U : - (0 <= p <= 1)%R -> - (bernoulli_trunc p U = - p%:E * \d_true U + (`1-p)%:E * \d_false U)%E. +Lemma integral_bernoulli (f : bool -> \bar R) : (forall x, 0 <= f x) -> + \int[bernoulli p]_y (f y) = p%:E * f true + (`1-p)%:E * f false. Proof. -move=> /andP[p0 p1]. -rewrite /bernoulli_trunc. -case: (sumbool_ler 0 p) => [{}p0/=|]. - case: (sumbool_ler p 1) => [{}p1/=|]. - by rewrite /bernoulli/= measure_addE. - by rewrite ltNge p1. -by rewrite ltNge p0. +move=> f0; case/andP : p01 => p0 p1. +rewrite bernoulliE/=. +rewrite ge0_integral_measure_sum// 2!big_ord_recl/= big_ord0 adde0/=. +by rewrite !ge0_integral_mscale//= !integral_dirac//= !diracT !mul1e. Qed. -(* HB.instance Definition _ (p : R) := Probability.on (bernoulli_trunc p). *) +End integral_bernoulli. -Let simpe := (@mule0 R, @adde0 R, @mule1 R, @add0e R). +Section measurable_bernoulli. +Local Open Scope ring_scope. +Variable R : realType. +Implicit Type p : R. -Lemma measurable_bernoulli_trunc : - measurable_fun setT (bernoulli_trunc : _ -> pprobability _ _). +Lemma measurable_bernoulli : + measurable_fun setT (bernoulli : R -> pprobability bool R). Proof. apply: (@measurability _ _ _ _ _ _ (@pset _ _ _ : set (set (pprobability _ R)))) => //. move=> _ -[_ [r r01] [Ys mYs <-]] <-; apply: emeasurable_fun_infty_o => //=. -rewrite /bernoulli_trunc/=. -have := @subsetT _ Ys; rewrite setT_bool => UT. +rewrite /bernoulli; have := @subsetT _ Ys; rewrite setT_bool => UT. have [->|->|->|->] /= := subset_set2 UT. - rewrite [X in measurable_fun _ X](_ : _ = cst 0%E)//. - apply/funext => x/=. - by case: sumbool_ler. + by apply/funext => x/=; case: ifPn => // _; rewrite fsbig_set0. - rewrite [X in measurable_fun _ X](_ : _ = (fun x => if 0 <= x <= 1 then x%:E else 0%E))//. apply: measurable_fun_ifT => //=; apply: measurable_and => //; @@ -238,339 +254,380 @@ have [->|->|->|->] /= := subset_set2 UT. rewrite (_ : _ @^-1` _ = `[0, +oo[%classic)//. by apply/seteqP; split => [x|x] /=; rewrite in_itv/= andbT. by rewrite (_ : _ @^-1` _ = `]-oo, 1]%classic). - apply/funext => x/=; case: sumbool_ler => /= x0. - case: sumbool_ler => /= x1. - rewrite /bernoulli/= /measure_add/= /msum/= !big_ord_recl//= big_ord0//=. - by rewrite /mscale/= !diracE mem_set//= memNset//= ?simpe x0 x1. - rewrite /bernoulli0 /bernoulli/= /measure_add/= /msum/= !big_ord_recl//= big_ord0//=. - by rewrite /mscale/= !diracE mem_set//= memNset//= ?simpe x0/= leNgt x1. - rewrite /bernoulli0 /bernoulli/= /measure_add/= /msum/= !big_ord_recl//= big_ord0//=. - by rewrite /mscale/= !diracE mem_set//= memNset//= ?simpe leNgt x0. + apply/funext => x/=; case: ifPn => /= x01. + by rewrite fsbig_set1//= lee_fin; case/andP : x01. + by rewrite diracE memNset//. - rewrite [X in measurable_fun _ X](_ : _ = (fun x => if 0 <= x <= 1 then (`1-x)%:E else 1%E))//. apply: measurable_fun_ifT => //=. apply: measurable_and => //; apply: (measurable_fun_bool true) => //=. - rewrite (_ : _ @^-1` _ = `[0, +oo[%classic)//. - by apply/seteqP; split => [x|x] /=; rewrite in_itv/= andbT. - by rewrite (_ : _ @^-1` _ = `]-oo, 1]%classic). - by apply/EFin_measurable_fun; apply/measurable_funB. - apply/funext => x/=; case: sumbool_ler => /= x0. - case: sumbool_ler => /= x1. - rewrite /bernoulli/= /measure_add/= /msum/= !big_ord_recl//= big_ord0//=. - by rewrite /mscale/= !diracE memNset//= mem_set//= ?simpe x0 x1/=. - rewrite /bernoulli0 /bernoulli/= /measure_add/= /msum/= !big_ord_recl//= big_ord0//=. - by rewrite /mscale/= !diracE memNset//= mem_set//= ?simpe x0/= leNgt x1/= onem0. - rewrite /bernoulli0. - rewrite /bernoulli/= /measure_add/= /msum/= !big_ord_recl//= big_ord0//=. - by rewrite /mscale/= !diracE memNset//= mem_set//= leNgt x0/= ?simpe onem0. + rewrite (_ : _ @^-1` _ = `[0, +oo[%classic)//. + by apply/seteqP; split => [x|x] /=; rewrite in_itv/= andbT. + by rewrite (_ : _ @^-1` _ = `]-oo, 1]%classic). + exact/EFin_measurable_fun/measurable_funB. + apply/funext => x/=; case: ifPn => /= x01. + by rewrite fsbig_set1//= lee_fin subr_ge0; case/andP : x01. + by rewrite diracE mem_set. - rewrite [X in measurable_fun _ X](_ : _ = cst 1%E)//; apply/funext => x/=. - case: sumbool_ler => /= x0. - case: sumbool_ler => /= x1. - rewrite /bernoulli/= /measure_add/= /msum/= !big_ord_recl//= big_ord0//=. - rewrite /mscale/= !diracE mem_set//=; last by left. - rewrite mem_set//=; last by right. - by rewrite ?simpe -EFinD add_onemK. - rewrite /bernoulli0. - rewrite /bernoulli/= /measure_add/= /msum/= !big_ord_recl//= big_ord0//=. - rewrite /mscale/= !diracE mem_set//=; last by left. - rewrite mem_set//=; last by right. - by rewrite ?simpe onem0. - rewrite /bernoulli0. - rewrite /bernoulli/= /measure_add/= /msum/= !big_ord_recl//= big_ord0//=. - rewrite /mscale/= !diracE mem_set//=; last by left. - rewrite mem_set//=; last by right. - by rewrite ?simpe onem0. -Qed. - -End bernoulli_trunc. - -Arguments bernoulli_trunc {R}. -Arguments measurable_bernoulli_trunc {R}. - -Lemma integral_bernoulli_trunc {R : realType} (p : R) (f : bool -> \bar R) : - (0 <= p <= 1)%R -> (forall x, 0 <= f x) -> - \int[bernoulli_trunc p]_y (f y) = p%:E * f true + (`1-p)%:E * f false. -Proof. -move=> /andP[p0 p1] f0; rewrite /bernoulli_trunc. -case: sumbool_ler => [? /=|]. - case: (sumbool_ler p 1) => [? /=|]. - by rewrite integral_bernoulli. - by rewrite ltNge p1. -by rewrite ltNge p0. + by rewrite -setT_bool diracT; case: ifPn => // x01; rewrite bernoulli_pmf1. Qed. -Section binomial_probability. -Context {R : realType} (n : nat) (p : {nonneg R}) (p1 : (p%:num <= 1)%R). +Lemma measurable_bernoulli2 U : measurable U -> + measurable_fun setT (bernoulli ^~ U : R -> \bar R). +Proof. +by move=> ?; exact: (measurable_kernel (kprobability measurable_bernoulli)). +Qed. + +End measurable_bernoulli. +Arguments measurable_bernoulli {R}. + +Section binomial_pmf. Local Open Scope ring_scope. +Context {R : realType} (n : nat) (p : R). -(* C(n, k) * p^k * (1-p)^(n-k) *) -Definition bino_term (k : nat) : {nonneg R} := - (p%:num^+k * (NngNum (onem_ge0 p1))%:num^+(n-k)%N *+ 'C(n, k))%:nng. +Definition binomial_pmf k := p ^+ k * (`1-p) ^+ (n - k) *+ 'C(n, k). -Lemma bino_term0 : - bino_term 0 = ((NngNum (onem_ge0 p1))%:num^+n)%:nng. +Lemma binomial_pmf_ge0 k (p01 : (0 <= p <= 1)%R) : 0 <= binomial_pmf k. Proof. -rewrite /bino_term bin0 subn0/=. -apply/val_inj => /=. -by field. +move: p01 => /andP[p0 p1]. +rewrite /binomial_pmf mulrn_wge0// mulr_ge0// ?exprn_ge0//. +exact: onem_ge0. Qed. -Lemma bino_term1 : - bino_term 1 = (p%:num * (NngNum (onem_ge0 p1))%:num^+(n-1)%N *+ n)%:nng. -Proof. -rewrite /bino_term bin1/=. -apply/val_inj => /=. -by rewrite expr1. -Qed. +End binomial_pmf. -Import Notations. +Definition binomial_prob {R : realType} (n : nat) (p : R) : set nat -> \bar R := + fun U => if (0 <= p <= 1)%R then + \esum_(k in U) (binomial_pmf n p k)%:E else \d_O U. -(* Check \sum_(k < n.+1) (fun k => [the measure _ _ of mscale (bino_term k) - [the measure _ _ of \d_k]]). *) -(* \sum_(k < n.+1) (bino_coef p n k) * \d_k. *) -Definition binomial_probability : set nat -> \bar R := - @msum _ _ R (fun k => mscale (bino_term k) \d_k) n.+1. +Section binomial. +Context {R : realType} (n : nat) (p : R). -HB.instance Definition _ := Measure.on binomial_probability. +Local Notation binomial := (binomial_prob n p). -Let binomial_setT : binomial_probability [set: _] = 1%:E. +Let binomial0 : binomial set0 = 0. Proof. -rewrite /binomial_probability/msum/mscale/bino_term/=/mscale/=. -under eq_bigr do rewrite diracT mule1. -rewrite sumEFin. -under eq_bigr=> i _. - rewrite mulrC. - over. -rewrite -exprDn_comm; last by rewrite /GRing.comm mulrC. -by rewrite addrC add_onemK; congr _%:E; rewrite expr1n. +by rewrite /binomial measure0; case: ifPn => //; rewrite esum_set0. Qed. -HB.instance Definition _ := - @Measure_isProbability.Build _ _ R binomial_probability binomial_setT. - -End binomial_probability. - -Section integral_binomial. -Variables (R : realType) (d : measure_display) (T : measurableType d). - -Lemma integral_binomial (n : nat) (p : {nonneg R}) - (p1 : (p%:num <= 1)%R) (f : nat -> \bar R) - (mf : measurable_fun setT f) : - (forall x, 0 <= f x) -> \int[binomial_probability n p1]_y (f y) = - \sum_(k < n.+1) (bino_term n p1 k)%:num%:E * f k. +Let binomial_ge0 U : 0 <= binomial U. Proof. -move=> f0; rewrite ge0_integral_measure_sum//=; apply: eq_bigr => i _. -by rewrite ge0_integral_mscale//= integral_dirac//= diracT mul1e. +rewrite /binomial; case: ifPn => // p01. +apply: esum_ge0 => /= k Uk. +by rewrite lee_fin binomial_pmf_ge0. Qed. -End integral_binomial. +Let binomial_sigma_additive : semi_sigma_additive binomial. +Proof. +move=> F mF tF mUF; rewrite /binomial; case: ifPn => p01; last first. + exact: measure_semi_sigma_additive. +apply: cvg_toP. + apply: ereal_nondecreasing_is_cvgn => a b ab. + apply: lee_sum_nneg_natr => // k _ _. + by apply: esum_ge0 => /= ? _; exact: binomial_pmf_ge0. +rewrite nneseries_sum_bigcup// => i. +by rewrite lee_fin binomial_pmf_ge0. +Qed. -(* X + Y is a measurableType if X and Y are *) -HB.instance Definition _ (X Y : pointedType) := - isPointed.Build (X + Y)%type (@inl X Y point). +HB.instance Definition _ := isMeasure.Build _ _ _ binomial + binomial0 binomial_ge0 binomial_sigma_additive. -Section measurable_sum. -Context d d' (X : measurableType d) (Y : measurableType d'). +Let binomial_setT : binomial [set: _] = 1. +Proof. +rewrite /binomial; case: ifPn; last by move=> _; rewrite probability_setT. +move=> p01; rewrite /binomial_pmf. +have ? : forall k, 0%R <= (p ^+ k * `1-p ^+ (n - k) *+ 'C(n, k))%:E. + move=> k; case/andP : p01 => p1 p2. + by rewrite lee_fin mulrn_wge0// mulr_ge0 ?exprn_ge0 ?subr_ge0. +rewrite (esumID (`I_n.+1))// [X in _ + X]esum1 ?adde0; last first. + by move=> /= k [_ /negP]; rewrite -leqNgt => nk; rewrite bin_small. +rewrite setTI esum_fset// -fsbig_ord//=. +under eq_bigr do rewrite mulrC. +rewrite sumEFin -exprDn_comm; last exact: mulrC. +by rewrite subrK expr1n. +Qed. -Definition measurable_sum : set (set (X + Y)) := setT. +HB.instance Definition _ := + @Measure_isProbability.Build _ _ R binomial binomial_setT. -Let sum0 : measurable_sum set0. Proof. by []. Qed. +End binomial. -Let sumC A : measurable_sum A -> measurable_sum (~` A). Proof. by []. Qed. +Section binomial_probability. +Local Open Scope ring_scope. +Context {R : realType} (n : nat) (p : R) (p0 : (0 <= p)%R) (p1 : ((NngNum p0)%:num <= 1)%R). -Let sumU (F : (set (X + Y))^nat) : (forall i, measurable_sum (F i)) -> - measurable_sum (\bigcup_i F i). -Proof. by []. Qed. +Definition bin_prob (k : nat) : {nonneg R} := + ((NngNum p0)%:num^+k * (NngNum (onem_ge0 p1))%:num^+(n-k)%N *+ 'C(n, k))%:nng. -HB.instance Definition _ := @isMeasurable.Build default_measure_display (X + Y)%type - measurable_sum sum0 sumC sumU. +Lemma bin_prob0 : bin_prob 0 = ((NngNum (onem_ge0 p1))%:num^+n)%:nng. +Proof. +rewrite /bin_prob bin0 subn0/=; apply/val_inj => /=. +by rewrite expr0 mul1r mulr1n. +Qed. -End measurable_sum. +Lemma bin_prob1 : + bin_prob 1 = ((NngNum p0)%:num * (NngNum (onem_ge0 p1))%:num^+(n-1)%N *+ n)%:nng. +Proof. by rewrite /bin_prob bin1/=; apply/val_inj => /=; rewrite expr1. Qed. -Lemma measurable_fun_sum dA dB d' (A : measurableType dA) (B : measurableType dB) - (Y : measurableType d') (f : A -> Y) (g : B -> Y) : - measurable_fun setT f -> measurable_fun setT g -> - measurable_fun setT (fun tb : A + B => - match tb with inl a => f a | inr b => g b end). +Lemma binomialE : binomial_prob n p = + @msum _ _ R (fun k => mscale (bin_prob k) \d_k) n.+1. Proof. -move=> mx my/= _ Z mZ /=; rewrite setTI /=. -rewrite (_ : _ @^-1` Z = inl @` (f @^-1` Z) `|` inr @` (g @^-1` Z)). - exact: measurableU. -apply/seteqP; split. - by move=> [a Zxa|b Zxb]/=; [left; exists a|right; exists b]. -by move=> z [/= [a Zxa <-//=]|]/= [b Zyb <-//=]. +apply/funext => U; rewrite /binomial_prob; case: ifPn => [_|]; last by rewrite p1 p0. +rewrite /msum/= /mscale/= /binomial_pmf. +have ? : forall k, (0%R <= (p ^+ k * `1-p ^+ (n - k) *+ 'C(n, k))%:E)%E. + move=> k. + by rewrite lee_fin mulrn_wge0// mulr_ge0 ?exprn_ge0 ?subr_ge0. +rewrite (esumID (`I_n.+1))// [X in _ + X]esum1 ?adde0; last first. + by move=> /= k [_ /negP]; rewrite -leqNgt => nk; rewrite bin_small. +rewrite esum_mkcondl esum_fset//; last by move=> i /= _; case: ifPn. +rewrite -fsbig_ord//=; apply: eq_bigr => i _. +by rewrite diracE; case: ifPn => /= iU; [rewrite mule1|rewrite mule0]. Qed. -(* TODO: measurable_fun_if_pair -> measurable_fun_if_pair_bool? *) -Lemma measurable_fun_if_pair_nat d d' (X : measurableType d) - (Y : measurableType d') (f g : X -> Y) (n : nat) : - measurable_fun setT f -> measurable_fun setT g -> - measurable_fun setT (fun xn => if xn.2 == n then f xn.1 else g xn.1). +Lemma binomialE_ext U : binomial_prob n p U = + (\sum_(k < n.+1) (bin_prob k)%:num%:E * (\d_(nat_of_ord k) U))%E. +Proof. by rewrite binomialE /msum//=. Qed. + +Lemma integral_binomial (f : nat -> \bar R) : (forall x, 0 <= f x)%E -> + (\int[binomial_prob n p]_y (f y) = \sum_(k < n.+1) (bin_prob k)%:num%:E * f k)%E. Proof. -move=> mx my; apply: measurable_fun_ifT => //=. -- have h : measurable_fun [set: nat] (fun t => t == n) by []. - exact: (@measurableT_comp _ _ _ _ _ _ _ _ _ h). -- exact: measurableT_comp. -- exact: measurableT_comp. +move=> f0; rewrite binomialE ge0_integral_measure_sum//=; apply: eq_bigr => i _. +by rewrite ge0_integral_mscale//= integral_dirac//= diracT mul1e. Qed. -Section binomial_trunc. -Variables (R : realType). -Local Open Scope ring_scope. - -Definition binomial_probability0 := @binomial_probability R 0 0%:nng%R ler01. +End binomial_probability. -Definition binomial_probability_trunc n (p : R) := - match (sumbool_ler 0%R p) with - | inl l0p => match (sumbool_ler (NngNum l0p)%:num 1%R) with - | inl lp1 => [the probability _ _ of @binomial_probability R n (NngNum l0p) lp1] - | inr _ => [the probability _ _ of binomial_probability0] - end - | inr _ => [the probability _ _ of binomial_probability0] - end. +Lemma integral_binomial_bernoulli (R : realType) n p U : + (0 <= p <= 1)%R -> + \int[binomial_prob n p]_y \d_(0 < y)%N U = bernoulli (1 - `1-p ^+ n) U :> \bar R. +Proof. +move=> /andP[p0 p1]. +rewrite bernoulliE_ext//=; last first. + rewrite subr_ge0 exprn_ile1//=; last 2 first. + exact/onem_ge0. + exact/onem_le1. + by rewrite lerBlDr addrC -lerBlDr subrr; exact/exprn_ge0/onem_ge0. +rewrite (@integral_binomial _ n p _ _ (fun y => \d_(1 <= y)%N U))//; last first. +rewrite !big_ord_recl/=. +rewrite /bump. +under eq_bigr => i _. + rewrite /=. + have -> : (0 < 1 + i)%N => //. + over. +rewrite addeC -ge0_sume_distrl. +- congr (_ * _ + _ * _). + + have -> : \sum_(i < n) (p ^+ (1 + i) * `1-p ^+ (n - (1 + i)) *+ 'C(n, 1 + i))%:E = + \sum_(i < n.+1) (p ^+ i * `1-p ^+ (n - i) *+ 'C(n, i))%:E - (`1-p ^+ n)%:E. + rewrite big_ord_recl/= expr0 subn0 mul1r bin0 mulr1n addeC addeA. + by rewrite (addeC _ (_ ^+ n)%:E) EFinN subee// add0e. + rewrite sumEFin !EFinB EFin_expe. + congr (_ - _)%E. + under eq_bigr do rewrite mulrC. + rewrite -(@exprDn_comm _ `1-p p n); last first. + by rewrite /GRing.comm/onem mulrC. + by rewrite /onem subrK expr1n. + + rewrite subn0 expr0 bin0 mulr1n /onem. + by rewrite mul1r opprB addrCA subrr addr0. +- move=> i _. + by apply/mulrn_wge0/mulr_ge0; apply/exprn_ge0 => //; exact/onem_ge0. +Qed. + +Lemma sumbool_ler {R : realDomainType} (x y : R) : (x <= y)%R + (x > y)%R. +Proof. by have [_|_] := leP x y; [exact: inl|exact: inr]. Qed. + +Section binomial_total. +Local Open Scope ring_scope. +Variables (R : realType) (n : nat). +Implicit Type p : R. -Lemma measurable_binomial_probability_trunc (n : nat) - : measurable_fun setT (binomial_probability_trunc n : R -> pprobability _ _). +Lemma measurable_binomial_probT : + measurable_fun setT (binomial_prob n : R -> pprobability _ _). Proof. apply: (@measurability _ _ _ _ _ _ (@pset _ _ _ : set (set (pprobability _ R)))) => //. move=> _ -[_ [r r01] [Ys mYs <-]] <-; apply: emeasurable_fun_infty_o => //=. -rewrite /binomial_probability_trunc/=. +rewrite /binomial_prob/=. set f := (X in measurable_fun _ X). rewrite (_ : f = fun x => if 0 <= x <= 1 then (\sum_(m < n.+1) - match sumbool_ler 0 x with - | inl l0p => - match sumbool_ler x 1 with - | inl lp1 => mscale (@bino_term _ n (NngNum l0p) lp1 m) (\d_(nat_of_ord m)) Ys - | inr _ => (x ^+ m * `1-x ^+ (n - m) *+ 'C(n, m))%:E * \d_(nat_of_ord m) Ys - end - | inr _ => (x ^+ m * `1-x ^+ (n - m) *+ 'C(n, m))%:E * \d_(nat_of_ord m) Ys - end)%E + if sumbool_ler 0 x is inl l0p then + if sumbool_ler x 1 is inl lp1 then + mscale (@bin_prob _ n _ l0p lp1 m) (\d_(nat_of_ord m)) Ys + else + (x ^+ m * `1-x ^+ (n - m) *+ 'C(n, m))%:E * \d_(nat_of_ord m) Ys + else (x ^+ m * `1-x ^+ (n - m) *+ 'C(n, m))%:E * \d_(nat_of_ord m) Ys)%E else \d_0%N Ys)//. - move=> ?; apply: measurable_fun_ifT => //=. + apply: measurable_fun_ifT => //=. apply: measurable_and => //; apply: (measurable_fun_bool true) => //=. rewrite (_ : _ @^-1` _ = `[0, +oo[%classic)//. by apply/seteqP; split => [x|x] /=; rewrite in_itv/= andbT. by rewrite (_ : _ @^-1` _ = `]-oo, 1]%classic). apply: emeasurable_fun_sum => m /=. rewrite /mscale/= [X in measurable_fun _ X](_ : _ = (fun x => - ((x ^+ m * `1-x ^+ (n - m) *+ 'C(n, m))%:E * \d_(nat_of_ord m) Ys)%E)); last first. + (x ^+ m * `1-x ^+ (n - m) *+ 'C(n, m))%:E * \d_(nat_of_ord m) Ys)%E); last first. by apply:funext => x; case: sumbool_ler => // x0; case: sumbool_ler. apply: emeasurable_funM => //; apply/EFin_measurable_fun => //. - under eq_fun do rewrite -mulrnAr. - apply: measurable_funM => //. under eq_fun do rewrite -mulr_natr. - apply: measurable_funM => //=. - apply: measurable_fun_pow. - exact: measurable_funB. -rewrite {}/f. -apply/funext => x. -case: sumbool_ler => /= x0. - case: sumbool_ler => /= x1. - by rewrite /binomial_probability/= /msum /= /bino_term/= x0 x1. - rewrite /binomial_probability /= /msum big_ord_recl/= big_ord0 /mscale. - by rewrite /= expr0 mul1r subnn expr0 bin0 mul1e adde0 !leNgt x1 andbF. -rewrite /binomial_probability /= /msum big_ord_recl/= big_ord0 /mscale. -by rewrite /= expr0 mul1r subnn expr0 bin0 mul1e adde0 !leNgt x0/=. -Qed. - -End binomial_trunc. + do 2 apply: measurable_funM => //. + exact/measurable_fun_pow/measurable_funB. +rewrite {}/f; apply/funext => x. +case: ifPn => // /andP[x0 x1]. +rewrite (esumID `I_n.+1)//; last first. + by move=> k _; rewrite lee_fin// binomial_pmf_ge0// x0. +rewrite [X in (_ + X)%E]esum1 ?adde0; last first. + by move=> k [_ /= /negP]; rewrite -leqNgt => nk; rewrite /binomial_pmf bin_small. +rewrite esum_mkcondl esum_fset//=; last first. + move=> k; rewrite inE/= ltnS => kn. + by case: ifPn => // _; rewrite lee_fin binomial_pmf_ge0// x0. +rewrite -fsbig_ord//=; apply: eq_bigr => i _. +case: ifPn => iYs. + case: sumbool_ler => //= x0'. + case: sumbool_ler => //= x1'. + by rewrite /mscale/= /binomial_pmf diracE iYs mule1. + by move: x1'; rewrite ltNge x1. + by move: x0'; rewrite ltNge x0. +case: sumbool_ler => //= x0'. + case: sumbool_ler => //= x1'. + by rewrite /mscale/= /binomial_pmf diracE (negbTE iYs) mule0. + by move: x1'; rewrite ltNge x1. +by move: x0'; rewrite ltNge x0. +Qed. + +End binomial_total. +Arguments binomial_prob {R}. +Arguments measurable_binomial_probT {R}. -Arguments binomial_probability_trunc {R}. -Arguments measurable_binomial_probability_trunc {R}. +Section uniform_probability. +Local Open Scope ring_scope. +Context (R : realType) (a b : R). -Section integral_binomial_trunc. -Variables (R : realType) (d : measure_display) (T : measurableType d). +Definition uniform_pdf x := if a <= x <= b then (b - a)^-1 else 0. -Import Notations. -Lemma integral_binomial_probabilty_trunc (n : nat) (p : R) - (p0 : (0 <= p)%R) (p1 : ((NngNum p0)%:num <= 1)%R) (f : mnat -> \bar R) - (mf : measurable_fun setT f) : (forall x, 0 <= f x) -> - \int[binomial_probability_trunc n p]_y (f y) = - \sum_(k < n.+1) (bino_term n p1 k)%:num%:E * f k. +Lemma uniform_pdf_ge0 x : a < b -> 0 <= uniform_pdf x. Proof. -move=> f0; rewrite /binomial_probability_trunc/=. -case: sumbool_ler => [? /=|]. - case: sumbool_ler => [?/=|]. - by rewrite integral_binomial. - by rewrite ltNge p1. -by rewrite ltNge p0. +move=> ab; rewrite /uniform_pdf; case: ifPn => // axb. +by rewrite invr_ge0// ltW// subr_gt0. Qed. -End integral_binomial_trunc. - -Section binomial_example. -Context {R : realType}. -Open Scope ring_scope. - -Lemma binomial3_2 : @binomial_probability R 3 _ (p1S 1) [set 2%N] = (3 / 8)%:E. +Lemma measurable_uniform_pdf : measurable_fun setT uniform_pdf. Proof. -rewrite /binomial_probability/msum !big_ord_recl/= big_ord0 adde0 bino_term0. -rewrite /mscale/= !diracE /bump/=. -repeat rewrite ?binS ?bin0 ?bin1 ?bin_small//. -rewrite memNset//=. -rewrite memNset//=. -rewrite mem_set//=. -rewrite memNset//=. -congr _%:E. -rewrite expr0 !mulr1 !mulr0 !add0r !addn0 !add0n /onem. -by field. +rewrite /uniform_pdf /=; apply: measurable_fun_if => //=. +apply: measurable_and => //. + apply: (measurable_fun_bool true) => //=. + rewrite (_ : _ @^-1` _ = `[a, +oo[%classic)//. + by apply/seteqP; split => [z|z] /=; rewrite in_itv/= andbT. +apply: (measurable_fun_bool true) => //=. +by rewrite (_ : _ @^-1` _ = `]-oo, b]%classic). Qed. -End binomial_example. - -Section uniform_probability. -Context (R : realType) (a b : R) (ab0 : (0 < b - a)%R). - -Definition uniform_probability : set _ -> \bar R := - @mscale _ _ R (invr_nonneg (NngNum (ltW ab0))) - (mrestr lebesgue_measure (measurable_itv `[a, b])). +Local Notation mu := lebesgue_measure. -(* NB: set R -> \bar R を書くとMeasure.onが通らない *) -HB.instance Definition _ := Measure.on uniform_probability. +Lemma integral_uniform_pdf U : + (\int[mu]_(x in U) (uniform_pdf x)%:E = + \int[mu]_(x in U `&` `[a, b]) (uniform_pdf x)%:E)%E. +Proof. +rewrite [RHS]integral_mkcondr/=; apply: eq_integral => x xU. +rewrite patchE; case: ifPn => //. +rewrite notin_setE/= in_itv/= => /negP/negbTE xab. +by rewrite /uniform_pdf xab. +Qed. -(* Let uniform0 : uniform_probability set0 = 0. -Proof. exact: measure0. Qed. +Lemma integral_uniform_pdf1 A (ab : a < b) : `[a, b] `<=` A -> + (\int[mu]_(x in A) (uniform_pdf x)%:E = 1)%E. +Proof. +move=> abA; rewrite integral_uniform_pdf setIidr//. +rewrite (eq_integral (fun=> (b - a)^-1%:E)); last first. + by move=> x; rewrite inE/= in_itv/= /uniform_pdf => ->. +rewrite integral_cst//= lebesgue_measure_itv/= lte_fin. +by rewrite ab -EFinD -EFinM mulVf// gt_eqF// subr_gt0. +Qed. -Let uniform_ge0 U : 0 <= uniform_probability U. -Proof. exact: measure_ge0. Qed. +Definition uniform_prob (ab : a < b) : set _ -> \bar R := + fun U => (\int[mu]_(x in U) (uniform_pdf x)%:E)%E. -Let uniform_sigma_additive : semi_sigma_additive uniform_probability. -Proof. move=> /= F mF tF mUF; exact: measure_semi_sigma_additive. Qed. +Hypothesis ab : (a < b)%R. -HB.instance Definition _ := isMeasure.Build _ _ _ uniform_probability - uniform0 uniform_ge0 uniform_sigma_additive. *) +Let uniform0 : uniform_prob ab set0 = 0. +Proof. by rewrite /uniform_prob integral_set0. Qed. -Let uniform_probability_setT : uniform_probability [set: _] = 1%:E. +Let uniform_ge0 U : (0 <= uniform_prob ab U)%E. Proof. -rewrite /uniform_probability /mscale/= /mrestr/=. -rewrite setTI lebesgue_measure_itv/= lte_fin. -by rewrite -subr_gt0 ab0 -EFinD -EFinM mulVf// gt_eqF// subr_gt0. +by apply: integral_ge0 => /= x Ux; rewrite lee_fin uniform_pdf_ge0. Qed. -HB.instance Definition _ := @Measure_isProbability.Build _ _ R - uniform_probability uniform_probability_setT. - -End uniform_probability. - -Section integral_uniform. -Context {R : realType}. +Lemma integrable_uniform_pdf : + mu.-integrable setT (fun x => (uniform_pdf x)%:E). +Proof. +apply/integrableP; split. + by apply: measurableT_comp => //; exact: measurable_uniform_pdf. +under eq_integral. + move=> x _; rewrite gee0_abs//; last first. + by rewrite lee_fin uniform_pdf_ge0. + over. +by rewrite /= integral_uniform_pdf1 ?ltry// -subr_gt0. +Qed. -Let integral_uniform_indic (a b : R) (ab0 : (0 < b - a)%R) E : - measurable E -> let m := uniform_probability ab0 in - \int[m]_x (\1_E x)%:E = - (b - a)^-1%:E * \int[lebesgue_measure]_(x in `[a, b]) (\1_E x)%:E. +Let uniform_sigma_additive : semi_sigma_additive (uniform_prob ab). Proof. -move=> mE m. -by rewrite !integral_indic//= /uniform_probability/= /mscale/= /mrestr setIT. +move=> /= F mF tF mUF; rewrite /uniform_prob; apply: cvg_toP. + apply: ereal_nondecreasing_is_cvgn => m n mn. + apply: lee_sum_nneg_natr => // k _ _. + by apply: integral_ge0 => /= x Fkx; rewrite lee_fin uniform_pdf_ge0. +rewrite ge0_integral_bigcup//=. +- apply: measurable_funTS; apply: measurableT_comp => //. + exact: measurable_uniform_pdf. +- by move=> x _; rewrite lee_fin uniform_pdf_ge0. Qed. -Let integral_uniform_nnsfun (f : {nnsfun _ >-> R}) - (a b : R) (ab0 : (0 < b - a)%R) : let m := uniform_probability ab0 in - \int[m]_x (f x)%:E = - (b - a)^-1%:E * \int[lebesgue_measure]_(x in `[a, b]) (f x)%:E. +HB.instance Definition _ := isMeasure.Build _ _ _ (uniform_prob ab) + uniform0 uniform_ge0 uniform_sigma_additive. + +Let uniform_setT : uniform_prob ab [set: _] = 1%:E. +Proof. by rewrite /uniform_prob /mscale/= integral_uniform_pdf1. Qed. + +HB.instance Definition _ := @Measure_isProbability.Build _ _ R + (uniform_prob ab) uniform_setT. + +Lemma dominates_uniform_prob : uniform_prob ab `<< mu. +Proof. +move=> A mA muA0; rewrite /uniform_prob integral_uniform_pdf. +apply/eqP; rewrite eq_le; apply/andP; split; last first. + apply: integral_ge0 => x [Ax /=]; rewrite in_itv /= => xab. + by rewrite lee_fin uniform_pdf_ge0. +apply: (@le_trans _ _ + (\int[mu]_(x in A `&` `[a, b]%classic) (b - a)^-1%:E))%E; last first. + rewrite integral_cst//= ?mul1e//. + by rewrite pmule_rle0 ?lte_fin ?invr_gt0// ?subr_gt0// -muA0 measureIl. + exact: measurableI. +apply: ge0_le_integral => //=. +- exact: measurableI. +- by move=> x [Ax]; rewrite /= in_itv/= => axb; rewrite lee_fin uniform_pdf_ge0. +- by apply/EFin_measurable_fun/measurable_funTS; exact: measurable_uniform_pdf. +- by move=> x [Ax _]; rewrite lee_fin invr_ge0// ltW// subr_gt0. +- by move=> x [Ax]; rewrite in_itv/= /uniform_pdf => ->. +Qed. + +Let integral_uniform_indic E : measurable E -> + (\int[uniform_prob ab]_x (\1_E x)%:E = + (b - a)^-1%:E * \int[mu]_(x in `[a, b]) (\1_E x)%:E)%E. +Proof. +move=> mE; rewrite integral_indic//= /uniform_prob setIT -ge0_integralZl//=. +- rewrite [LHS]integral_mkcond/= [RHS]integral_mkcond/=. + apply: eq_integral => x _; rewrite !patchE; case: ifPn => xE. + case: ifPn. + rewrite inE/= in_itv/= => xab. + by rewrite /uniform_pdf xab indicE xE mule1. + by rewrite notin_setE/= in_itv/= => /negP/negbTE; rewrite /uniform_pdf => ->. + case: ifPn => //. + by rewrite inE/= in_itv/= => axb; rewrite indicE (negbTE xE) mule0. +- exact/EFin_measurable_fun/measurable_indic. +- by move=> x _; rewrite lee_fin. +- by rewrite lee_fin invr_ge0// ltW// subr_gt0. +Qed. + +Let integral_uniform_nnsfun (f : {nnsfun _ >-> R}) : + (\int[uniform_prob ab]_x (f x)%:E = + (b - a)^-1%:E * \int[mu]_(x in `[a, b]) (f x)%:E)%E. Proof. -move=> m. under [LHS]eq_integral do rewrite fimfunE -fsumEFin//. rewrite [LHS]ge0_integral_fsum//; last 2 first. - by move=> r; exact/EFin_measurable_fun/measurableT_comp. @@ -578,7 +635,7 @@ rewrite [LHS]ge0_integral_fsum//; last 2 first. rewrite -[RHS]ge0_integralZl//; last 3 first. - exact/EFin_measurable_fun/measurable_funTS. - by move=> x _; rewrite lee_fin. - - by rewrite lee_fin invr_ge0// ltW. + - by rewrite lee_fin invr_ge0// ltW// subr_gt0. under [RHS]eq_integral. move=> x xD; rewrite fimfunE -fsumEFin// ge0_mule_fsumr; last first. by move=> r; rewrite EFinM nnfun_muleindic_ge0. @@ -586,592 +643,200 @@ under [RHS]eq_integral. rewrite [RHS]ge0_integral_fsum//; last 2 first. - by move=> r; apply/EFin_measurable_fun; do 2 apply/measurableT_comp => //. - move=> n x _; rewrite EFinM mule_ge0//; last by rewrite nnfun_muleindic_ge0. - by rewrite lee_fin invr_ge0// ltW. + by rewrite lee_fin invr_ge0// ltW// subr_gt0. apply: eq_fsbigr => r _; rewrite ge0_integralZl//. - by rewrite !integralZl_indic_nnsfun//= integral_uniform_indic// muleCA. - exact/EFin_measurable_fun/measurableT_comp. - by move=> t _; rewrite nnfun_muleindic_ge0. -- by rewrite lee_fin invr_ge0// ltW. +- by rewrite lee_fin invr_ge0// ltW// subr_gt0. Qed. -Lemma integral_uniform (f : _ -> \bar R) (a b : R) - (ab0 : (0 < b - a)%R) : measurable_fun setT f -> (forall x, 0 <= f x) -> - let m := uniform_probability ab0 in - \int[m]_x f x = - (b - a)^-1%:E * \int[lebesgue_measure]_(x in `[a, b]) f x. +Lemma integral_uniform (f : _ -> \bar R) : + measurable_fun setT f -> (forall x, 0 <= f x)%E -> + (\int[uniform_prob ab]_x f x = (b - a)^-1%:E * \int[mu]_(x in `[a, b]) f x)%E. Proof. -move=> mf f0 m. -have [f_ [ndf_ f_f]] := approximation measurableT mf (fun x0 _ => f0 x0). -transitivity (lim (\int[m]_(x in setT) (f_ n x)%:E @[n --> \oo])). +move=> mf f0. +have [f_ [ndf_ f_f]] := approximation measurableT mf (fun y _ => f0 y). +transitivity (lim (\int[uniform_prob ab]_x (f_ n x)%:E @[n --> \oo])%E). rewrite -monotone_convergence//=. - apply: eq_integral => ? /[!inE] xD; apply/esym/cvg_lim => //=. exact: f_f. - by move=> n; exact/EFin_measurable_fun/measurable_funTS. - by move=> n ? _; rewrite lee_fin. - by move=> ? _ ? ? mn; rewrite lee_fin; exact/lefP/ndf_. -rewrite [X in _ = _ * X](_ : _ = lim - (\int[lebesgue_measure]_(x in `[a, b]) (f_ n x)%:E @[n --> \oo])); last first. +rewrite [X in _ = (_ * X)%E](_ : _ = lim + (\int[mu]_(x in `[a, b]) (f_ n x)%:E @[n --> \oo])%E); last first. rewrite -monotone_convergence//=. - by apply: eq_integral => ? /[!inE] xD; apply/esym/cvg_lim => //; exact: f_f. - by move=> n; exact/EFin_measurable_fun/measurable_funTS. - by move=> n ? _; rewrite lee_fin. - by move=> ? _ ? ? /ndf_ /lefP; rewrite lee_fin. rewrite -limeMl//. - apply: congr_lim. - by apply/funext => n /=; exact: integral_uniform_nnsfun. -apply/ereal_nondecreasing_is_cvgn => ? ? ab; apply: ge0_le_integral => //=. + by apply: congr_lim; apply/funext => n /=; exact: integral_uniform_nnsfun. +apply/ereal_nondecreasing_is_cvgn => x y xy; apply: ge0_le_integral => //=. - by move=> ? _; rewrite lee_fin. - exact/EFin_measurable_fun/measurable_funTS. - by move=> ? _; rewrite lee_fin. - exact/EFin_measurable_fun/measurable_funTS. -- by move=> ? _; rewrite lee_fin; move/ndf_ : ab => /lefP. +- by move=> ? _; rewrite lee_fin; move/ndf_ : xy => /lefP. Qed. -End integral_uniform. +End uniform_probability. -(* normalization constant *) -Section beta_nat_norm. -Context {R : realType} (a b : nat). +Section poisson_pdf. +Variable R : realType. +Local Open Scope ring_scope. -Definition beta_nat_norm : R := - (a.-1`!%:R * b.-1`!%:R / (a + b).-1`!%:R)%R. +(* density function for Poisson *) +Definition poisson_pdf k r : R := + if r > 0 then r ^+ k / k`!%:R^-1 * expR (- r) else 1%:R. -Lemma beta_nat_norm_gt0 : (0 < beta_nat_norm :> R)%R. +Lemma poisson_pdf_ge0 k r : 0 <= poisson_pdf k r. Proof. -by rewrite /beta_nat_norm divr_gt0// ?mulr_gt0 ?ltr0n ?fact_gt0. +rewrite /poisson_pdf; case: ifPn => r0//. +by rewrite mulr_ge0 ?expR_ge0// mulr_ge0// exprn_ge0 ?ltW. Qed. -Lemma beta_nat_norm_ge0 : (0 <= beta_nat_norm :> R)%R. -Proof. exact/ltW/beta_nat_norm_gt0. Qed. - -End beta_nat_norm. - -Lemma beta_nat_norm00 {R : realType} : beta_nat_norm 0 0 = 1%R :> R. -Proof. by rewrite /beta_nat_norm/= fact0 mulr1/= divff. Qed. - -Lemma beta_nat_norm11 {R : realType} : beta_nat_norm 1 1 = 1%R :> R. -Proof. by rewrite /beta_nat_norm/= fact0 mulr1/= divff. Qed. +Lemma poisson_pdf_gt0 k r : 0 < r -> 0 < poisson_pdf k.+1 r. +Proof. +move=> r0; rewrite /poisson_pdf r0 mulr_gt0 ?expR_gt0//. +by rewrite divr_gt0// ?exprn_gt0// invr_gt0 ltr0n fact_gt0. +Qed. -(* definition of the beta probability specialized to natural numbers *) +Lemma measurable_poisson_pdf k : measurable_fun setT (poisson_pdf k). +Proof. +rewrite /poisson_pdf; apply: measurable_fun_if => //. + apply: (measurable_fun_bool true). + rewrite (_ : _ @^-1` _ = `]0, +oo[%classic)//. + by apply/seteqP; split => x /=; rewrite in_itv/= andbT. +by apply: measurable_funM => /=; + [exact: measurable_funM|exact: measurableT_comp]. +Qed. -Definition ubeta_nat_pdf' {R : realType} (a b : nat) (t : R) := - (t ^+ a * (`1- t) ^+ b)%R. +End poisson_pdf. -Section beta_probability. +Section exponential_pdf. +Variable R : realType. Local Open Scope ring_scope. -Context {R : realType}. -Variables a b : nat. -(* unnormalized pdf for beta specialized to nat *) -Definition ubeta_nat_pdf (t : R) := ubeta_nat_pdf' a.-1 b.-1 t. +Definition exponential_pdf x r : R := r * expR (- r * x). -Lemma ubeta_nat_pdf_ge0 t : 0 <= t <= 1 -> 0 <= ubeta_nat_pdf t. -Proof. by move=> /andP[t0 t1]; rewrite mulr_ge0// exprn_ge0// onem_ge0. Qed. +Lemma exponential_pdf_gt0 x r : 0 < r -> 0 < exponential_pdf x r. +Proof. by move=> r0; rewrite /exponential_pdf mulr_gt0// expR_gt0. Qed. -Lemma ubeta_nat_pdf_le1 t : 0 <= t <= 1 -> ubeta_nat_pdf t <= 1. -Proof. -move=> /andP[t0 t1]; rewrite /ubeta_nat_pdf. -by rewrite mulr_ile1// ?(exprn_ge0,onem_ge0,exprn_ile1,onem_le1). -Qed. +Lemma exponential_pdf_ge0 x r : 0 <= r -> 0 <= exponential_pdf x r. +Proof. by move=> r0; rewrite /exponential_pdf mulr_ge0// expR_ge0. Qed. -Lemma measurable_ubeta_nat_pdf : measurable_fun setT ubeta_nat_pdf. +Lemma measurable_exponential_pdf x : measurable_fun setT (exponential_pdf x). Proof. -by apply /measurable_funM => //; exact/measurable_fun_pow/measurable_funB. +apply: measurable_funM => //=; apply: measurableT_comp => //. +exact: measurable_funM. Qed. -Lemma beta_nat_normE : - (beta_nat_norm a b)%:E = (\int[lebesgue_measure]_(x in `[0%R, 1%R]) (ubeta_nat_pdf x)%:E)%E. -Proof. -rewrite /beta_nat_norm. -rewrite /ubeta_nat_pdf. -rewrite /ubeta_nat_pdf'. -Admitted. +End exponential_pdf. -(* normalized pdf for beta specialized to nat *) -Definition beta_nat_pdf t := ubeta_nat_pdf t / (beta_nat_norm a b). +(* X + Y is a measurableType if X and Y are *) +HB.instance Definition _ (X Y : pointedType) := + isPointed.Build (X + Y)%type (@inl X Y point). -Lemma measurable_beta_nat_pdf : measurable_fun setT beta_nat_pdf. -Proof. by apply: measurable_funM => //; exact: measurable_ubeta_nat_pdf. Qed. +Section measurable_sum. +Context d d' (X : measurableType d) (Y : measurableType d'). -Lemma beta_nat_pdf_ge0 t : 0 <= t <= 1 -> 0 <= beta_nat_pdf t. -Proof. -move=> t01; rewrite /beta_nat_pdf divr_ge0//. - exact: ubeta_nat_pdf_ge0. -exact: beta_nat_norm_ge0. -Qed. +Definition measurable_sum : set (set (X + Y)) := setT. -Local Notation mu := lebesgue_measure. +Let sum0 : measurable_sum set0. Proof. by []. Qed. -(* unnormalized beta specialized to nat *) -Definition ubeta_nat (U : set (measurableTypeR R)) : \bar R := - \int[mu]_(x in U `&` `[0, 1](*NB: is this correct?*)) (ubeta_nat_pdf x)%:E. -(* TODO: define as \int[uniform_probability p01]_(t in U) (ubeta_nat_pdf t)%:E ? *) +Let sumC A : measurable_sum A -> measurable_sum (~` A). Proof. by []. Qed. -Lemma ubeta_natE U : - (ubeta_nat U = - \int[mu]_(x in U `&` `[0%R, 1%R]) (ubeta_nat_pdf x)%:E :> \bar R)%E. +Let sumU (F : (set (X + Y))^nat) : (forall i, measurable_sum (F i)) -> + measurable_sum (\bigcup_i F i). Proof. by []. Qed. -Lemma ubeta_nat_lty U : (ubeta_nat U < +oo)%E. -Proof. -Admitted. +HB.instance Definition _ := @isMeasurable.Build default_measure_display (X + Y)%type + measurable_sum sum0 sumC sumU. -Let ubeta_nat0 : ubeta_nat set0 = 0%:E. -Proof. by rewrite /ubeta_nat set0I integral_set0. Qed. +End measurable_sum. -Let ubeta_nat_ge0 U : (0 <= ubeta_nat U)%E. +Lemma measurable_fun_sum dA dB d' (A : measurableType dA) (B : measurableType dB) + (Y : measurableType d') (f : A -> Y) (g : B -> Y) : + measurable_fun setT f -> measurable_fun setT g -> + measurable_fun setT (fun tb : A + B => + match tb with inl a => f a | inr b => g b end). Proof. -rewrite /ubeta_nat integral_ge0//= => x [Ux]. -by rewrite in_itv/= => x01; rewrite lee_fin ubeta_nat_pdf_ge0. +move=> mx my/= _ Z mZ /=; rewrite setTI /=. +rewrite (_ : _ @^-1` Z = inl @` (f @^-1` Z) `|` inr @` (g @^-1` Z)). + exact: measurableU. +apply/seteqP; split. + by move=> [a Zxa|b Zxb]/=; [left; exists a|right; exists b]. +by move=> z [/= [a Zxa <-//=]|]/= [b Zyb <-//=]. Qed. -(* TODO: should be shorter *) -Let ubeta_nat_sigma_additive : semi_sigma_additive ubeta_nat. +(* TODO: measurable_fun_if_pair -> measurable_fun_if_pair_bool? *) +Lemma measurable_fun_if_pair_nat d d' (X : measurableType d) + (Y : measurableType d') (f g : X -> Y) (n : nat) : + measurable_fun setT f -> measurable_fun setT g -> + measurable_fun setT (fun xn => if xn.2 == n then f xn.1 else g xn.1). Proof. -move=> /= F mF tF mUF; rewrite /ubeta_nat setI_bigcupl; apply: cvg_toP. - apply: ereal_nondecreasing_is_cvgn => m n mn. - apply: lee_sum_nneg_natr => // k _ _. - apply: integral_ge0 => /= x [_]; rewrite in_itv => x01. - by rewrite lee_fin; exact: ubeta_nat_pdf_ge0. -rewrite ge0_integral_bigcup//=. -- by move=> k; exact: measurableI. -- apply/integrableP; split. - by apply/EFin_measurable_fun; exact: measurable_funTS measurable_ubeta_nat_pdf. - apply: le_lt_trans => /=. - apply: (@subset_integral _ _ _ mu _ `[0%R, 1%R]) => //=. - - rewrite -setI_bigcupl; apply: measurableI => //. - - apply/measurableT_comp => //; apply/measurableT_comp => //. - exact: measurable_funTS measurable_ubeta_nat_pdf. - - by apply: bigcup_sub => k _; exact: subIsetr. - rewrite /=. - under eq_integral. - move=> /= x; rewrite inE/= in_itv/= => x01. - rewrite ger0_norm//; last by rewrite ubeta_nat_pdf_ge0. - over. - by rewrite -beta_nat_normE ltry. -- move=> x [k _ [_]]; rewrite /= in_itv/= => x01. - by rewrite lee_fin ubeta_nat_pdf_ge0. -- exact: trivIset_setIr. +move=> mx my; apply: measurable_fun_ifT => //=. +- have h : measurable_fun [set: nat] (fun t => t == n) by []. + exact: (measurableT_comp h). +- exact: measurableT_comp. +- exact: measurableT_comp. Qed. -HB.instance Definition _ := isMeasure.Build _ _ _ ubeta_nat - ubeta_nat0 ubeta_nat_ge0 ubeta_nat_sigma_additive. - -Definition beta_nat (*: set [the measurableType (R.-ocitv.-measurable).-sigma of - salgebraType R.-ocitv.-measurable] -> \bar R*) := - @mscale _ _ _ (invr_nonneg (NngNum (beta_nat_norm_ge0 a b))) ubeta_nat. +(* Definition mR (R : realType) : Type := R. +HB.instance Definition _ (R : realType) := Measurable.on (mR R). +(* [the measurableType (R.-ocitv.-measurable).-sigma of + salgebraType (R.-ocitv.-measurable)]. *) *) -Let beta_nat0 : beta_nat set0 = 0. -Proof. exact: measure0. Qed. +Module Notations. +Notation munit := Datatypes_unit__canonical__measure_Measurable. +Notation mbool := Datatypes_bool__canonical__measure_Measurable. +Notation mnat := Datatypes_nat__canonical__measure_Measurable. +End Notations. -Let beta_nat_ge0 U : (0 <= beta_nat U)%E. -Proof. exact: measure_ge0. Qed. +Lemma invr_nonneg_proof (R : numDomainType) (p : {nonneg R}) : + (0 <= (p%:num)^-1)%R. +Proof. by rewrite invr_ge0. Qed. -Let beta_nat_sigma_additive : semi_sigma_additive beta_nat. -Proof. move=> /= F mF tF mUF; exact: measure_semi_sigma_additive. Qed. +Definition invr_nonneg (R : numDomainType) (p : {nonneg R}) := + NngNum (invr_nonneg_proof p). -HB.instance Definition _ := isMeasure.Build _ _ _ beta_nat - beta_nat0 beta_nat_ge0 beta_nat_sigma_additive. - -Let beta_nat_setT : beta_nat setT = 1%:E. -Proof. -rewrite /beta_nat /= /mscale /=. -rewrite /ubeta_nat/= setTI. -by rewrite -beta_nat_normE -EFinM mulVr// unitfE gt_eqF// beta_nat_norm_gt0. -Qed. - -HB.instance Definition _ := @Measure_isProbability.Build _ _ _ - beta_nat beta_nat_setT. +Section constants. +Variable R : realType. +Local Open Scope ring_scope. -Lemma beta_nat01 : beta_nat `[0, 1] = 1%:E. +Lemma onem1S n : `1- (1 / n.+1%:R) = (n%:R / n.+1%:R)%:nng%:num :> R. Proof. -rewrite /beta_nat /= /mscale/=. -rewrite /beta_nat /ubeta_nat setIidr//. -by rewrite -beta_nat_normE -EFinM mulVr// unitfE gt_eqF// beta_nat_norm_gt0. +by rewrite /onem/= -{1}(@divrr _ n.+1%:R) ?unitfE// -mulrBl -natr1 addrK. Qed. -End beta_probability. - -Arguments beta_nat {R}. - -Section beta_probability11. -Local Open Scope ring_scope. -Context {R : realType}. +Lemma p1S n : (1 / n.+1%:R)%:nng%:num <= 1 :> R. +Proof. by rewrite ler_pdivrMr//= mul1r ler1n. Qed. -Lemma ubeta_nat_pdf11 : ubeta_nat_pdf 1 1 = @cst R _ 1. -Proof. by apply/funext => r; rewrite /ubeta_nat_pdf/= /ubeta_nat_pdf' !expr0 mulr1. Qed. - -Let a01 : 0 < 1 - 0 :> R. Proof. by []. Qed. - -Lemma beta11_uniform U : measurable U -> - beta_nat 1 1 U = uniform_probability a01 U. -Proof. -move=> mU; rewrite /beta_nat /uniform_probability. -rewrite /mscale/= beta_nat_norm11 subr0 invr1 !mul1e. -rewrite /ubeta_nat /mrestr/=. -rewrite ubeta_nat_pdf11/= integral_cst/= ?mul1e//. -exact: measurableI. -Qed. - -End beta_probability11. - -Lemma factD n m : (n`! * m`! <= (n + m).+1`!)%N. -Proof. -elim: n m => /= [m|n ih m]. - by rewrite fact0 mul1n add0n factS leq_pmull. -rewrite 2!factS [in X in (_ <= _ * X)%N]addSn -mulnA leq_mul//. -by rewrite ltnS addSnnS leq_addr. -Qed. - -Lemma factD' n m : (n`! * m.-1`! <= (n + m)`!)%N. -Proof. -case: m => //= [|m]. - by rewrite fact0 muln1 addn0. -by rewrite addnS factD. -Qed. - -Lemma leq_prod2 (x y n m : nat) : (n <= x)%N -> (m <= y)%N -> - (\prod_(m <= i < y) i * \prod_(n <= i < x) i <= \prod_(n + m <= i < x + y) i)%N. -Proof. -move=> nx my. -rewrite big_addn. -rewrite -addnBA//. -rewrite {3}/index_iota. -rewrite -addnBAC//. -rewrite iotaD. -rewrite big_cat/=. -rewrite mulnC. -rewrite leq_mul//. - rewrite /index_iota. - apply: leq_prod. - by move=> i _; rewrite leq_addr. -rewrite subnKC//. -rewrite -{1}(add0n m). -rewrite big_addn. -rewrite {2}(_ : (y - m) = ((y - m + x) - x))%N; last first. - by rewrite -addnBA// subnn addn0. -rewrite -{1}(add0n x). -rewrite big_addn. -rewrite -addnBA// subnn addn0. -apply: leq_prod => i _. -by rewrite leq_add2r leq_addr. -Qed. - -Lemma leq_fact2 (x y n m : nat) : - (n <= x) %N -> (m <= y)%N -> - (x`! * y`! * ((n + m).+1)`! <= n`! * m`! * ((x + y).+1)`!)%N. -Proof. -move=> nx my. -rewrite (_ : x`! = n`! * \prod_(n.+1 <= i < x.+1) i)%N; last first. - by rewrite -fact_split. -rewrite -!mulnA leq_mul2l; apply/orP; right. -rewrite (_ : y`! = m`! * \prod_(m.+1 <= i < y.+1) i)%N; last first. - by rewrite -fact_split. -rewrite mulnCA -!mulnA leq_mul2l; apply/orP; right. -rewrite (_ : (x + y).+1`! = (n + m).+1`! * \prod_((n + m).+2 <= i < (x + y).+2) i)%N; last first. - rewrite -fact_split//. - by rewrite ltnS leq_add. -rewrite mulnA mulnC leq_mul2l; apply/orP; right. -rewrite -addSn -addnS. -rewrite -addSn -addnS. -exact: leq_prod2. -Qed. - -Section integral_beta. -Context {R : realType}. -Variables a b a' b' : nat. +Lemma p12 : (1 / 2%:R)%:nng%:num <= 1 :> R. Proof. by rewrite p1S. Qed. -Local Notation mu := lebesgue_measure. +Lemma p14 : (1 / 4%:R)%:nng%:num <= 1 :> R. Proof. by rewrite p1S. Qed. -Lemma integralMl f g1 g2 A : -measurable A -> measurable_fun A f -> - measurable_fun A g1 -> measurable_fun A g2 -> -(ae_eq mu A g1 (EFin \o g2)) -> - \int[mu]_(x in A) (f x * g1 x) = - \int[mu]_(x in A) (f x * (g2 x)%:E) :> \bar R. -Proof. -move=> mA mf mg1 mg2 Hg. -apply: ae_eq_integral => //. - by apply: emeasurable_funM. - apply: emeasurable_funM => //. - by apply/EFin_measurable_fun. -by apply: ae_eq_mul2l. -Qed. - -Let beta_nat_dom : (@beta_nat R a b `<< mu). -Proof. -move=> A mA muA0. -rewrite /beta_nat /mscale/= /ubeta_nat. -have -> : \int[mu]_(x0 in A `&` `[0%R, 1%R]) (ubeta_nat_pdf a b x0)%:E = 0%:E. - apply/eqP; rewrite eq_le. - apply/andP; split; last first. - apply: integral_ge0 => x [Ax /=]. - rewrite in_itv /= => x01. - by rewrite lee_fin ubeta_nat_pdf_ge0. - apply: le_trans. - apply: (@subset_integral _ _ _ _ _ A). - by apply: measurableI. - by []. - apply/EFin_measurable_fun. - apply: (@measurable_funS _ _ _ _ setT) => //=. - apply: measurable_ubeta_nat_pdf. - move=> x Ax. - have : (`[0%R, 1%R]%classic x). - admit. - rewrite /= in_itv/=. - apply: ubeta_nat_pdf_ge0. - apply: subIsetl. - rewrite /=. - (* rewrite integral_abs_eq0. *) (* without abs *) - admit. -by rewrite mule0. -Admitted. - -Lemma integral_beta_nat f : - measurable_fun setT f -> - \int[beta_nat a b]_(x in `[0%R, 1%R]) `|f x| < +oo -> - \int[beta_nat a b]_(x in `[0%R, 1%R]) f x = - \int[mu]_(x in `[0%R, 1%R]) (f x * (beta_nat_pdf a b x)%:E) :> \bar R. -Proof. -move=> mf finf. -rewrite -(Radon_Nikodym_change_of_variables beta_nat_dom) //=. -apply: integralMl => //. - apply: (@measurable_funS _ _ _ _ [set: R]) => //. - apply: (@measurable_funS _ _ _ _ [set: R]) => //. - rewrite Radon_NikodymE. - by exact: beta_nat_dom. - move=> /= H. - case: cid => /= h [h1 h2 h3]. - have : (measurable_fun setT h /\ \int[mu]_x `|h x| < +oo). - apply/integrableP/h2. - move=> /= [mh _]. - apply: mh. - apply: (@measurable_funS _ _ _ _ [set: R]) => //. - apply: measurable_beta_nat_pdf. - rewrite Radon_NikodymE => /= A. - by exact: beta_nat_dom. -case: cid => /= h [h1 h2 h3]. -apply: integral_ae_eq => //. - apply: integrableS h2 => //. (* integrableST? *) - apply: (@measurable_funS _ _ _ _ [set: R]) => //. - apply: measurableT_comp => //. - apply: measurable_beta_nat_pdf. - move=> E E01 mE. - have mB : measurable_fun E (EFin \o ubeta_nat_pdf a b). - apply: measurableT_comp => //. - apply: (@measurable_funS _ _ _ _ [set: R]) => //. - apply: measurable_ubeta_nat_pdf. - rewrite -(h3 _ mE). - rewrite /beta_nat/mscale/ubeta_nat/beta_nat_pdf/=. - under eq_integral do rewrite mulrC EFinM. - rewrite (integralZl mE). - rewrite /ubeta_nat setIidl //. - rewrite /=. - apply/integrableP; split. - by apply: mB. - under eq_integral => x x01. - rewrite gee0_abs /=. - over. - apply: ubeta_nat_pdf_ge0. - have : x \in `[0%R, 1%R]. - apply: (@subset_trans _ _ `[x,x] _ _ E01). - by rewrite set_interval.set_itv1 sub1set x01. - by rewrite /= in_itv/= lexx. - by rewrite in_itv/=. - rewrite /=. - have <- := (setIidl E01). - by rewrite -ubeta_natE ubeta_nat_lty. -apply/integrableP; split. - by apply: (@measurable_funS _ _ _ _ [set: R]). -exact: finf. -Qed. +Lemma onem27 : `1- (2 / 7%:R) = (5%:R / 7%:R)%:nng%:num :> R. +Proof. by apply/eqP; rewrite subr_eq/= -mulrDl -natrD divrr// unitfE. Qed. -Local Open Scope ring_scope. +(*Lemma p27 : (2 / 7%:R)%:nng%:num <= 1 :> R. +Proof. by rewrite /= lter_pdivrMr// mul1r ler_nat. Qed.*) -(* TODO: `[0, 1]? *) -Definition beta_nat_bern U : \bar R := - \int[beta_nat a b]_y bernoulli_trunc (ubeta_nat_pdf a'.+1 b'.+1 y) U. - -Local Notation B := beta_nat_norm. - -Definition Baa'bb'Bab : R := (beta_nat_norm (a + a') (b + b')) / beta_nat_norm a b. - -Lemma Baa'bb'Bab_ge0 : 0 <= Baa'bb'Bab. -Proof. by rewrite /Baa'bb'Bab divr_ge0// beta_nat_norm_ge0. Qed. - -Definition Baa'bb'Bab_nneg : {nonneg R} := NngNum Baa'bb'Bab_ge0. - -Lemma Baa'bb'Bab_le1 : Baa'bb'Bab_nneg%:num <= 1. -Proof. -rewrite /Baa'bb'Bab_nneg/= /Baa'bb'Bab. -rewrite ler_pdivrMr// ?mul1r ?beta_nat_norm_gt0//. -rewrite /B /beta_nat_norm. -rewrite ler_pdivrMr ?ltr0n ?fact_gt0//. -rewrite mulrAC. -rewrite ler_pdivlMr ?ltr0n ?fact_gt0//. -rewrite -!natrM ler_nat. -case: a. - rewrite /= fact0 mul1n !add0n. - case: b => /=. - case: a' => //. - case: b' => //= m. - by rewrite fact0 !mul1n muln1. - move=> n/=. - by rewrite fact0 add0n muln1 mul1n factD'. - move=> m. - rewrite mulnC leq_mul// mulnC. - by rewrite (leq_trans (factD' _ _))// addSn addnS//= addnC. -move=> n. -rewrite addSn. -case: b. - rewrite !fact0 add0n muln1 [leqRHS]mulnC addn0/= leq_mul//. - by rewrite factD'. -move=> m. -clear a b. -rewrite [(n + a').+1.-1]/=. -rewrite [n.+1.-1]/=. -rewrite [m.+1.-1]/=. -rewrite addnS. -rewrite [(_ + m).+1.-1]/=. -rewrite (addSn m b'). -rewrite [(m + _).+1.-1]/=. -rewrite (addSn (n + a')). -rewrite [_.+1.-1]/=. -rewrite addSn addnS. -by rewrite leq_fact2// leq_addr. -Qed. - -Lemma onem_Baa'bb'Bab_ge0 : 0 <= 1 - (Baa'bb'Bab_nneg%:num). -Proof. by rewrite subr_ge0 Baa'bb'Bab_le1. Qed. - -Lemma onem_Baa'bb'Bab_ge0_fix : 0 <= B a b * (1 - Baa'bb'Bab_nneg%:num). -Proof. -rewrite mulr_ge0//. - rewrite /B. - exact: beta_nat_norm_ge0. -rewrite subr_ge0. -exact: Baa'bb'Bab_le1. -Qed. - -Lemma ubeta_nat_pdf_ge0' t : 0 <= ubeta_nat_pdf a'.+1 b'.+1 t :> R. -Proof. -apply: ubeta_nat_pdf_ge0. (* TODO: needs 0 <= t <= 1 *) -Admitted. - -Lemma ubeta_nat_pdf_le1' t : (NngNum (ubeta_nat_pdf_ge0' t))%:num <= 1 :> R. -Proof. -rewrite /=. -rewrite /ubeta_nat_pdf. -rewrite /ubeta_nat_pdf'. (* TODO: needs 0 <= t <= 1 *) -Admitted. - -Lemma integral_ubeta_nat' : - (\int[ubeta_nat a b]_x (ubeta_nat_pdf a'.+1 b'.+1 x)%:E = - \int[mu]_(x in `[0%R, 1%R]) - (x ^+ a'.-1 * `1-x ^+ b'.-1 * x ^+ a * `1-x ^+ b)%:E :> \bar R)%E. -Proof. -rewrite /ubeta_nat/ubeta_nat_pdf. -Admitted. - -Lemma beta_nat_bern_bern U : - (a > 0)%N -> (b > 0)%N -> - beta_nat_bern U = - bernoulli_trunc Baa'bb'Bab U. -Proof. -rewrite /beta_nat_bern. -transitivity ((\int[beta_nat a b]_(y in `[0%R, 1%R]) - bernoulli_trunc (ubeta_nat_pdf a'.+1 b'.+1 y) U)%E : \bar R). - admit. -rewrite integral_beta_nat /=; last 2 first. - apply: (@measurableT_comp _ _ _ _ _ _ (bernoulli_trunc ^~ U)). - apply: (measurability (ErealGenInftyO.measurableE R)) => //=. - move=> /= _ [_ [x ->] <-]; apply: measurableI => //. - admit. - exact: measurable_ubeta_nat_pdf. - admit. -under eq_integral => x. - rewrite inE/= in_itv/= => x01. - rewrite bernoulli_truncE. - over. - apply/andP; split. - apply/ubeta_nat_pdf_ge0/x01. - apply/ubeta_nat_pdf_le1/x01. -rewrite /=. -rewrite bernoulli_truncE; last first. - apply/andP; split. - exact: Baa'bb'Bab_ge0. - exact: Baa'bb'Bab_le1. -under eq_integral => x _. - rewrite muleC muleDr//. - over. -rewrite integralD//=; last 2 first. - (* TODO: integrableM *) - admit. - admit. -congr (_ + _). - under eq_integral do rewrite muleA muleC. - rewrite integralZl//=; last first. - admit. - rewrite muleC. - congr (_ * _)%E. - rewrite /beta_nat_pdf. - under eq_integral do rewrite EFinM -muleA muleC -muleA. - rewrite integralZl//=; last first. - admit. - transitivity (((beta_nat_norm a b)^-1)%:E * \int[lebesgue_measure]_(x in `[0%R, 1%R]) ((ubeta_nat_pdf (a+a') (b+b') x)%:E) : \bar R)%E. - congr (_ * _)%E. - apply: eq_integral => x x01. - rewrite /ubeta_nat_pdf /ubeta_nat_pdf' muleC /onem -EFinM/=. - rewrite mulrCA -mulrA -exprD mulrA -exprD. - congr (_ ^+ _ * _ ^+ _)%:E. - rewrite -!subn1 subDnCA//. - rewrite addnC -!subn1 subDnCA//. - rewrite -beta_nat_normE. - rewrite /Baa'bb'Bab/B -!EFinM. - congr _%:E. - rewrite mulrC//. -under eq_integral do rewrite muleA muleC. -rewrite integralZl//=; last first. - admit. -rewrite muleC. -congr (_ * _)%E. -rewrite /beta_nat_pdf. -under eq_integral do rewrite EFinM -muleA muleC -muleA. -rewrite integralZl//=; last first. - admit. -transitivity (((beta_nat_norm a b)^-1)%:E * \int[lebesgue_measure]_(x in `[0%R, 1%R]) ((ubeta_nat_pdf a b x)%:E - (ubeta_nat_pdf (a+a') (b+b') x)%:E) : \bar R)%E. - congr (_ * _)%E. - apply: eq_integral => x x01. - rewrite /onem -EFinM mulrBl mul1r EFinB. - congr (_ - _)%E. - rewrite /ubeta_nat_pdf /ubeta_nat_pdf'/=. - rewrite mulrCA -mulrA -exprD mulrA -exprD. - congr (_ ^+ _ * _ ^+ _)%:E. - rewrite addnC -!subn1 subDnCA//. - rewrite -!subn1 subDnCA//. -rewrite integralB_EFin//=; last 2 first. - admit. - admit. -rewrite -!beta_nat_normE -EFinM mulrBr /onem mulVf; last first. - rewrite /B mulf_eq0 negb_or. - apply/andP; split. - rewrite mulf_eq0 negb_or. - rewrite gt_eqF ?ltr0n ?fact_gt0//=. - rewrite gt_eqF ?ltr0n ?fact_gt0//=. - rewrite invr_eq0 gt_eqF ?ltr0n ?fact_gt0//=. -congr (_ - _)%:E. -by rewrite mulrC. -Admitted. - -End integral_beta. +End constants. +Arguments p12 {R}. +Arguments p14 {R}. +(*Arguments p27 {R}.*) +Arguments p1S {R}. Section mscore. Context d (T : measurableType d) (R : realType). Variable f : T -> R. -Definition mscore t : {measure set _ -> \bar R} := +Definition mscore t : {measure set unit -> \bar R} := let p := NngNum (normr_ge0 (f t)) in - [the measure _ _ of mscale p [the measure _ _ of dirac tt]]. + mscale p (dirac tt). Lemma mscoreE t U : mscore t U = if U == set0 then 0 else `| (f t)%:E |. Proof. @@ -1196,7 +861,7 @@ Section score. Context d (T : measurableType d) (R : realType). Variable f : T -> R. -Definition k (mf : measurable_fun setT f) i t U := +Definition k (mf : measurable_fun [set: T] f) i t U := if i%:R%:E <= mscore f t U < i.+1%:R%:E then mscore f t U else @@ -1339,7 +1004,7 @@ Section kiteT. Variable k : R.-ker X ~> Y. Definition kiteT : X * bool -> {measure set Y -> \bar R} := - fun xb => if xb.2 then k xb.1 else [the measure _ _ of mzero]. + fun xb => if xb.2 then k xb.1 else mzero. Let measurable_fun_kiteT U : measurable U -> measurable_fun setT (kiteT ^~ U). Proof. @@ -1395,7 +1060,7 @@ Section kiteF. Variable k : R.-ker X ~> Y. Definition kiteF : X * bool -> {measure set Y -> \bar R} := - fun xb => if ~~ xb.2 then k xb.1 else [the measure _ _ of mzero]. + fun xb => if ~~ xb.2 then k xb.1 else mzero. Let measurable_fun_kiteF U : measurable U -> measurable_fun setT (kiteF ^~ U). Proof. @@ -1459,7 +1124,7 @@ Variables (f : T -> bool) (u1 u2 : R.-sfker T ~> T'). Definition mite (mf : measurable_fun setT f) : T -> set T' -> \bar R := fun t => if f t then u1 t else u2 t. -Variables mf : measurable_fun setT f. +Hypothesis mf : measurable_fun [set: T] f. Let mite0 t : mite mf t set0 = 0. Proof. by rewrite /mite; case: ifPn. Qed. @@ -1481,23 +1146,20 @@ Import ITE. Definition kite : R.-sfker T ~> T' := kdirac mf \; kadd (kiteT u1) (kiteF u2). *) -Definition kite := - [the R.-sfker _ ~> _ of kdirac mf] \; - [the R.-sfker _ ~> _ of kadd - [the R.-sfker _ ~> T' of kiteT u1] - [the R.-sfker _ ~> T' of kiteF u2] ]. +Definition kite : R.-sfker T ~> T' := + kdirac mf \; kadd (kiteT u1) (kiteF u2). End ite. Section insn2. Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Definition ret (f : X -> Y) (mf : measurable_fun setT f) - : R.-pker X ~> Y := [the R.-pker _ ~> _ of kdirac mf]. +Definition ret (f : X -> Y) (mf : measurable_fun [set: X] f) + : R.-pker X ~> Y := kdirac mf. -Definition sample (P : X -> pprobability Y R) (mP : measurable_fun setT P) +Definition sample (P : X -> pprobability Y R) (mP : measurable_fun [set: X] P) : R.-pker X ~> Y := - [the R.-pker _ ~> _ of kprobability mP]. + kprobability mP. Definition sample_cst (P : pprobability Y R) : R.-pker X ~> Y := sample (measurable_cst P). @@ -1597,7 +1259,7 @@ Context d d' d3 (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType). Lemma letin_kret (k : R.-sfker X ~> Y) - (f : X * Y -> Z) (mf : measurable_fun setT f) x U : + (f : X * Y -> Z) (mf : measurable_fun [set: X * Y] f) x U : measurable U -> letin k (ret mf) x U = k x (curry f x @^-1` U). Proof. @@ -1607,10 +1269,9 @@ rewrite integral_indic ?setIT// -[X in measurable X]setTI. exact: (measurableT_comp mf). Qed. -Lemma letin_retk - (f : X -> Y) (mf : measurable_fun setT f) - (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) - x U : measurable U -> +Lemma letin_retk (f : X -> Y) + (mf : measurable_fun [set: X] f) (k : R.-sfker X * Y ~> Z) x U : + measurable U -> letin (ret mf) k x U = k (x, f x) U. Proof. move=> mU; rewrite letinE retE integral_dirac ?diracT ?mul1e//. @@ -1631,9 +1292,9 @@ End insn1. Section hard_constraint. Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Definition fail := - letin (score (@measurable_cst _ _ X _ setT (0%R : R))) - (ret (@measurable_cst _ _ _ Y setT point)). +Definition fail : R.-sfker X ~> Y := + letin (score (measurable_cst (0%R : R))) + (ret (measurable_cst point)). Lemma failE x U : fail x U = 0. Proof. by rewrite /fail letinE ge0_integral_mscale//= normr0 mul0e. Qed. @@ -1661,15 +1322,13 @@ Arguments kb {d T}. Arguments kn {d T}. Section iter_mprod. -Import Notations. +Local Open Scope type_scope. -Fixpoint iter_mprod (l : list {d & measurableType d}) - : {d & measurableType d} := +Fixpoint iter_mprod (l : seq {d & measurableType d}) : {d & measurableType d} := match l with - | [::] => existT measurableType _ munit + | [::] => existT measurableType _ unit | h :: t => let t' := iter_mprod t in - existT _ _ [the measurableType (projT1 h, projT1 t').-prod of - (projT2 h * projT2 t')%type] + existT _ _ [the measurableType _ of projT2 h * projT2 t'] end. End iter_mprod. @@ -1678,15 +1337,13 @@ Section acc. Import Notations. Context {R : realType}. -Fixpoint acc (l : seq {d & measurableType d}) n : - projT2 (iter_mprod l) -> projT2 (nth (existT _ _ munit) l n) := - match l return - projT2 (iter_mprod l) -> projT2 (nth (existT _ _ munit) l n) - with - | [::] => match n with | O => id | m.+1 => id end - | _ :: _ => match n with +Fixpoint acc (l : seq {d & measurableType d}) k : + projT2 (iter_mprod l) -> projT2 (nth (existT _ _ munit) l k) := + match l with + | [::] => match k with O => id | _ => id end + | _ :: _ => match k with | O => fst - | m.+1 => fun H => acc m H.2 + | m.+1 => fun x => acc m x.2 end end. @@ -1703,25 +1360,22 @@ Section rpair_pairA. Context d0 d1 d2 (T0 : measurableType d0) (T1 : measurableType d1) (T2 : measurableType d2). -Definition rpair d (T : measurableType d) t : - ([the measurableType _ of T0] -> [the measurableType _ of T0 * T])%type := +Definition rpair d (T : measurableType d) t : T0 -> T0 * T := fun x => (x, t). Lemma mrpair d (T : measurableType d) t : measurable_fun setT (@rpair _ T t). Proof. exact: measurable_fun_prod. Qed. -Definition pairA : ([the measurableType _ of T0 * T1 * T2] -> - [the measurableType _ of T0 * (T1 * T2)])%type := +Definition pairA : T0 * T1 * T2 -> T0 * (T1 * T2) := fun x => (x.1.1, (x.1.2, x.2)). -Definition mpairA : measurable_fun setT pairA. +Definition mpairA : measurable_fun [set: (T0 * T1) * T2] pairA. Proof. apply: measurable_fun_prod => /=; first exact: measurableT_comp. by apply: measurable_fun_prod => //=; exact: measurableT_comp. Qed. -Definition pairAi : ([the measurableType _ of T0 * (T1 * T2)] -> - [the measurableType _ of T0 * T1 * T2])%type := +Definition pairAi : T0 * (T1 * T2) -> T0 * T1 * T2 := fun x => (x.1, x.2.1, x.2.2). Definition mpairAi : measurable_fun setT pairAi. @@ -1746,39 +1400,33 @@ Import Notations. Context d0 d1 d2 d3 (T0 : measurableType d0) (T1 : measurableType d1) (T2 : measurableType d2) (T3 : measurableType d3) (R : realType). -Definition pairAr d (T : measurableType d) t : - ([the measurableType _ of T0 * T1] -> - [the measurableType _ of T0 * (T1 * T)])%type := +Definition pairAr d (T : measurableType d) t : T0 * T1 -> T0 * (T1 * T) := pairA \o rpair T t. Arguments pairAr {d} T. Lemma mpairAr d (T : measurableType d) t : measurable_fun setT (pairAr T t). Proof. exact: measurableT_comp. Qed. -Definition pairAAr : ([the measurableType _ of T0 * T1 * T2] -> - [the measurableType _ of T0 * (T1 * (T2 * munit))])%type := - pairA \o pairA \o rpair munit tt. +Definition pairAAr : T0 * T1 * T2 -> T0 * (T1 * (T2 * unit)) := + pairA \o pairA \o rpair unit tt. Lemma mpairAAr : measurable_fun setT pairAAr. Proof. by do 2 apply: measurableT_comp => //. Qed. -Definition pairAAAr : ([the measurableType _ of T0 * T1 * T2 * T3] -> - [the measurableType _ of T0 * (T1 * (T2 * (T3 * munit)))])%type := - pairA \o pairA \o pairA \o rpair munit tt. +Definition pairAAAr : T0 * T1 * T2 * T3 -> T0 * (T1 * (T2 * (T3 * unit))) := + pairA \o pairA \o pairA \o rpair unit tt. Lemma mpairAAAr : measurable_fun setT pairAAAr. Proof. by do 3 apply: measurableT_comp => //. Qed. -Definition pairAArAi : ([the measurableType _ of T0 * (T1 * T2)] -> - [the measurableType _ of T0 * (T1 * (T2 * munit))])%type := +Definition pairAArAi : T0 * (T1 * T2) -> T0 * (T1 * (T2 * unit)) := pairAAr \o pairAi. Lemma mpairAArAi : measurable_fun setT pairAArAi. Proof. by apply: measurableT_comp => //=; exact: mpairAAr. Qed. -Definition pairAAArAAi : ([the measurableType _ of T3 * (T0 * (T1 * T2))] -> - [the measurableType _ of T3 * (T0 * (T1 * (T2 * munit)))])%type := - pairA \o pairA \o pairA \o rpair munit tt \o pairAi \o pairAi. +Definition pairAAArAAi : T3 * (T0 * (T1 * T2)) -> T3 * (T0 * (T1 * (T2 * unit))) := + pairA \o pairA \o pairA \o rpair unit tt \o pairAi \o pairAi. Lemma mpairAAARAAAi : measurable_fun setT pairAAArAAi. Proof. by do 5 apply: measurableT_comp => //=. Qed. @@ -1795,92 +1443,91 @@ Import Notations. Context d0 d1 d2 d3 (T0 : measurableType d0) (T1 : measurableType d1) (T2 : measurableType d2) (T3 : measurableType d3) (R : realType). -Definition Of2 := [:: existT _ _ T0; existT _ _ T1]. +Definition T01 : seq {d & measurableType d} := [:: existT _ _ T0; existT _ _ T1]. -Definition acc0of2 : [the measurableType _ of (T0 * T1)%type] -> T0 := - @acc Of2 0 \o pairAr munit tt. +Definition acc0of2 : T0 * T1 -> T0 := + acc T01 0 \o pairAr unit tt. Lemma macc0of2 : measurable_fun setT acc0of2. Proof. -by apply: measurableT_comp; [exact: (measurable_acc Of2 0)|exact: mpairAr]. +by apply: measurableT_comp; [exact: (measurable_acc T01 0)|exact: mpairAr]. Qed. -Definition acc1of2 : [the measurableType _ of (T0 * T1)%type] -> T1 := - acc Of2 1 \o pairAr munit tt. +Definition acc1of2 : T0 * T1 -> T1 := + acc T01 1 \o pairAr unit tt. Lemma macc1of2 : measurable_fun setT acc1of2. Proof. -by apply: measurableT_comp; [exact: (measurable_acc Of2 1)|exact: mpairAr]. +by apply: measurableT_comp; [exact: (measurable_acc T01 1)|exact: mpairAr]. Qed. -Definition Of3 := [:: existT _ _ T0; existT _ _ T1; existT _ d2 T2]. +Definition T02 := [:: existT _ _ T0; existT _ _ T1; existT _ _ T2]. -Definition acc1of3 : [the measurableType _ of (T0 * T1 * T2)%type] -> T1 := - acc Of3 1 \o pairAAr. +Definition acc1of3 : T0 * T1 * T2 -> T1 := + acc T02 1 \o pairAAr. Lemma macc1of3 : measurable_fun setT acc1of3. Proof. -by apply: measurableT_comp; [exact: (measurable_acc Of3 1)|exact: mpairAAr]. +by apply: measurableT_comp; [exact: (measurable_acc T02 1)|exact: mpairAAr]. Qed. -Definition acc2of3 : [the measurableType _ of (T0 * T1 * T2)%type] -> T2 := - acc Of3 2 \o pairAAr. +Definition acc2of3 : T0 * T1 * T2 -> T2 := + acc T02 2 \o pairAAr. Lemma macc2of3 : measurable_fun setT acc2of3. Proof. -by apply: measurableT_comp; [exact: (measurable_acc Of3 2)|exact: mpairAAr]. +by apply: measurableT_comp; [exact: (measurable_acc T02 2)|exact: mpairAAr]. Qed. -Definition acc0of3' : [the measurableType _ of (T0 * (T1 * T2))%type] -> T0 := - acc Of3 0 \o pairAArAi. +Definition acc0of3' : T0 * (T1 * T2) -> T0 := + acc T02 0 \o pairAArAi. Lemma macc0of3' : measurable_fun setT acc0of3'. Proof. -by apply: measurableT_comp; [exact: (measurable_acc Of3 0)|exact: mpairAArAi]. +by apply: measurableT_comp; [exact: (measurable_acc T02 0)|exact: mpairAArAi]. Qed. -Definition acc1of3' : [the measurableType _ of (T0 * (T1 * T2))%type] -> T1 := - acc Of3 1 \o pairAArAi. +Definition acc1of3' : T0 * (T1 * T2) -> T1 := + acc T02 1 \o pairAArAi. Lemma macc1of3' : measurable_fun setT acc1of3'. Proof. -by apply: measurableT_comp; [exact: (measurable_acc Of3 1)|exact: mpairAArAi]. +by apply: measurableT_comp; [exact: (measurable_acc T02 1)|exact: mpairAArAi]. Qed. -Definition acc2of3' : [the measurableType _ of (T0 * (T1 * T2))%type] -> T2 := - acc Of3 2 \o pairAArAi. +Definition acc2of3' : T0 * (T1 * T2) -> T2 := + acc T02 2 \o pairAArAi. Lemma macc2of3' : measurable_fun setT acc2of3'. Proof. -by apply: measurableT_comp; [exact: (measurable_acc Of3 2)|exact: mpairAArAi]. +by apply: measurableT_comp; [exact: (measurable_acc T02 2)|exact: mpairAArAi]. Qed. -Definition Of4 := +Definition T03 := [:: existT _ _ T0; existT _ _ T1; existT _ d2 T2; existT _ d3 T3]. -Definition acc1of4 : [the measurableType _ of (T0 * T1 * T2 * T3)%type] -> T1 := - acc Of4 1 \o pairAAAr. +Definition acc1of4 : T0 * T1 * T2 * T3 -> T1 := + acc T03 1 \o pairAAAr. Lemma macc1of4 : measurable_fun setT acc1of4. Proof. -by apply: measurableT_comp; [exact: (measurable_acc Of4 1)|exact: mpairAAAr]. +by apply: measurableT_comp; [exact: (measurable_acc T03 1)|exact: mpairAAAr]. Qed. -Definition acc2of4' : - [the measurableType _ of (T0 * (T1 * (T2 * T3)))%type] -> T2 := - acc Of4 2 \o pairAAArAAi. +Definition acc2of4' : T0 * (T1 * (T2 * T3)) -> T2 := + acc T03 2 \o pairAAArAAi. Lemma macc2of4' : measurable_fun setT acc2of4'. Proof. -by apply: measurableT_comp; [exact: (measurable_acc Of4 2)|exact: mpairAAARAAAi]. +by apply: measurableT_comp; [exact: (measurable_acc T03 2)|exact: mpairAAARAAAi]. Qed. -Definition acc3of4 : [the measurableType _ of (T0 * T1 * T2 * T3)%type] -> T3 := - acc Of4 3 \o pairAAAr. +Definition acc3of4 : T0 * T1 * T2 * T3 -> T3 := + acc T03 3 \o pairAAAr. Lemma macc3of4 : measurable_fun setT acc3of4. Proof. -by apply: measurableT_comp; [exact: (measurable_acc Of4 3)|exact: mpairAAAr]. +by apply: measurableT_comp; [exact: (measurable_acc T03 3)|exact: mpairAAAr]. Qed. End accessor_functions. @@ -1895,259 +1542,575 @@ Arguments macc1of4 {d0 d1 d2 d3 _ _ _ _}. Arguments macc2of4' {d0 d1 d2 d3 _ _ _ _}. Arguments macc3of4 {d0 d1 d2 d3 _ _ _ _}. -Section insn1_lemmas. -Import Notations. -Context d (T : measurableType d) (R : realType). - -Let kcomp_scoreE d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) - (g : R.-sfker [the measurableType _ of (T1 * unit)%type] ~> T2) - f (mf : measurable_fun setT f) r U : - (score mf \; g) r U = `|f r|%:E * g (r, tt) U. -Proof. -rewrite /= /kcomp /kscore /= ge0_integral_mscale//=. -by rewrite integral_dirac// diracT mul1e. -Qed. +Module CASE_NAT. +Section case_nat. +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Lemma scoreE d' (T' : measurableType d') (x : T * T') (U : set T') (f : R -> R) - (r : R) (r0 : (0 <= r)%R) - (f0 : (forall r, 0 <= r -> 0 <= f r)%R) (mf : measurable_fun setT f) : - score (measurableT_comp mf (@macc1of2 _ _ _ _)) - (x, r) (curry (snd \o fst) x @^-1` U) = - (f r)%:E * \d_x.2 U. -Proof. -by rewrite /score/= /mscale/= ger0_norm//= f0. -Qed. +Section case_nat_ker. +Variable k : R.-ker X ~> Y. -Lemma score_score (f : R -> R) (g : R * unit -> R) - (mf : measurable_fun setT f) - (mg : measurable_fun setT g) : - letin (score mf) (score mg) = - score (measurable_funM mf (measurableT_comp mg (measurable_pair2 tt))). -Proof. -apply/eq_sfkernel => x U. -rewrite {1}/letin; unlock. -by rewrite kcomp_scoreE/= /mscale/= diracE normrM muleA EFinM. -Qed. +Definition case_nat_ m (xn : X * nat) : {measure set Y -> \bar R} := + if xn.2 == m then k xn.1 else mzero. -(* hard constraints to express score below 1 *) -Lemma score_fail (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : - score (kr r%:num) = - letin (sample_cst (bernoulli r1) : R.-pker T ~> _) - (ite (@macc1of2 _ _ _ _) (ret ktt) fail). +Let measurable_fun_case_nat_ m U : measurable U -> + measurable_fun setT (case_nat_ m ^~ U). Proof. -apply/eq_sfkernel => x U. -rewrite letinE/= /sample; unlock. -rewrite integral_measure_add//= ge0_integral_mscale//= ge0_integral_mscale//=. -rewrite integral_dirac//= integral_dirac//= !diracT/= !mul1e. -by rewrite /mscale/= iteE//= iteE//= failE mule0 adde0 ger0_norm. +move=> mU; rewrite /case_nat_ (_ : (fun _ => _) = + (fun x => if x.2 == m then k x.1 U else mzero U)) /=; last first. + by apply/funext => -[t b]/=; case: ifPn. +apply: (@measurable_fun_if_pair_nat _ _ _ _ (k ^~ U) (fun=> mzero U)) => //. +exact/measurable_kernel. Qed. -End insn1_lemmas. +#[export] +HB.instance Definition _ m := isKernel.Build _ _ _ _ _ + (case_nat_ m) (measurable_fun_case_nat_ m). +End case_nat_ker. -Section letin_ite. -Context d d2 d3 (T : measurableType d) (T2 : measurableType d2) - (Z : measurableType d3) (R : realType). -Variables (k1 k2 : R.-sfker T ~> Z) - (u : R.-sfker [the measurableType _ of (T * Z)%type] ~> T2) - (f : T -> bool) (mf : measurable_fun setT f) - (t : T) (U : set T2). +Section sfcase_nat. +Variable k : R.-sfker X ~> Y. -Lemma letin_iteT : f t -> letin (ite mf k1 k2) u t U = letin k1 u t U. +Let sfcase_nat_ m : exists2 k_ : (R.-ker _ ~> _)^nat, + forall n, measure_fam_uub (k_ n) & + forall x U, measurable U -> case_nat_ k m x U = mseries (k_ ^~ x) 0 U. Proof. -move=> ftT. -rewrite !letinE/=. -apply: eq_measure_integral => V mV _. -by rewrite iteE ftT. +have [k_ hk /=] := sfinite_kernel k. +exists (fun n => case_nat_ (k_ n) m) => /=. + move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). + exists r%:num => /= -[x [|n']]; rewrite /case_nat_//= /mzero//. + by case: ifPn => //= ?; rewrite /mzero. + by case: ifPn => // ?; rewrite /= /mzero. +move=> [x b] U mU; rewrite /case_nat_; case: ifPn => hb; first by rewrite hk. +by rewrite /mseries eseries0. Qed. -Lemma letin_iteF : ~~ f t -> letin (ite mf k1 k2) u t U = letin k2 u t U. +#[export] +HB.instance Definition _ m := @Kernel_isSFinite_subdef.Build _ _ _ _ _ + (case_nat_ k m) (sfcase_nat_ m). +End sfcase_nat. + +Section fkcase_nat. +Variable k : R.-fker X ~> Y. + +Let case_nat_uub n : measure_fam_uub (case_nat_ k n). Proof. -move=> ftF. -rewrite !letinE/=. -apply: eq_measure_integral => V mV _. -by rewrite iteE (negbTE ftF). +have /measure_fam_uubP[M hM] := measure_uub k. +exists M%:num => /= -[]; rewrite /case_nat_ => t [|n']/=. + by case: ifPn => //= ?; rewrite /mzero. +by case: ifPn => //= ?; rewrite /mzero. Qed. -End letin_ite. +#[export] +HB.instance Definition _ n := Kernel_isFinite.Build _ _ _ _ _ + (case_nat_ k n) (case_nat_uub n). +End fkcase_nat. -Section letinA. -Context d d' d1 d2 d3 (X : measurableType d) (Y : measurableType d') - (T1 : measurableType d1) (T2 : measurableType d2) (T3 : measurableType d3) - (R : realType). -Import Notations. -Variables (t : R.-sfker X ~> T1) - (u : R.-sfker [the measurableType _ of (X * T1)%type] ~> T2) - (v : R.-sfker [the measurableType _ of (X * T2)%type] ~> Y) - (v' : R.-sfker [the measurableType _ of (X * T1 * T2)%type] ~> Y) - (vv' : forall y, v =1 fun xz => v' (xz.1, y, xz.2)). +End case_nat. +End CASE_NAT. -Lemma letinA x A : measurable A -> - letin t (letin u v') x A - = - (letin (letin t u) v) x A. -Proof. -move=> mA. -rewrite !letinE. -under eq_integral do rewrite letinE. -rewrite integral_kcomp; [|by []|]. -- apply: eq_integral => y _. - apply: eq_integral => z _. - by rewrite (vv' y). -exact: (measurableT_comp (measurable_kernel v _ mA)). -Qed. +Import CASE_NAT. -End letinA. +Section case_nat. +Context d d' (T : measurableType d) (T' : measurableType d') (R : realType). -Section letinC. -Context d d1 d' (X : measurableType d) (Y : measurableType d1) - (Z : measurableType d') (R : realType). +Import CASE_NAT. -Import Notations. +Definition case_nat (t : R.-sfker T ~> nat) (u_ : (R.-sfker T ~> T')^nat) + : R.-sfker T ~> T' := + t \; kseries (fun n => case_nat_ (u_ n) n). -Variables (t : R.-sfker Z ~> X) - (t' : R.-sfker [the measurableType _ of (Z * Y)%type] ~> X) - (tt' : forall y, t =1 fun z => t' (z, y)) - (u : R.-sfker Z ~> Y) - (u' : R.-sfker [the measurableType _ of (Z * X)%type] ~> Y) - (uu' : forall x, u =1 fun z => u' (z, x)). +End case_nat. -Definition T z : set X -> \bar R := t z. -Let T0 z : (T z) set0 = 0. Proof. by []. Qed. -Let T_ge0 z x : 0 <= (T z) x. Proof. by []. Qed. -Let T_semi_sigma_additive z : semi_sigma_additive (T z). -Proof. exact: measure_semi_sigma_additive. Qed. -HB.instance Definition _ z := @isMeasure.Build _ X R (T z) (T0 z) (T_ge0 z) - (@T_semi_sigma_additive z). +Definition measure_sum_display : + (measure_display * measure_display) -> measure_display. +Proof. exact. Qed. -Let sfinT z : sfinite_measure (T z). Proof. exact: sfinite_kernel_measure. Qed. +Definition image_classes d1 d2 + (T1 : measurableType d1) (T2 : measurableType d2) (T : Type) + (f1 : T1 -> T) (f2 : T2 -> T) := + <>. -HB.instance Definition _ z := @isSFinite.Build _ X R (T z) (sfinT z). +Section sum_salgebra_instance. +Context d1 d2 (T1 : measurableType d1) (T2 : measurableType d2). +Let f1 : T1 -> T1 + T2 := @inl T1 T2. +Let f2 : T2 -> T1 + T2 := @inr T1 T2. -Definition U z : set Y -> \bar R := u z. -Let U0 z : (U z) set0 = 0. Proof. by []. Qed. -Let U_ge0 z x : 0 <= (U z) x. Proof. by []. Qed. -Let U_semi_sigma_additive z : semi_sigma_additive (U z). -Proof. exact: measure_semi_sigma_additive. Qed. -HB.instance Definition _ z := @isMeasure.Build _ Y R (U z) (U0 z) (U_ge0 z) - (@U_semi_sigma_additive z). +Lemma sum_salgebra_set0 : image_classes f1 f2 (set0 : set (T1 + T2)). +Proof. exact: sigma_algebra0. Qed. -Let sfinU z : sfinite_measure (U z). Proof. exact: sfinite_kernel_measure. Qed. -HB.instance Definition _ z := @isSFinite.Build _ Y R (U z) (sfinU z). +Lemma sum_salgebra_setC A : image_classes f1 f2 A -> + image_classes f1 f2 (~` A). +Proof. exact: sigma_algebraC. Qed. -Lemma letinC z A : measurable A -> - letin t - (letin u' - (ret (measurable_fun_prod macc1of3 macc2of3))) z A = - letin u - (letin t' - (ret (measurable_fun_prod macc2of3 macc1of3))) z A. -Proof. -move=> mA. -rewrite !letinE. -under eq_integral. - move=> x _. - rewrite letinE -uu'. - under eq_integral do rewrite retE /=. - over. -rewrite (sfinite_Fubini - [the {sfinite_measure set X -> \bar R} of T z] - [the {sfinite_measure set Y -> \bar R} of U z] - (fun x => \d_(x.1, x.2) A ))//; last first. - apply/EFin_measurable_fun => /=; rewrite (_ : (fun x => _) = mindic R mA)//. - by apply/funext => -[]. -rewrite /=. -apply: eq_integral => y _. -by rewrite letinE/= -tt'; apply: eq_integral => // x _; rewrite retE. -Qed. +Lemma sum_salgebra_bigcup (F : _^nat) : (forall i, image_classes f1 f2 (F i)) -> + image_classes f1 f2 (\bigcup_i (F i)). +Proof. exact: sigma_algebra_bigcup. Qed. -End letinC. +HB.instance Definition sum_salgebra_mixin := + @isMeasurable.Build (measure_sum_display (d1, d2)) + (T1 + T2)%type (image_classes f1 f2) + (sum_salgebra_set0) (sum_salgebra_setC) (sum_salgebra_bigcup). -(* sample programs *) -Section poisson. -Variable R : realType. -Local Open Scope ring_scope. +End sum_salgebra_instance. +Reserved Notation "p .-sum" (at level 1, format "p .-sum"). +Reserved Notation "p .-sum.-measurable" + (at level 2, format "p .-sum.-measurable"). +Notation "p .-sum" := (measure_sum_display p) : measure_display_scope. +Notation "p .-sum.-measurable" := + ((p.-sum).-measurable : set (set (_ + _))) : + classical_set_scope. -(* density function for Poisson *) -Definition poisson k r : R := - if r > 0 then r ^+ k / k`!%:R^-1 * expR (- r) else 1%:R. +Module CASE_SUM. -Lemma poisson_ge0 k r : 0 <= poisson k r. -Proof. -rewrite /poisson; case: ifPn => r0//. -by rewrite mulr_ge0 ?expR_ge0// mulr_ge0// exprn_ge0 ?ltW. -Qed. +Section case_sum'. -Lemma poisson_gt0 k r : 0 < r -> 0 < poisson k.+1 r. -Proof. -move=> r0; rewrite /poisson r0 mulr_gt0 ?expR_gt0//. -by rewrite divr_gt0// ?exprn_gt0// invr_gt0 ltr0n fact_gt0. -Qed. +Section kcase_sum'. +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). +Let A : measurableType _ := unit. +Let B : measurableType _ := bool. +Variables (k1 : A -> R.-sfker X ~> Y) (k2 : B -> R.-sfker X ~> Y). -Lemma measurable_poisson k : measurable_fun setT (poisson k). +Definition case_sum' : X * (A + B) -> {measure set Y -> \bar R} := + fun xab => match xab with + | (x, inl a) => k1 a x + | (x, inr b) => k2 b x + end. + +Let measurable_fun_case_sum' U : measurable U -> + measurable_fun setT (case_sum' ^~ U). Proof. -rewrite /poisson; apply: measurable_fun_if => //. - apply: (measurable_fun_bool true). - rewrite (_ : _ @^-1` _ = `]0, +oo[%classic)//. - by apply/seteqP; split => x /=; rewrite in_itv/= andbT. -by apply: measurable_funM => /=; - [exact: measurable_funM|exact: measurableT_comp]. +rewrite /= => mU. +apply: (measurability (ErealGenInftyO.measurableE R)) => //. +move=> /= _ [_ [x ->] <-]; apply: measurableI => //. +rewrite /case_sum'/= (_ : _ @^-1` _ = + ([set x1 | k1 tt x1 U < x%:E] `*` inl @` [set tt]) `|` + ([set x1 | k2 false x1 U < x%:E] `*` inr @` [set false]) `|` + ([set x1 | k2 true x1 U < x%:E] `*` inr @` [set true])); last first. + apply/seteqP; split. + - move=> z /=; rewrite in_itv/=; move: z => [z [[]|[|]]]//= ?. + + by do 2 left; split => //; exists tt. + + by right; split => //; exists true. + + by left; right; split => //; exists false. + - move=> z /=; rewrite in_itv/=; move: z => [z [[]|[|]]]//=. + - move=> [[[]//|]|]. + + by move=> [_ []]. + + by move=> [_ []]. + - move=> [[|]|[]//]. + + by move=> [_ []]. + + by move=> [_ [] [|]]. + - move=> [[|[]//]|]. + + by move=> [_ []]. + + by move=> [_ [] [|]]. +pose h1 := [set xub : X * (unit + bool) | k1 tt xub.1 U < x%:E]. +have mh1 : measurable h1. + rewrite -[X in measurable X]setTI; apply: emeasurable_fun_infty_o => //=. + have H : measurable_fun [set: X] (fun x => k1 tt x U) by exact/measurable_kernel. + move=> _ /= C mC; rewrite setTI. + have := H measurableT _ mC; rewrite setTI => {}H. + rewrite [X in measurable X](_ : _ = ((fun x => k1 tt x U) @^-1` C) `*` setT)//. + exact: measurableM. + by apply/seteqP; split => [z//=| z/= []]. +set h2 := [set xub : X * (unit + bool)| k2 false xub.1 U < x%:E]. +have mh2 : measurable h2. + rewrite -[X in measurable X]setTI. + apply: emeasurable_fun_infty_o => //=. + have H : measurable_fun [set: X] (fun x => k2 false x U) by exact/measurable_kernel. + move=> _ /= C mC; rewrite setTI. + have := H measurableT _ mC; rewrite setTI => {}H. + rewrite [X in measurable X](_ : _ = ((fun x => k2 false x U) @^-1` C) `*` setT)//. + exact: measurableM. + by apply/seteqP; split => [z //=|z/= []]. +set h3 := [set xub : X * (unit + bool)| k2 true xub.1 U < x%:E]. +have mh3 : measurable h3. + rewrite -[X in measurable X]setTI. + apply: emeasurable_fun_infty_o => //=. + have H : measurable_fun [set: X] (fun x => k2 (true) x U) by exact/measurable_kernel. + move=> _ /= C mC; rewrite setTI. + have := H measurableT _ mC; rewrite setTI => {}H. + rewrite [X in measurable X](_ : _ = ((fun x => k2 (true) x U) @^-1` C) `*` setT)//. + exact: measurableM. + by apply/seteqP; split=> [z//=|z/= []]. +apply: measurableU. +- apply: measurableU. + + apply: measurableM => //. + rewrite [X in measurable X](_ : _ = ysection h1 (inl tt))//. + * by apply: measurable_ysection. + * by apply/seteqP; split => z /=; rewrite /ysection /= inE. + + apply: measurableM => //. + rewrite [X in measurable X](_ : _ = ysection h2 (inr false))//. + * by apply: measurable_ysection. + * by apply/seteqP; split => z /=; rewrite /ysection /= inE. +- apply: measurableM => //. + rewrite [X in measurable X](_ : _ = ysection h3 (inr true))//. + + by apply: measurable_ysection. + + by apply/seteqP; split => z /=; rewrite /ysection /= inE. +Qed. + +#[export] +HB.instance Definition _ := isKernel.Build _ _ _ _ _ + case_sum' measurable_fun_case_sum'. +End kcase_sum'. + +Section sfkcase_sum'. +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). +Let A : measurableType _ := unit. +Let B : measurableType _ := bool. +Variables (k1 : A -> R.-sfker X ~> Y) (k2 : B-> R.-sfker X ~> Y). + +Let sfinite_case_sum' : exists2 k_ : (R.-ker _ ~> _)^nat, + forall n, measure_fam_uub (k_ n) & + forall x U, measurable U -> case_sum' k1 k2 x U = mseries (k_ ^~ x) 0 U. +Proof. +rewrite /=. +set f1 : A -> (R.-fker _ ~> _)^nat := + fun ab : A => sval (cid (sfinite_kernel (k1 ab))). +set Hf1 := fun ab : A => svalP (cid (sfinite_kernel (k1 ab))). +rewrite /= in Hf1. +set f2 : B -> (R.-fker _ ~> _)^nat := + fun ab : B => sval (cid (sfinite_kernel (k2 ab))). +set Hf2 := fun ab : B => svalP (cid (sfinite_kernel (k2 ab))). +rewrite /= in Hf2. +exists (fun n => case_sum' (f1 ^~ n) (f2 ^~ n)). + move=> n /=. + have [rtt Hrtt] := measure_uub (f1 tt n). + have [rfalse Hrfalse] := measure_uub (f2 false n). + have [rtrue Hrtrue] := measure_uub (f2 true n). + exists (maxr rtt (maxr rfalse rtrue)) => //= -[x [[]|[|]]] /=. + by rewrite 2!EFin_max lt_max Hrtt. + by rewrite 2!EFin_max 2!lt_max Hrtrue 2!orbT. + by rewrite 2!EFin_max 2!lt_max Hrfalse orbT. +move=> [x [[]|[|]]] U mU/=-. +by rewrite (Hf1 tt x _ mU). +by rewrite (Hf2 true x _ mU). +by rewrite (Hf2 false x _ mU). Qed. -Definition poisson3 := poisson 4 3%:R. (* 0.168 *) -Definition poisson10 := poisson 4 10%:R. (* 0.019 *) +#[export] +HB.instance Definition _ := @Kernel_isSFinite_subdef.Build _ _ _ _ _ + (case_sum' k1 k2) (sfinite_case_sum'). +End sfkcase_sum'. -End poisson. +End case_sum'. -Section exponential. -Variable R : realType. -Local Open Scope ring_scope. +Section case_sum. +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). +Let A : measurableType _ := unit. +Let B : measurableType _ := bool. -(* density function for exponential *) -Definition exp_density x r : R := r * expR (- r * x). +(* case analysis on the datatype unit + bool *) +Definition case_sum (f : R.-sfker X ~> (A + B)%type) + (k1 : A -> R.-sfker X ~> Y) (k2 : B -> R.-sfker X ~> Y) : R.-sfker X ~> Y := + f \; case_sum' k1 k2. -Lemma exp_density_gt0 x r : 0 < r -> 0 < exp_density x r. -Proof. by move=> r0; rewrite /exp_density mulr_gt0// expR_gt0. Qed. +End case_sum. -Lemma exp_density_ge0 x r : 0 <= r -> 0 <= exp_density x r. -Proof. by move=> r0; rewrite /exp_density mulr_ge0// expR_ge0. Qed. +End CASE_SUM. -Lemma mexp_density x : measurable_fun setT (exp_density x). +(* counting measure as a kernel *) +Section kcounting. +Context d (G : measurableType d) (R : realType). + +Definition kcounting : G -> {measure set nat -> \bar R} := fun=> counting. + +Let mkcounting U : measurable U -> measurable_fun setT (kcounting ^~ U). +Proof. by []. Qed. + +HB.instance Definition _ := isKernel.Build _ _ _ _ _ kcounting mkcounting. + +Let sfkcounting : exists2 k_ : (R.-ker _ ~> _)^nat, + forall n, measure_fam_uub (k_ n) & + forall x U, measurable U -> kcounting x U = mseries (k_ ^~ x) 0 U. Proof. -apply: measurable_funM => //=; apply: measurableT_comp => //. -exact: measurable_funM. +exists (fun n => [the R.-fker _ ~> _ of + @kdirac _ _ G nat R _ (@measurable_cst _ _ _ _ setT n)]). + by move=> n /=; exact: measure_uub. +by move=> g U mU; rewrite /kcounting/= counting_dirac. Qed. -End exponential. +HB.instance Definition _ := + Kernel_isSFinite_subdef.Build _ _ _ _ R kcounting sfkcounting. -Lemma letin_sample_bernoulli d d' (T : measurableType d) - (T' : measurableType d') (R : realType)(r : {nonneg R}) (r1 : (r%:num <= 1)%R) - (u : R.-sfker [the measurableType _ of (T * bool)%type] ~> T') x y : - letin (sample_cst (bernoulli r1)) u x y = - r%:num%:E * u (x, true) y + (`1- (r%:num))%:E * u (x, false) y. +End kcounting. + +(* formalization of the iterate construct of Staton ESOP 2017, Sect. 4.2 *) +Section iterate. +Context d {G : measurableType d} {R : realType}. +Let A : measurableType _ := unit. +Let B : measurableType _ := bool. + +Import CASE_SUM. + +(* formalization of iterate^n + Gamma |-p iterate^n t from x = u : B *) +Variables (t : R.-sfker (G * A) ~> (A + B)%type) + (u : G -> A) (mu : measurable_fun setT u). + +Fixpoint iterate_ n : R.-sfker G ~> B := + match n with + | 0%N => case_sum (letin (ret mu) t) + (fun u' => fail) + (fun v => ret (measurable_cst v)) + | m.+1 => case_sum (letin (ret mu) t) + (fun u' => iterate_ m) + (fun v => fail) + end. + +(* formalization of iterate (A = unit, B = bool) + Gamma, x : A |-p t : A + B Gamma |-d u : A +----------------------------------------------- + Gamma |-p iterate t from x = u : B *) +Definition iterate : R.-sfker G ~> B := case_nat (kcounting R) iterate_. + +End iterate. + +(* an s-finite kernel to test that two expressions are different *) +Section lift_neq. +Context {R : realType} d (G : measurableType d). +Variables (f : G -> bool) (g : G -> bool). + +Definition flift_neq : G -> bool := fun x' => f x' != g x'. + +Hypotheses (mf : measurable_fun setT f) (mg : measurable_fun setT g). + +(* see also emeasurable_fun_neq *) +Lemma measurable_fun_flift_neq : measurable_fun setT flift_neq. Proof. -rewrite letinE/=. -rewrite ge0_integral_measure_sum// 2!big_ord_recl/= big_ord0 adde0/=. -by rewrite !ge0_integral_mscale//= !integral_dirac//= !diracT 2!mul1e. +apply: (measurable_fun_bool true). +rewrite /flift_neq /= (_ : _ @^-1` _ = ([set x | f x] `&` [set x | ~~ g x]) `|` + ([set x | ~~ f x] `&` [set x | g x])). + apply: measurableU; apply: measurableI. + - by rewrite -[X in measurable X]setTI; exact: mf. + - rewrite [X in measurable X](_ : _ = ~` [set x | g x]); last first. + by apply/seteqP; split => x /= /negP. + by apply: measurableC; rewrite -[X in measurable X]setTI; exact: mg. + - rewrite [X in measurable X](_ : _ = ~` [set x | f x]); last first. + by apply/seteqP; split => x /= /negP. + by apply: measurableC; rewrite -[X in measurable X]setTI; exact: mf. + - by rewrite -[X in measurable X]setTI; exact: mg. +by apply/seteqP; split => x /=; move: (f x) (g x) => [|] [|]//=; intuition. Qed. +Definition lift_neq : R.-sfker G ~> bool := ret measurable_fun_flift_neq. + +End lift_neq. + +Section von_neumann_trick. +Context d {T : measurableType d} {R : realType}. + +Definition minltt {d1 d2} {T1 : measurableType d1} {T2 : measurableType d2} := + @measurable_cst _ _ T1 _ setT (@inl unit T2 tt). + +Definition finrb d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) : + T1 * bool -> T2 + bool := fun t1b => inr t1b.2. + +Lemma minrb {d1 d2} {T1 : measurableType d1} {T2 : measurableType d2} : + measurable_fun setT (@finrb _ _ T1 T2). +Proof. exact: measurableT_comp. Qed. + +(* biased coin *) +Variable (D : pprobability bool R). + +Definition trick : R.-sfker (T * unit) ~> (unit + bool)%type := + letin (sample_cst D) + (letin (sample_cst D) + (letin (lift_neq macc1of3 macc2of3) + (ite macc3of4 + (letin (ret macc1of4) (ret minrb)) + (ret minltt)))). + +Definition von_neumann_trick : R.-sfker T ~> bool := iterate trick ktt. + +End von_neumann_trick. + +Section insn1_lemmas. +Import Notations. +Context d (T : measurableType d) (R : realType). + +Let kcomp_scoreE d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) + (g : R.-sfker [the measurableType _ of (T1 * unit)%type] ~> T2) + f (mf : measurable_fun setT f) r U : + (score mf \; g) r U = `|f r|%:E * g (r, tt) U. +Proof. +rewrite /= /kcomp /kscore /= ge0_integral_mscale//=. +by rewrite integral_dirac// diracT mul1e. +Qed. + +Lemma scoreE d' (T' : measurableType d') (x : T * T') (U : set T') (f : R -> R) + (r : R) (r0 : (0 <= r)%R) + (f0 : (forall r, 0 <= r -> 0 <= f r)%R) (mf : measurable_fun setT f) : + score (measurableT_comp mf (@macc1of2 _ _ _ _)) + (x, r) (curry (snd \o fst) x @^-1` U) = + (f r)%:E * \d_x.2 U. +Proof. +by rewrite /score/= /mscale/= ger0_norm//= f0. +Qed. + +Lemma score_score (f : R -> R) (g : R * unit -> R) + (mf : measurable_fun setT f) + (mg : measurable_fun setT g) : + letin (score mf) (score mg) = + score (measurable_funM mf (measurableT_comp mg (measurable_pair2 tt))). +Proof. +apply/eq_sfkernel => x U. +rewrite {1}/letin; unlock. +by rewrite kcomp_scoreE/= /mscale/= diracE normrM muleA EFinM. +Qed. + +(* hard constraints to express score below 1 *) +Lemma score_fail (r : R) : (0 <= r <= 1)%R -> + score (kr r) = + letin (sample_cst (bernoulli r) : R.-pker T ~> _) + (ite (@macc1of2 _ _ _ _) (ret ktt) fail). +Proof. +move=> /andP[r0 r1]; apply/eq_sfkernel => x U. +rewrite letinE/= /sample; unlock. +by rewrite /mscale/= ger0_norm// integral_bernoulli ?r0//= 2!iteE//= failE mule0 adde0. +Qed. + +End insn1_lemmas. + +Section letin_ite. +Context d d2 d3 (T : measurableType d) (T2 : measurableType d2) + (Z : measurableType d3) (R : realType). +Variables (k1 k2 : R.-sfker T ~> Z) + (u : R.-sfker [the measurableType _ of (T * Z)%type] ~> T2) + (f : T -> bool) (mf : measurable_fun setT f) + (t : T) (U : set T2). + +Lemma letin_iteT : f t -> letin (ite mf k1 k2) u t U = letin k1 u t U. +Proof. +move=> ftT; rewrite !letinE/=; apply: eq_measure_integral => V mV _. +by rewrite iteE ftT. +Qed. + +Lemma letin_iteF : ~~ f t -> letin (ite mf k1 k2) u t U = letin k2 u t U. +Proof. +move=> ftF; rewrite !letinE/=; apply: eq_measure_integral => V mV _. +by rewrite iteE (negbTE ftF). +Qed. + +End letin_ite. + +Section letinA. +Context d d' d1 d2 d3 (X : measurableType d) (Y : measurableType d') + (T1 : measurableType d1) (T2 : measurableType d2) (T3 : measurableType d3) + (R : realType). +Import Notations. +Variables (t : R.-sfker X ~> T1) + (u : R.-sfker [the measurableType _ of (X * T1)%type] ~> T2) + (v : R.-sfker [the measurableType _ of (X * T2)%type] ~> Y) + (v' : R.-sfker [the measurableType _ of (X * T1 * T2)%type] ~> Y) + (vv' : forall y, v =1 fun xz => v' (xz.1, y, xz.2)). + +Lemma letinA x A : measurable A -> + letin t (letin u v') x A + = + (letin (letin t u) v) x A. +Proof. +move=> mA. +rewrite !letinE. +under eq_integral do rewrite letinE. +rewrite integral_kcomp; [|by []|]. +- apply: eq_integral => y _. + apply: eq_integral => z _. + by rewrite (vv' y). +- exact: (measurableT_comp (measurable_kernel v _ mA)). +Qed. + +End letinA. + +Section letinC. +Context d d1 d' (X : measurableType d) (Y : measurableType d1) + (Z : measurableType d') (R : realType). + +Import Notations. + +Variables (t : R.-sfker Z ~> X) + (t' : R.-sfker [the measurableType _ of (Z * Y)%type] ~> X) + (tt' : forall y, t =1 fun z => t' (z, y)) + (u : R.-sfker Z ~> Y) + (u' : R.-sfker [the measurableType _ of (Z * X)%type] ~> Y) + (uu' : forall x, u =1 fun z => u' (z, x)). + +Definition T z : set X -> \bar R := t z. +Let T0 z : (T z) set0 = 0. Proof. by []. Qed. +Let T_ge0 z x : 0 <= (T z) x. Proof. by []. Qed. +Let T_semi_sigma_additive z : semi_sigma_additive (T z). +Proof. exact: measure_semi_sigma_additive. Qed. +HB.instance Definition _ z := @isMeasure.Build _ X R (T z) (T0 z) (T_ge0 z) + (@T_semi_sigma_additive z). + +Let sfinT z : sfinite_measure (T z). Proof. exact: sfinite_kernel_measure. Qed. +HB.instance Definition _ z := @isSFinite.Build _ X R (T z) (sfinT z). + +Definition U z : set Y -> \bar R := u z. +Let U0 z : (U z) set0 = 0. Proof. by []. Qed. +Let U_ge0 z x : 0 <= (U z) x. Proof. by []. Qed. +Let U_semi_sigma_additive z : semi_sigma_additive (U z). +Proof. exact: measure_semi_sigma_additive. Qed. +HB.instance Definition _ z := @isMeasure.Build _ Y R (U z) (U0 z) (U_ge0 z) + (@U_semi_sigma_additive z). + +Let sfinU z : sfinite_measure (U z). Proof. exact: sfinite_kernel_measure. Qed. +HB.instance Definition _ z := @isSFinite.Build _ Y R (U z) (sfinU z). + +Lemma letinC z A : measurable A -> + letin t + (letin u' + (ret (measurable_fun_prod macc1of3 macc2of3))) z A = + letin u + (letin t' + (ret (measurable_fun_prod macc2of3 macc1of3))) z A. +Proof. +move=> mA. +rewrite !letinE. +under eq_integral. + move=> x _. + rewrite letinE -uu'. + under eq_integral do rewrite retE /=. + over. +rewrite (sfinite_Fubini + [the {sfinite_measure set X -> \bar R} of T z] + [the {sfinite_measure set Y -> \bar R} of U z] + (fun x => \d_(x.1, x.2) A ))//; last first. + apply/EFin_measurable_fun => /=; rewrite (_ : (fun x => _) = mindic R mA)//. + by apply/funext => -[]. +rewrite /=. +apply: eq_integral => y _. +by rewrite letinE/= -tt'; apply: eq_integral => // x _; rewrite retE. +Qed. + +End letinC. + +(* examples *) + +Lemma letin_sample_bernoulli d d' (T : measurableType d) + (T' : measurableType d') (R : realType) (r : R) + (u : R.-sfker [the measurableType _ of (T * bool)%type] ~> T') x y : + (0 <= r <= 1)%R -> + letin (sample_cst (bernoulli r)) u x y = + r%:E * u (x, true) y + (`1- r)%:E * u (x, false) y. +Proof. by move=> r01; rewrite letinE/= integral_bernoulli. Qed. + Section sample_and_return. Import Notations. Context d (T : measurableType d) (R : realType). Definition sample_and_return : R.-sfker T ~> _ := letin - (sample_cst [the probability _ _ of bernoulli p27]) (* T -> B *) + (sample_cst (bernoulli (2 / 7))) (* T -> B *) (ret macc1of2) (* T * B -> B *). Lemma sample_and_returnE t U : sample_and_return t U = (2 / 7%:R)%:E * \d_true U + (5%:R / 7%:R)%:E * \d_false U. Proof. -by rewrite /sample_and_return letin_sample_bernoulli !retE onem27. +rewrite /sample_and_return letin_sample_bernoulli; last lra. +by rewrite !retE onem27. Qed. End sample_and_return. -(* trivial example *) Section sample_and_branch. Import Notations. Context d (T : measurableType d) (R : realType). @@ -2158,14 +2121,14 @@ Context d (T : measurableType d) (R : realType). Definition sample_and_branch : R.-sfker T ~> _ := letin - (sample_cst [the probability _ _ of bernoulli p27]) (* T -> B *) + (sample_cst (bernoulli (2 / 7))) (* T -> B *) (ite macc1of2 (ret (@k3 _ _ R)) (ret k10)). Lemma sample_and_branchE t U : sample_and_branch t U = - (2 / 7%:R)%:E * \d_(3%:R : R) U + - (5%:R / 7%:R)%:E * \d_(10%:R : R) U. + (2 / 7)%:E * \d_(3 : R) U + (5 / 7)%:E * \d_(10 : R) U. Proof. -by rewrite /sample_and_branch letin_sample_bernoulli/= !iteE !retE onem27. +rewrite /sample_and_branch letin_sample_bernoulli/=; last lra. +by rewrite !iteE !retE onem27. Qed. End sample_and_branch. @@ -2175,40 +2138,23 @@ Context d (T : measurableType d) (R : realType). Import Notations. Definition bernoulli_and : R.-sfker T ~> mbool := - (letin (sample_cst [the probability _ _ of bernoulli p12]) - (letin (sample_cst [the probability _ _ of bernoulli p12]) + (letin (sample_cst (bernoulli (1 / 2))) + (letin (sample_cst (bernoulli (1 / 2))) (ret (measurable_and macc1of3 macc2of3)))). -(* -Definition mand (x y : T * mbool * mbool -> mbool) - (t : T * mbool * mbool) : mbool := x t && y t. - -Lemma measurable_fun_mand (x y : T * mbool * mbool -> mbool) : - measurable_fun setT x -> measurable_fun setT y -> - measurable_fun setT (mand x y). -Proof. -move=> /= mx my; apply: (measurable_fun_bool true). -rewrite [X in measurable X](_ : _ = - (x @^-1` [set true]) `&` (y @^-1` [set true])); last first. - by rewrite /mand; apply/seteqP; split => z/= /andP. -apply: measurableI. -- by rewrite -[X in measurable X]setTI; exact: mx. -- by rewrite -[X in measurable X]setTI; exact: my. -Qed. - -Definition bernoulli_and : R.-sfker T ~> mbool := - (letin (sample_cst [the probability _ _ of bernoulli p12]) - (letin (sample_cst [the probability _ _ of bernoulli p12]) - (ret (measurable_fun_mand macc1of3 macc2of3)))). -*) Lemma bernoulli_andE t U : - bernoulli_and t U = - sample_cst (bernoulli p14) t U. + bernoulli_and t U = sample_cst (bernoulli (1 / 4)) t U. Proof. -rewrite /bernoulli_and 3!letin_sample_bernoulli/= muleDr//= -muleDl//. +rewrite /bernoulli_and. +rewrite letin_sample_bernoulli; last lra. +rewrite (letin_sample_bernoulli (r := 1 / 2)); last lra. +rewrite (letin_sample_bernoulli (r := 1 / 2)); last lra. +rewrite muleDr//= -muleDl//. rewrite !muleA -addeA -muleDl// -!EFinM !onem1S/= -splitr mulr1. have -> : (1 / 2 * (1 / 2) = 1 / 4%:R :> R)%R by rewrite mulf_div mulr1// -natrM. -rewrite /bernoulli/= measure_addE/= /mscale/= -!EFinM; congr( _ + (_ * _)%:E). +rewrite [in RHS](_ : 1 / 4 = (1 / 4)%:nng%:num)%R//. +rewrite (bernoulliE p14). +rewrite measure_addE/= /mscale/= -!EFinM; congr( _ + (_ * _)%:E). have -> : (1 / 2 = 2 / 4%:R :> R)%R. by apply/eqP; rewrite eqr_div// ?pnatr_eq0// mul1r -natrM. by rewrite onem1S// -mulrDl. @@ -2221,7 +2167,7 @@ Import Notations. Context d (T : measurableType d) (R : realType) (h : R -> R). Hypothesis mh : measurable_fun setT h. Definition kstaton_bus : R.-sfker T ~> mbool := - letin (sample_cst [the probability _ _ of bernoulli p27]) + letin (sample_cst (bernoulli (2 / 7))) (letin (letin (ite macc1of2 (ret k3) (ret k10)) (score (measurableT_comp mh macc2of3))) @@ -2238,43 +2184,43 @@ End staton_bus. Section staton_bus_poisson. Import Notations. Context d (T : measurableType d) (R : realType). -Let poisson4 := @poisson R 4%N. -Let mpoisson4 := @measurable_poisson R 4%N. +Let poisson4 := @poisson_pdf R 4%N. +Let mpoisson4 := @measurable_poisson_pdf R 4%N. Definition kstaton_bus_poisson : R.-sfker R ~> mbool := kstaton_bus _ mpoisson4. Let kstaton_bus_poissonE t U : kstaton_bus_poisson t U = - (2 / 7%:R)%:E * (poisson4 3%:R)%:E * \d_true U + - (5%:R / 7%:R)%:E * (poisson4 10%:R)%:E * \d_false U. + (2 / 7)%:E * (poisson4 3)%:E * \d_true U + + (5 / 7)%:E * (poisson4 10)%:E * \d_false U. Proof. -rewrite /kstaton_bus. -rewrite letin_sample_bernoulli. +rewrite /kstaton_bus_poisson /kstaton_bus. +rewrite letin_sample_bernoulli; last lra. rewrite -!muleA; congr (_ * _ + _ * _). - rewrite letin_kret//. rewrite letin_iteT//. rewrite letin_retk//. - by rewrite scoreE//= => r r0; exact: poisson_ge0. + by rewrite scoreE//= => r r0; exact: poisson_pdf_ge0. - by rewrite onem27. rewrite letin_kret//. rewrite letin_iteF//. rewrite letin_retk//. - by rewrite scoreE//= => r r0; exact: poisson_ge0. + by rewrite scoreE//= => r r0; exact: poisson_pdf_ge0. Qed. (* true -> 2/7 * 0.168 = 2/7 * 3^4 e^-3 / 4! *) (* false -> 5/7 * 0.019 = 5/7 * 10^4 e^-10 / 4! *) Lemma staton_busE P (t : R) U : - let N := ((2 / 7%:R) * poisson4 3%:R + - (5%:R / 7%:R) * poisson4 10%:R)%R in + let N := ((2 / 7) * poisson4 3 + + (5 / 7) * poisson4 10)%R in staton_bus mpoisson4 P t U = - ((2 / 7%:R)%:E * (poisson4 3%:R)%:E * \d_true U + - (5%:R / 7%:R)%:E * (poisson4 10%:R)%:E * \d_false U) * N^-1%:E. + ((2 / 7)%:E * (poisson4 3)%:E * \d_true U + + (5 / 7)%:E * (poisson4 10)%:E * \d_false U) * N^-1%:E. Proof. rewrite /staton_bus normalizeE !kstaton_bus_poissonE !diracT !mule1 ifF //. apply/negbTE; rewrite gt_eqF// lte_fin. -by rewrite addr_gt0// mulr_gt0//= ?divr_gt0// ?ltr0n// poisson_gt0// ltr0n. +by rewrite addr_gt0// mulr_gt0//= ?divr_gt0// ?ltr0n// poisson_pdf_gt0// ltr0n. Qed. End staton_bus_poisson. @@ -2286,8 +2232,8 @@ End staton_bus_poisson. Section staton_bus_exponential. Import Notations. Context d (T : measurableType d) (R : realType). -Let exp1560 := @exp_density R (ratr (15%:Q / 60%:Q)). -Let mexp1560 := @mexp_density R (ratr (15%:Q / 60%:Q)). +Let exp1560 := @exponential_pdf R (ratr (15%:Q / 60%:Q)). +Let mexp1560 := @measurable_exponential_pdf R (ratr (15%:Q / 60%:Q)). (* 15/60 = 0.25 *) @@ -2295,559 +2241,303 @@ Definition kstaton_bus_exponential : R.-sfker R ~> mbool := kstaton_bus _ mexp1560. Let kstaton_bus_exponentialE t U : kstaton_bus_exponential t U = - (2 / 7%:R)%:E * (exp1560 3%:R)%:E * \d_true U + - (5%:R / 7%:R)%:E * (exp1560 10%:R)%:E * \d_false U. -Proof. -rewrite /kstaton_bus. -rewrite letin_sample_bernoulli. -rewrite -!muleA; congr (_ * _ + _ * _). -- rewrite letin_kret//. - rewrite letin_iteT//. - rewrite letin_retk//. - rewrite scoreE//= => r r0; exact: exp_density_ge0. -- by rewrite onem27. - rewrite letin_kret//. - rewrite letin_iteF//. - rewrite letin_retk//. - by rewrite scoreE//= => r r0; exact: exp_density_ge0. -Qed. - -(* true -> 5/7 * 0.019 = 5/7 * 10^4 e^-10 / 4! *) -(* false -> 2/7 * 0.168 = 2/7 * 3^4 e^-3 / 4! *) - -Lemma staton_bus_exponentialE P (t : R) U : - let N := ((2 / 7%:R) * exp1560 3%:R + - (5%:R / 7%:R) * exp1560 10%:R)%R in - staton_bus mexp1560 P t U = - ((2 / 7%:R)%:E * (exp1560 3%:R)%:E * \d_true U + - (5%:R / 7%:R)%:E * (exp1560 10%:R)%:E * \d_false U) * N^-1%:E. -Proof. -rewrite /staton_bus. -rewrite normalizeE /= !kstaton_bus_exponentialE !diracT !mule1 ifF //. -apply/negbTE; rewrite gt_eqF// lte_fin. -by rewrite addr_gt0// mulr_gt0//= ?divr_gt0// ?ltr0n// exp_density_gt0 ?ltr0n. -Qed. - -End staton_bus_exponential. - -Module CASE_NAT. -Section case_nat. -Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). - -Section case_nat_ker. -Variable k : R.-ker X ~> Y. - -Definition case_nat_ j : X * nat -> {measure set Y -> \bar R} := - fun xn => if xn.2 == j then k xn.1 else [the measure _ _ of mzero]. - -Let measurable_fun_case_nat_ m U : measurable U -> - measurable_fun setT (case_nat_ m ^~ U). -Proof. -move=> mU; rewrite /case_nat_ (_ : (fun _ => _) = - (fun x => if x.2 == m then k x.1 U else mzero U)) /=; last first. - by apply/funext => -[t b]/=; case: ifPn. -apply: (@measurable_fun_if_pair_nat _ _ _ _ (k ^~ U) (fun=> mzero U)) => //. -exact/measurable_kernel. -Qed. - -#[export] -HB.instance Definition _ j := isKernel.Build _ _ _ _ _ - (case_nat_ j) (measurable_fun_case_nat_ j). -End case_nat_ker. - -Section sfcase_nat. -Variable k : R.-sfker X ~> Y. - -Let sfcase_nat_ j : exists2 k_ : (R.-ker _ ~> _)^nat, - forall n, measure_fam_uub (k_ n) & - forall x U, measurable U -> case_nat_ k j x U = mseries (k_ ^~ x) 0 U. -Proof. -have [k_ hk /=] := sfinite_kernel k. -exists (fun n => [the _.-ker _ ~> _ of case_nat_ (k_ n) j]) => /=. - move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). - exists r%:num => /= -[x [|n']]; rewrite /case_nat_//= /mzero//. - by case: ifPn => //= ?; rewrite /mzero. - by case: ifPn => // ?; rewrite /= /mzero. -move=> [x b] U mU; rewrite /case_nat_; case: ifPn => hb; first by rewrite hk. -by rewrite /mseries eseries0. -Qed. - -#[export] -HB.instance Definition _ j := @Kernel_isSFinite_subdef.Build _ _ _ _ _ - (case_nat_ k j) (sfcase_nat_ j). -End sfcase_nat. - -Section fkcase_nat. -Variable k : R.-fker X ~> Y. - -Let case_nat_uub (m : nat) : measure_fam_uub (case_nat_ k m). -Proof. -have /measure_fam_uubP[M hM] := measure_uub k. -exists M%:num => /= -[]; rewrite /case_nat_ => t [|m']/=. - by case: ifPn => //= ?; rewrite /mzero//=. -by case: ifPn => //= ?; rewrite /mzero//=. -Qed. - -#[export] -HB.instance Definition _ j := Kernel_isFinite.Build _ _ _ _ _ - (case_nat_ k j) (case_nat_uub j). -End fkcase_nat. - -End case_nat. -End CASE_NAT. - -Import CASE_NAT. - -Section case_nat. -Context d d' (T : measurableType d) (T' : measurableType d') (R : realType). - -Import CASE_NAT. - -(* case analysis on the nat datatype *) -Definition case_nat (t : R.-sfker T ~> nat) (u_ : (R.-sfker T ~> T')^nat) - : R.-sfker T ~> T' := - [the R.-sfker T ~> nat of t] \; - [the R.-sfker T * nat ~> T' of - kseries (fun n => [the R.-sfker T * nat ~> T' of case_nat_ (u_ n) n])]. - -End case_nat. - -Definition measure_sum_display : - (measure_display * measure_display) -> measure_display. -Proof. exact. Qed. - -Definition image_classes d1 d2 - (T1 : measurableType d1) (T2 : measurableType d2) (T : Type) - (f1 : T1 -> T) (f2 : T2 -> T) := - <>. - -Section sum_salgebra_instance. -Context d1 d2 (T1 : measurableType d1) (T2 : measurableType d2). -Let f1 : T1 -> T1 + T2 := @inl T1 T2. -Let f2 : T2 -> T1 + T2 := @inr T1 T2. - -Lemma sum_salgebra_set0 : image_classes f1 f2 (set0 : set (T1 + T2)). -Proof. exact: sigma_algebra0. Qed. - -Lemma sum_salgebra_setC A : image_classes f1 f2 A -> - image_classes f1 f2 (~` A). -Proof. exact: sigma_algebraC. Qed. - -Lemma sum_salgebra_bigcup (F : _^nat) : (forall i, image_classes f1 f2 (F i)) -> - image_classes f1 f2 (\bigcup_i (F i)). -Proof. exact: sigma_algebra_bigcup. Qed. - -HB.instance Definition sum_salgebra_mixin := - @isMeasurable.Build (measure_sum_display (d1, d2)) - (T1 + T2)%type (image_classes f1 f2) - (sum_salgebra_set0) (sum_salgebra_setC) (sum_salgebra_bigcup). - -End sum_salgebra_instance. -Reserved Notation "p .-sum" (at level 1, format "p .-sum"). -Reserved Notation "p .-sum.-measurable" - (at level 2, format "p .-sum.-measurable"). -Notation "p .-sum" := (measure_sum_display p) : measure_display_scope. -Notation "p .-sum.-measurable" := - ((p.-sum).-measurable : set (set (_ + _))) : - classical_set_scope. - -Module CASE_SUM. - -Section case_suml. -Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Let A : measurableType _ := unit. - -Section kcase_suml. -Variable k : R.-ker X ~> Y. - -Definition case_suml (a : A) : X * A -> {measure set Y -> \bar R} := - fun xa => k xa.1. - -Let measurable_fun_case_suml a U : measurable U -> - measurable_fun setT (case_suml a ^~ U). -Proof. -move=> /= mU; rewrite /case_suml. -have h := measurable_kernel k _ mU. -rewrite (_ : (fun x : X * unit => k x.1 U) = (fun x : X => k x U) \o fst) //. -by apply: measurableT_comp => //. -Qed. - -#[export] -HB.instance Definition _ a := isKernel.Build _ _ _ _ _ - (case_suml a) (measurable_fun_case_suml a). -End kcase_suml. - -Section sfkcase_suml. -Variable k : R.-sfker X ~> Y. - -Let sfinite_case_suml (a : A) : exists2 k_ : (R.-ker _ ~> _)^nat, - forall n, measure_fam_uub (k_ n) & - forall x U, measurable U -> case_suml k a x U = mseries (k_ ^~ x) 0 U. + (2 / 7)%:E * (exp1560 3)%:E * \d_true U + + (5 / 7)%:E * (exp1560 10)%:E * \d_false U. Proof. -have [k_ hk /=] := sfinite_kernel k. -exists (fun n => [the _.-ker _ ~> _ of case_suml (k_ n) a]) => /=. - move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). - by exists r%:num => /= -[x []]; rewrite /case_suml//= /mzero//. -move=> [x b] U mU; rewrite /case_suml /=. -by rewrite /mseries hk. +rewrite /kstaton_bus. +rewrite letin_sample_bernoulli; last lra. +rewrite -!muleA; congr (_ * _ + _ * _). +- rewrite letin_kret//. + rewrite letin_iteT//. + rewrite letin_retk//. + rewrite scoreE//= => r r0; exact: exponential_pdf_ge0. +- by rewrite onem27. + rewrite letin_kret//. + rewrite letin_iteF//. + rewrite letin_retk//. + by rewrite scoreE//= => r r0; exact: exponential_pdf_ge0. Qed. -#[export] -HB.instance Definition _ (a : A) := @Kernel_isSFinite_subdef.Build _ _ _ _ _ - (case_suml k a) (sfinite_case_suml a). -End sfkcase_suml. - -Section fkcase_suml. -Variable k : R.-fker X ~> Y. +(* true -> 5/7 * 0.019 = 5/7 * 10^4 e^-10 / 4! *) +(* false -> 2/7 * 0.168 = 2/7 * 3^4 e^-3 / 4! *) -Let case_suml_uub (a : A) : measure_fam_uub (case_suml k a). +Lemma staton_bus_exponentialE P (t : R) U : + let N := ((2 / 7) * exp1560 3 + + (5 / 7) * exp1560 10)%R in + staton_bus mexp1560 P t U = + ((2 / 7)%:E * (exp1560 3)%:E * \d_true U + + (5 / 7)%:E * (exp1560 10)%:E * \d_false U) * N^-1%:E. Proof. -have /measure_fam_uubP[M hM] := measure_uub k. -by exists M%:num => /= -[]; rewrite /case_suml. +rewrite /staton_bus. +rewrite normalizeE /= !kstaton_bus_exponentialE !diracT !mule1 ifF //. +apply/negbTE; rewrite gt_eqF// lte_fin. +by rewrite addr_gt0// mulr_gt0//= ?divr_gt0// ?ltr0n// exponential_pdf_gt0 ?ltr0n. Qed. -#[export] -HB.instance Definition _ a := Kernel_isFinite.Build _ _ _ _ _ - (case_suml k a) (case_suml_uub a). -End fkcase_suml. +End staton_bus_exponential. -End case_suml. +(**md + letin' variants +*) -Section case_sumr. -Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Let B : measurableType _ := bool. +Section mswap. +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable k : R.-ker Y * X ~> Z. -Section kcase_sumr. -Variable k : R.-ker X ~> Y. +Definition mswap xy U := k (swap xy) U. -Definition case_sumr (b : B) : X * B -> {measure set Y -> \bar R} := - fun xa => if xa.2 == b then k xa.1 else [the measure _ _ of mzero]. +Let mswap0 xy : mswap xy set0 = 0. +Proof. done. Qed. -Let measurable_fun_case_sumr b U : measurable U -> - measurable_fun setT (case_sumr b ^~ U). -Proof. -move=> /= mU; rewrite /case_suml. -have h := measurable_kernel k _ mU. -rewrite /case_sumr. -rewrite (_ : (fun x : X * bool => case_sumr b x U) = - (fun x : X * bool => (if x.2 == b then k x.1 U else [the {measure set Y -> \bar R} of mzero] U))); last first. - apply/funext => x. - rewrite /case_sumr. - by case: ifPn. -apply: measurable_fun_ifT => //=. - rewrite (_ : (fun t : X * bool => t.2 == b) = (fun t : bool => t == b) \o snd)//. - apply: measurableT_comp => //. -rewrite (_ : (fun t : X * bool => k t.1 U) = (fun t : X => k t U) \o fst)//. -by apply: measurableT_comp => //. -Qed. +Let mswap_ge0 x U : 0 <= mswap x U. +Proof. done. Qed. -#[export] -HB.instance Definition _ b := isKernel.Build _ _ _ _ _ - (case_sumr b) (measurable_fun_case_sumr b). -End kcase_sumr. +Let mswap_sigma_additive x : semi_sigma_additive (mswap x). +Proof. exact: measure_semi_sigma_additive. Qed. -Section sfkcase_sumr. -Variable k : R.-sfker X ~> Y. +HB.instance Definition _ x := isMeasure.Build _ _ R + (mswap x) (mswap0 x) (mswap_ge0 x) (@mswap_sigma_additive x). -Let sfinite_case_sumr b : exists2 k_ : (R.-ker _ ~> _)^nat, - forall n, measure_fam_uub (k_ n) & - forall x U, measurable U -> case_sumr k b x U = mseries (k_ ^~ x) 0 U. +Definition mkswap : _ -> {measure set Z -> \bar R} := + fun x => mswap x. + +Let measurable_fun_kswap U : + measurable U -> measurable_fun setT (mkswap ^~ U). Proof. -have [k_ hk /=] := sfinite_kernel k. -exists (fun n => [the _.-ker _ ~> _ of case_sumr (k_ n) b]) => /=. - move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). - by exists r%:num => /= -[x []]; rewrite /case_sumr//=; case: ifPn => // _; - rewrite /= (le_lt_trans _ (k_r x))// /mzero//. -move=> [x [|]] U mU; rewrite /case_sumr /=; case: b => //=; rewrite ?hk//; -by rewrite /mseries/= eseries0. +move=> mU. +rewrite [X in measurable_fun _ X](_ : _ = k ^~ U \o @swap _ _)//. +apply measurableT_comp => //=; first exact: measurable_kernel. +exact: measurable_swap. Qed. -#[export] -HB.instance Definition _ b := @Kernel_isSFinite_subdef.Build _ _ _ _ _ - (case_sumr k b) (sfinite_case_sumr b). -End sfkcase_sumr. +HB.instance Definition _ := isKernel.Build _ _ + (X * Y)%type Z R mkswap measurable_fun_kswap. -Section fkcase_sumr. -Variable k : R.-fker X ~> Y. +End mswap. + +Section mswap_sfinite_kernel. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable k : R.-sfker Y * X ~> Z. -Let case_sumr_uub b : measure_fam_uub (case_sumr k b). +Let mkswap_sfinite : + exists2 k_ : (R.-ker X * Y ~> Z)^nat, + forall n, measure_fam_uub (k_ n) & + forall x U, measurable U -> mkswap k x U = kseries k_ x U. Proof. -have /measure_fam_uubP[M hM] := measure_uub k. -by exists M%:num => /= -[]; rewrite /case_sumr => x [|] /=; case: b => //=; - rewrite (le_lt_trans _ (hM x))// /mzero. +have [k_ /= kE] := sfinite_kernel k. +exists (fun n => mkswap (k_ n)). + move=> n. + have /measure_fam_uubP[M hM] := measure_uub (k_ n). + by exists M%:num => x/=; exact: hM. +move=> xy U mU. +by rewrite /mswap/= kE. Qed. -#[export] -HB.instance Definition _ b := Kernel_isFinite.Build _ _ _ _ _ - (case_sumr k b) (case_sumr_uub b). -End fkcase_sumr. - -End case_sumr. -End CASE_SUM. - -Section case_sum'. +HB.instance Definition _ := + Kernel_isSFinite_subdef.Build _ _ _ Z R (mkswap k) mkswap_sfinite. -Section kcase_sum'. -Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Let A : measurableType _ := unit. -Let B : measurableType _ := bool. -Variables (k : (A + B)%type -> R.-sfker X ~> Y). +End mswap_sfinite_kernel. -Definition case_sum' : X * (A + B)%type -> {measure set Y -> \bar R} := - fun xab => match xab with - | (x, inl a) => CASE_SUM.case_suml (k xab.2) a (x, a) - | (x, inr b) => CASE_SUM.case_sumr (k xab.2) b (x, b) - end. +Section kswap_finite_kernel_finite. +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) + (k : R.-fker Y * X ~> Z). -Let measurable_fun_case_sum' U : measurable U -> - measurable_fun setT (case_sum' ^~ U). +Let mkswap_finite : measure_fam_uub (mkswap k). Proof. -rewrite /= => mU. -apply: (measurability (ErealGenInftyO.measurableE R)) => //. -move=> /= _ [_ [x ->] <-]; apply: measurableI => //. -rewrite /case_sum' /CASE_SUM.case_suml /CASE_SUM.case_sumr /=. -rewrite (_ : - (fun x : X * (unit + bool) => (let (x0, s) := x in - match s with inl _ => k x.2 x0 | inr b => if b == b then k x.2 x0 else mzero - end) U) = - (fun x : X * (unit + bool) => k x.2 x.1 U)); last first. - by apply/funext => -[x1 [a|b]] //; rewrite eqxx. -rewrite (_ : _ @^-1` _ = - ([set x1 | k (inl tt) x1 U < x%:E] `*` inl @` [set tt]) `|` - ([set x1 | k (inr false) x1 U < x%:E] `*` inr @` [set false]) `|` - ([set x1 | k (inr true) x1 U < x%:E] `*` inr @` [set true])); last first. - apply/seteqP; split. - - move=> z /=; rewrite in_itv/=; move: z => [z [[]|[|]]]//= ?. - + by do 2 left; split => //; exists tt. - + by right; split => //; exists true. - + by left; right; split => //; exists false. - - move=> z /=; rewrite in_itv/=; move: z => [z [[]|[|]]]//=. - - move=> [[[]//|]|]. - + by move=> [_ []]. - + by move=> [_ []]. - - move=> [[|]|[]//]. - + by move=> [_ []]. - + by move=> [_ [] [|]]. - - move=> [[|[]//]|]. - + by move=> [_ []]. - + by move=> [_ [] [|]]. -pose h1 := [set xub : X * (unit + bool) | k (inl tt) xub.1 U < x%:E]. -have mh1 : measurable h1. - rewrite -[X in measurable X]setTI; apply: emeasurable_fun_infty_o => //=. - have H : measurable_fun [set: X] (fun x => k (inl tt) x U) by exact/measurable_kernel. - move=> _ /= C mC; rewrite setTI. - have := H measurableT _ mC; rewrite setTI => {}H. - rewrite [X in measurable X](_ : _ = ((fun x => k (inl tt) x U) @^-1` C) `*` setT)//. - exact: measurableM. - by apply/seteqP; split => [z//=| z/= []]. -set h2 := [set xub : X * (unit + bool)| k (inr false) xub.1 U < x%:E]. -have mh2 : measurable h2. - rewrite -[X in measurable X]setTI. - apply: emeasurable_fun_infty_o => //=. - have H : measurable_fun [set: X] (fun x => k (inr false) x U) by exact/measurable_kernel. - move=> _ /= C mC; rewrite setTI. - have := H measurableT _ mC; rewrite setTI => {}H. - rewrite [X in measurable X](_ : _ = ((fun x => k (inr false) x U) @^-1` C) `*` setT)//. - exact: measurableM. - by apply/seteqP; split => [z //=|z/= []]. -set h3 := [set xub : X * (unit + bool)| k (inr true) xub.1 U < x%:E]. -have mh3 : measurable h3. - rewrite -[X in measurable X]setTI. - apply: emeasurable_fun_infty_o => //=. - have H : measurable_fun [set: X] (fun x => k (inr true) x U) by exact/measurable_kernel. - move=> _ /= C mC; rewrite setTI. - have := H measurableT _ mC; rewrite setTI => {}H. - rewrite [X in measurable X](_ : _ = ((fun x => k (inr true) x U) @^-1` C) `*` setT)//. - exact: measurableM. - by apply/seteqP; split=> [z//=|z/= []]. -apply: measurableU. -- apply: measurableU. - + apply: measurableM => //. - rewrite [X in measurable X](_ : _ = ysection h1 (inl tt))//. - * by apply: measurable_ysection. - * by apply/seteqP; split => z /=; rewrite /ysection /= inE. - + apply: measurableM => //. - rewrite [X in measurable X](_ : _ = ysection h2 (inr false))//. - * by apply: measurable_ysection. - * by apply/seteqP; split => z /=; rewrite /ysection /= inE. -- apply: measurableM => //. - rewrite [X in measurable X](_ : _ = ysection h3 (inr true))//. - + by apply: measurable_ysection. - + by apply/seteqP; split => z /=; rewrite /ysection /= inE. +have /measure_fam_uubP[r hr] := measure_uub k. +apply/measure_fam_uubP; exists (PosNum [gt0 of r%:num%R]) => x /=. +exact: hr. Qed. -#[export] -HB.instance Definition _ := isKernel.Build _ _ _ _ _ - (case_sum') (measurable_fun_case_sum'). -End kcase_sum'. +HB.instance Definition _ := + Kernel_isFinite.Build _ _ _ Z R (mkswap k) mkswap_finite. -Section sfkcase_sum'. -Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Let A : measurableType _ := unit. -Let B : measurableType _ := bool. -Variables (k : (A + B)%type -> R.-sfker X ~> Y). +End kswap_finite_kernel_finite. -Let sfinite_case_sum' : exists2 k_ : (R.-ker _ ~> _)^nat, - forall n, measure_fam_uub (k_ n) & - forall x U, measurable U -> case_sum' k x U = mseries (k_ ^~ x) 0 U. -Proof. -rewrite /=. -set f : A + B -> (R.-fker _ ~> _)^nat := - fun ab : A + B => sval (cid (sfinite_kernel (k ab))). -set Hf := fun ab : A + B => svalP (cid (sfinite_kernel (k ab))). -rewrite /= in Hf. -exists (fun n => [the R.-ker _ ~> _ of case_sum' (fun ab => [the R.-fker _ ~> _ of f ab n])]). - move=> n /=. - have [rtt Hrtt] := measure_uub (f (inl tt) n). - have [rfalse Hrfalse] := measure_uub (f (inr false) n). - have [rtrue Hrtrue] := measure_uub (f (inr true) n). - exists (maxr rtt (maxr rfalse rtrue)) => //= -[x [[]|[|]]] /=. - by rewrite 2!EFin_max lt_max Hrtt. - by rewrite /CASE_SUM.case_sumr /= 2!EFin_max 2!lt_max Hrtrue 2!orbT. - by rewrite /CASE_SUM.case_sumr /= 2!EFin_max 2!lt_max Hrfalse orbT. -move=> [x [[]|[|]]] U mU/=-. -by rewrite (Hf (inl tt) x _ mU). -by rewrite (Hf (inr true) x _ mU). -by rewrite (Hf (inr false) x _ mU). -Qed. +Reserved Notation "f .; g" (at level 60, right associativity, + format "f .; '/ ' g"). -#[export] -HB.instance Definition _ := @Kernel_isSFinite_subdef.Build _ _ _ _ _ - (case_sum' k) (sfinite_case_sum'). -End sfkcase_sum'. +Notation "l .; k" := (mkcomp l (mkswap k)) : ereal_scope. -End case_sum'. +Section letin'. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). -Section case_sum. -Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Let A : measurableType _ := unit. -Let B : measurableType _ := bool. +Definition letin' (l : R.-sfker X ~> Y) (k : R.-sfker Y * X ~> Z) := + locked [the R.-sfker X ~> Z of l .; k]. -Import CASE_SUM. +Lemma letin'E (l : R.-sfker X ~> Y) (k : R.-sfker Y * X ~> Z) x U : + letin' l k x U = \int[l x]_y k (y, x) U. +Proof. by rewrite /letin'; unlock. Qed. -(* case analysis on the datatype unit + bool *) -Definition case_sum (f : R.-sfker X ~> (A + B)%type) - (k : (A + B)%type-> R.-sfker X ~> Y) : R.-sfker X ~> Y := - [the R.-sfker X ~> (A + B)%type of f] \; - [the R.-sfker X * (A + B) ~> Y of case_sum' k]. +Lemma letin'_letin (l : R.-sfker X ~> Y) (k : R.-sfker Y * X ~> Z) : + letin' l k = letin l (mkswap k). +Proof. by rewrite /letin'; unlock. Qed. -End case_sum. +End letin'. -(* counting measure as a kernel *) -Section kcounting. -Context d (G : measurableType d) (R : realType). +Section letin'C. +Import Notations. +Context d d1 d' (X : measurableType d) (Y : measurableType d1) + (Z : measurableType d') (R : realType). +Variables (t : R.-sfker Z ~> X) + (u' : R.-sfker X * Z ~> Y) + (u : R.-sfker Z ~> Y) + (t' : R.-sfker Y * Z ~> X) + (tt' : forall y, t =1 fun z => t' (y, z)) + (uu' : forall x, u =1 fun z => u' (x, z)). + +Definition T' z : set X -> \bar R := t z. +Let T0 z : (T' z) set0 = 0. Proof. by []. Qed. +Let T_ge0 z x : 0 <= (T' z) x. Proof. by []. Qed. +Let T_semi_sigma_additive z : semi_sigma_additive (T' z). +Proof. exact: measure_semi_sigma_additive. Qed. +HB.instance Definition _ z := @isMeasure.Build _ X R (T' z) (T0 z) (T_ge0 z) + (@T_semi_sigma_additive z). -Definition kcounting : G -> {measure set nat -> \bar R} := fun=> counting. +Let sfinT z : sfinite_measure (T' z). Proof. exact: sfinite_kernel_measure. Qed. +HB.instance Definition _ z := @isSFinite.Build _ X R (T' z) (sfinT z). -Let mkcounting U : measurable U -> measurable_fun setT (kcounting ^~ U). -Proof. by []. Qed. +Definition U' z : set Y -> \bar R := u z. +Let U0 z : (U' z) set0 = 0. Proof. by []. Qed. +Let U_ge0 z x : 0 <= (U' z) x. Proof. by []. Qed. +Let U_semi_sigma_additive z : semi_sigma_additive (U' z). +Proof. exact: measure_semi_sigma_additive. Qed. +HB.instance Definition _ z := @isMeasure.Build _ Y R (U' z) (U0 z) (U_ge0 z) + (@U_semi_sigma_additive z). -HB.instance Definition _ := isKernel.Build _ _ _ _ _ kcounting mkcounting. +Let sfinU z : sfinite_measure (U' z). Proof. exact: sfinite_kernel_measure. Qed. +HB.instance Definition _ z := @isSFinite.Build _ Y R + (U' z) (sfinU z). -Let sfkcounting : exists2 k_ : (R.-ker _ ~> _)^nat, - forall n, measure_fam_uub (k_ n) & - forall x U, measurable U -> kcounting x U = mseries (k_ ^~ x) 0 U. +Lemma letin'C z A : measurable A -> + letin' t + (letin' u' + (ret (measurable_fun_prod macc1of3' macc0of3'))) z A = + letin' u + (letin' t' + (ret (measurable_fun_prod macc0of3' macc1of3'))) z A. Proof. -exists (fun n => [the R.-fker _ ~> _ of - @kdirac _ _ G nat R _ (@measurable_cst _ _ _ _ setT n)]). - by move=> n /=; exact: measure_uub. -by move=> g U mU; rewrite /kcounting/= counting_dirac. +move=> mA. +rewrite !letin'E. +under eq_integral. + move=> x _. + rewrite letin'E -uu'. + under eq_integral do rewrite retE /=. + over. +rewrite (sfinite_Fubini (T' z) (U' z) (fun x => \d_(x.1, x.2) A ))//; last first. + apply/EFin_measurable_fun => /=; rewrite (_ : (fun x => _) = mindic R mA)//. + by apply/funext => -[]. +rewrite /=. +apply: eq_integral => y _. +by rewrite letin'E/= -tt'; apply: eq_integral => // x _; rewrite retE. Qed. -HB.instance Definition _ := - Kernel_isSFinite_subdef.Build _ _ _ _ R kcounting sfkcounting. - -End kcounting. - -(* formalization of the iterate construct of Staton ESOP 2017, Sect. 4.2 *) -Section iterate. -Context d {G : measurableType d} {R : realType}. -Let A : measurableType _ := unit. -Let B : measurableType _ := bool. - -(* formalization of iterate^n - Gamma |-p iterate^n t from x = u : B *) -Variables (t : R.-sfker (G * A) ~> (A + B)%type) - (u : G -> A) (mu : measurable_fun setT u). +End letin'C. +Arguments letin'C {d d1 d' X Y Z R} _ _ _ _. -Fixpoint iterate_ n : R.-sfker G ~> B := - match n with - | 0%N => case_sum (letin (ret mu) t) - (fun x => match x with - | inl a => fail - | inr b => ret (measurable_cst b) - end) - | m.+1 => case_sum (letin (ret mu) t) - (fun x => match x with - | inl a => iterate_ m - | inr b => fail - end) - end. +Section letin'A. +Context d d' d1 d2 d3 (X : measurableType d) (Y : measurableType d') + (T1 : measurableType d1) (T2 : measurableType d2) (T3 : measurableType d3) + (R : realType). +Import Notations. +Variables (t : R.-sfker X ~> T1) + (u : R.-sfker T1 * X ~> T2) + (v : R.-sfker T2 * X ~> Y) + (v' : R.-sfker T2 * (T1 * X) ~> Y) + (vv' : forall y, v =1 fun xz => v' (xz.1, (y, xz.2))). -(* formalization of iterate (A = unit, B = bool) - Gamma, x : A |-p t : A + B Gamma |-d u : A ------------------------------------------------ - Gamma |-p iterate t from x = u : B *) -Definition iterate : R.-sfker G ~> B := case_nat (kcounting R) iterate_. +Lemma letin'A x A : measurable A -> + letin' t (letin' u v') x A + = + (letin' (letin' t u) v) x A. +Proof. +move=> mA. +rewrite !letin'E. +under eq_integral do rewrite letin'E. +rewrite letin'_letin/=. +rewrite integral_kcomp; [|by []|]. + apply: eq_integral => z _. + apply: eq_integral => y _. + by rewrite (vv' z). +exact: measurableT_comp (@measurable_kernel _ _ _ _ _ v _ mA) _. +Qed. -End iterate. +End letin'A. -(* an s-finite kernel to test that two expressions are different *) -Section lift_neq. -Context {R : realType} d (G : measurableType d). -Variables (f : G -> bool) (g : G -> bool). +Lemma letin'_sample_bernoulli d d' (T : measurableType d) + (T' : measurableType d') (R : realType) (r : R) (r01 : (0 <= r <= 1)%R) + (u : R.-sfker bool * T ~> T') x y : + letin' (sample_cst (bernoulli r)) u x y = + r%:E * u (true, x) y + (`1- r)%:E * u (false, x) y. +Proof. by rewrite letin'_letin letin_sample_bernoulli. Qed. -Definition flift_neq : G -> bool := fun x' => f x' != g x'. +Section letin'_return. +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). -Hypotheses (mf : measurable_fun setT f) (mg : measurable_fun setT g). +Lemma letin'_kret (k : R.-sfker X ~> Y) + (f : Y * X -> Z) (mf : measurable_fun setT f) x U : + measurable U -> + letin' k (ret mf) x U = k x (curry f ^~ x @^-1` U). +Proof. +move=> mU. +rewrite letin'E. +under eq_integral do rewrite retE. +rewrite integral_indic ?setIT// -[X in measurable X]setTI. +exact: (measurableT_comp mf). +Qed. -(* see also emeasurable_fun_neq *) -Lemma measurable_fun_flift_neq : measurable_fun setT flift_neq. +Lemma letin'_retk (f : X -> Y) (mf : measurable_fun setT f) + (k : R.-sfker Y * X ~> Z) x U : + measurable U -> letin' (ret mf) k x U = k (f x, x) U. Proof. -apply: (measurable_fun_bool true). -rewrite /flift_neq /= (_ : _ @^-1` _ = ([set x | f x] `&` [set x | ~~ g x]) `|` - ([set x | ~~ f x] `&` [set x | g x])). - apply: measurableU; apply: measurableI. - - by rewrite -[X in measurable X]setTI; exact: mf. - - rewrite [X in measurable X](_ : _ = ~` [set x | g x]); last first. - by apply/seteqP; split => x /= /negP. - by apply: measurableC; rewrite -[X in measurable X]setTI; exact: mg. - - rewrite [X in measurable X](_ : _ = ~` [set x | f x]); last first. - by apply/seteqP; split => x /= /negP. - by apply: measurableC; rewrite -[X in measurable X]setTI; exact: mf. - - by rewrite -[X in measurable X]setTI; exact: mg. -by apply/seteqP; split => x /=; move: (f x) (g x) => [|] [|]//=; intuition. +move=> mU; rewrite letin'E retE integral_dirac ?diracT ?mul1e//. +exact: (measurableT_comp (measurable_kernel k _ mU)). Qed. -Definition lift_neq : R.-sfker G ~> bool := ret measurable_fun_flift_neq. +End letin'_return. -End lift_neq. +Section letin'_ite. +Context d d2 d3 (T : measurableType d) (T2 : measurableType d2) + (Z : measurableType d3) (R : realType). +Variables (k1 k2 : R.-sfker T ~> Z) + (u : R.-sfker Z * T ~> T2) + (f : T -> bool) (mf : measurable_fun setT f) + (t : T) (U : set T2). -Section von_neumann_trick. -Context d {T : measurableType d} {R : realType}. +Lemma letin'_iteT : f t -> letin' (ite mf k1 k2) u t U = letin' k1 u t U. +Proof. by move=> ftT; rewrite !letin'_letin letin_iteT. Qed. -Definition kinrtt {d1 d2} {T1 : measurableType d1} {T2 : measurableType d2} := - @measurable_cst _ _ T1 _ setT (@inl unit T2 tt). +Lemma letin'_iteF : ~~ f t -> letin' (ite mf k1 k2) u t U = letin' k2 u t U. +Proof. by move=> ftF; rewrite !letin'_letin letin_iteF. Qed. -Definition finlb d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) - : T1 * bool -> T2 + bool := fun t1b => inr t1b.2. +End letin'_ite. -Lemma minlb {d1 d2} {T1 : measurableType d1} {T2 : measurableType d2} : - measurable_fun setT (@finlb _ _ T1 T2). -Proof. exact: measurableT_comp. Qed. +Section hard_constraint'. +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Variable (D : pprobability bool R (* biased coin *)). +Definition fail' : R.-sfker X ~> Y := + letin' (score (measurable_cst (0%R : R))) + (ret (measurable_cst point)). -Definition von_neumann_trick' : R.-sfker (T * unit) ~> (unit + bool)%type := - letin (sample_cst D) - (letin (sample_cst D) - (letin (lift_neq macc1of3 macc2of3) - (ite (macc3of4) - (letin (ret macc1of4) (ret minlb)) - (ret kinrtt)))). +Lemma fail'E x U : fail' x U = 0. +Proof. by rewrite /fail' letin'_letin failE. Qed. -Definition von_neumann_trick : R.-sfker T ~> bool := - iterate von_neumann_trick' ktt. +End hard_constraint'. +Arguments fail' {d d' X Y R}. -End von_neumann_trick. +Lemma score_fail' d (X : measurableType d) {R : realType} + (r : R) (r01 : (0 <= r <= 1)%R) : + score (kr r) = + letin' (sample_cst (bernoulli r) : R.-pker X ~> _) + (ite macc0of2 (ret ktt) fail'). +Proof. +move: r01 => /andP[r0 r1]; apply/eq_sfkernel => x U. +rewrite letin'E/= /sample; unlock. +rewrite integral_bernoulli ?r0//=. +by rewrite /mscale/= iteE//= iteE//= fail'E mule0 adde0 ger0_norm. +Qed. diff --git a/theories/prob_lang_wip.v b/theories/prob_lang_wip.v index fcb9353d5..31987aaf5 100644 --- a/theories/prob_lang_wip.v +++ b/theories/prob_lang_wip.v @@ -4,12 +4,12 @@ From mathcomp Require Import rat. From mathcomp Require Import mathcomp_extra boolp classical_sets functions. From mathcomp Require Import cardinality fsbigop. Require Import signed reals ereal topology normedtype sequences esum measure. -Require Import lebesgue_measure numfun lebesgue_integral exp kernel trigo. -Require Import prob_lang. +Require Import lebesgue_measure numfun lebesgue_integral exp kernel trigo. +Require Import realfun charge prob_lang. (******************************************************************************) (* Semantics of a probabilistic programming language using s-finite kernels *) -(* (wip about definition of Lebesgue and counting measures) *) +(* (wip about the definition of Lebesgue measure) *) (******************************************************************************) Set Implicit Arguments. @@ -22,112 +22,187 @@ Local Open Scope classical_set_scope. Local Open Scope ring_scope. Local Open Scope ereal_scope. -Section gauss. -Variable R : realType. +Section gauss_pdf. +Context {R : realType}. Local Open Scope ring_scope. -(* density function for gauss *) -Definition gauss_density m s x : R := +Definition gauss_pdf m s x : R := (s * sqrtr (pi *+ 2))^-1 * expR (- ((x - m) / s) ^+ 2 / 2%:R). -Lemma gauss_density_ge0 m s x : 0 <= s -> 0 <= gauss_density m s x. +Lemma gauss_pdf_ge0 m s x : 0 <= s -> 0 <= gauss_pdf m s x. Proof. by move=> s0; rewrite mulr_ge0 ?expR_ge0// invr_ge0 mulr_ge0. Qed. -Lemma gauss_density_gt0 m s x : 0 < s -> 0 < gauss_density m s x. +Lemma gauss_pdf_gt0 m s x : 0 < s -> 0 < gauss_pdf m s x. Proof. move=> s0; rewrite mulr_gt0 ?expR_gt0// invr_gt0 mulr_gt0//. by rewrite sqrtr_gt0 pmulrn_rgt0// pi_gt0. Qed. -Definition gauss01_density : R -> R := gauss_density 0 1. +Lemma measurable_gauss_pdf m s : measurable_fun setT (gauss_pdf m s). +Proof. +apply: measurable_funM => //=; apply: measurableT_comp => //=. +apply: measurable_funM => //=; apply: measurableT_comp => //=. +apply: measurableT_comp (measurable_exprn _) _ => /=. +by apply: measurable_funM => //=; exact: measurable_funD. +Qed. -Hypothesis integral_gauss01_density : - (\int[lebesgue_measure]_x (gauss01_density x)%:E = 1%E)%E. +Definition gauss_pdf01 : R -> R := gauss_pdf 0 1. -Lemma gauss01_densityE x : - gauss01_density x = (sqrtr (pi *+ 2))^-1 * expR (- (x ^+ 2) / 2%:R). -Proof. by rewrite /gauss01_density /gauss_density mul1r subr0 divr1. Qed. +Lemma gauss_pdf01E x : + gauss_pdf01 x = (sqrtr (pi *+ 2))^-1 * expR (- (x ^+ 2) / 2%:R). +Proof. by rewrite /gauss_pdf01 /gauss_pdf mul1r subr0 divr1. Qed. -Definition mgauss01 (V : set R) := - (\int[lebesgue_measure]_(x in V) (gauss01_density x)%:E)%E. +Lemma gauss_pdf01_ub x : gauss_pdf01 x <= (Num.sqrt (pi *+ 2))^-1. +Proof. +rewrite -[leRHS]mulr1. +rewrite /gauss_pdf01 /gauss_pdf; last first. +rewrite mul1r subr0 ler_pM2l ?invr_gt0// ?sqrtr_gt0; last by rewrite mulrn_wgt0// pi_gt0. +by rewrite -[leRHS]expR0 ler_expR mulNr oppr_le0 mulr_ge0// sqr_ge0. +Qed. -Lemma measurable_fun_gauss_density m s : - measurable_fun setT (gauss_density m s). +Lemma continuous_gauss_pdf1 x : {for x, continuous gauss_pdf01}. Proof. -apply: measurable_funM => //=. -apply: measurableT_comp => //=. -apply: measurable_funM => //=. -apply: measurableT_comp => //=. -apply: measurableT_comp (measurable_exprn _) _ => /=. -apply: measurable_funM => //=. -exact: measurable_funD. +apply: continuousM => //=; first exact: cvg_cst. +apply: continuous_comp => /=; last exact: continuous_expR. +apply: continuousM => //=; last exact: cvg_cst. +apply: continuous_comp => //=; last exact: continuousN. +apply: (@continuous_comp _ _ _ _ (fun x : R => x ^+ 2)%R); last exact: exprn_continuous. +apply: continuousM => //=; last exact: cvg_cst. +by apply: continuousD => //=; exact: cvg_cst. Qed. -Let mgauss010 : mgauss01 set0 = 0%E. -Proof. by rewrite /mgauss01 integral_set0. Qed. +End gauss_pdf. + +Definition gauss01 {R : realType} + of \int[@lebesgue_measure R]_x (gauss_pdf01 x)%:E = 1%E : set _ -> \bar R := + fun V => (\int[lebesgue_measure]_(x in V) (gauss_pdf01 x)%:E)%E. + +Section gauss. +Variable R : realType. +Local Open Scope ring_scope. + +Hypothesis integral_gauss_pdf01 : + (\int[@lebesgue_measure R]_x (gauss_pdf01 x)%:E = 1%E)%E. + +Local Notation gauss01 := (gauss01 integral_gauss_pdf01). + +Let gauss010 : gauss01 set0 = 0%E. +Proof. by rewrite /gauss01 integral_set0. Qed. -Let mgauss01_ge0 A : (0 <= mgauss01 A)%E. +Let gauss01_ge0 A : (0 <= gauss01 A)%E. Proof. -by rewrite /mgauss01 integral_ge0//= => x _; rewrite lee_fin gauss_density_ge0. +by rewrite /gauss01 integral_ge0//= => x _; rewrite lee_fin gauss_pdf_ge0. Qed. -Let mgauss01_sigma_additive : semi_sigma_additive mgauss01. +Let gauss01_sigma_additive : semi_sigma_additive gauss01. Proof. move=> /= F mF tF mUF. -rewrite /mgauss01/= integral_bigcup//=; last first. +rewrite /gauss01/= integral_bigcup//=; last first. apply/integrableP; split. - apply/EFin_measurable_fun. - exact: measurable_funS (measurable_fun_gauss_density 0 1). - rewrite (_ : (fun x => _) = (EFin \o gauss01_density)); last first. - by apply/funext => x; rewrite gee0_abs// lee_fin gauss_density_ge0. + apply/measurable_funTS/measurableT_comp => //. + exact: measurable_gauss_pdf. + rewrite (_ : (fun x => _) = EFin \o gauss_pdf01); last first. + by apply/funext => x; rewrite gee0_abs// lee_fin gauss_pdf_ge0. apply: le_lt_trans. apply: (@ge0_subset_integral _ _ _ _ _ setT) => //=. - apply/EFin_measurable_fun. - exact: measurable_fun_gauss_density. - by move=> ? _; rewrite lee_fin gauss_density_ge0. - by rewrite integral_gauss01_density// ltey. + by apply/EFin_measurable_fun; exact: measurable_gauss_pdf. + by move=> ? _; rewrite lee_fin gauss_pdf_ge0. + by rewrite integral_gauss_pdf01 // ltey. apply: is_cvg_ereal_nneg_natsum_cond => n _ _. -by apply: integral_ge0 => /= x ?; rewrite lee_fin gauss_density_ge0. +by apply: integral_ge0 => /= x ?; rewrite lee_fin gauss_pdf_ge0. Qed. HB.instance Definition _ := isMeasure.Build _ _ _ - mgauss01 mgauss010 mgauss01_ge0 mgauss01_sigma_additive. - -Let mgauss01_setT : mgauss01 [set: _] = 1%E. -Proof. by rewrite /mgauss01 integral_gauss01_density. Qed. + gauss01 gauss010 gauss01_ge0 gauss01_sigma_additive. -HB.instance Definition _ := @Measure_isProbability.Build _ _ R mgauss01 mgauss01_setT. +Let gauss01_setT : gauss01 [set: _] = 1%E. +Proof. by rewrite /gauss01 integral_gauss_pdf01. Qed. -Definition gauss01 := [the probability _ _ of mgauss01]. +HB.instance Definition _ := @Measure_isProbability.Build _ _ R gauss01 gauss01_setT. End gauss. Section gauss_lebesgue. -Import Notations. Context d (T : measurableType d) (R : realType). -Hypothesis integral_gauss01_density : - (\int[@lebesgue_measure R]_x (gauss01_density x)%:E = 1%E)%E. +Notation mu := (@lebesgue_measure R). +Hypothesis integral_gauss_pdf01 : \int[mu]_x (gauss_pdf01 x)%:E = 1%E. + +Lemma gauss01_dom : gauss01 integral_gauss_pdf01 `<< mu. +Proof. +move=> A mA muA0; rewrite /gauss01. +apply/eqP; rewrite eq_le; apply/andP; split; last first. + by apply: integral_ge0 => x _; rewrite lee_fin gauss_pdf_ge0. +apply: (@le_trans _ _ (\int[mu]_(x in A) (Num.sqrt (pi *+ 2))^-1%:E))%E; last first. + by rewrite integral_cst//= muA0 mule0. +apply: ge0_le_integral => //=. +- by move=> x _; rewrite lee_fin gauss_pdf_ge0. +- apply/measurable_funTS/measurableT_comp => //. + exact: measurable_gauss_pdf. +- by move=> x _; rewrite lee_fin gauss_pdf01_ub. +Qed. -Let f1 (x : R) := (gauss01_density x) ^-1. +Let f1 (x : salgebraType (R.-ocitv.-measurable)) := (gauss_pdf01 x) ^-1. -Hypothesis integral_mgauss01 : forall U, measurable U -> - \int[mgauss01 (R:=R)]_(y in U) (f1 y)%:E = - \int[lebesgue_measure]_(x0 in U) (gauss01_density x0 * f1 x0)%:E. +Lemma measurable_fun_f1 : measurable_fun setT f1. +Proof. +apply: continuous_measurable_fun => x. +apply: (@continuousV _ _ gauss_pdf01). + by rewrite gt_eqF// gauss_pdf_gt0. +exact: continuous_gauss_pdf1. +Qed. + +Lemma integrable_f1 U : measurable U -> + (gauss01 integral_gauss_pdf01).-integrable U (fun x : salgebraType (R.-ocitv.-measurable) => (f1 x)%:E). +Proof. +Admitted. + +Lemma integral_mgauss01 : forall U, measurable U -> + \int[gauss01 integral_gauss_pdf01]_(y in U) (f1 y)%:E = + \int[mu]_(x0 in U) (gauss_pdf01 x0 * f1 x0)%:E. +Proof. +move=> U mU. +under [in RHS]eq_integral do rewrite EFinM/= muleC. +rewrite -(Radon_Nikodym_change_of_variables gauss01_dom _ (integrable_f1 mU))//=. +apply: ae_eq_integral => //=. +- apply: emeasurable_funM => //. + apply/measurable_funTS/measurableT_comp => //. + exact: measurable_fun_f1. + apply: measurable_int. + apply: integrableS (Radon_Nikodym_integrable _) => //=. + exact: gauss01_dom. +- apply: emeasurable_funM => //. + apply/measurable_funTS/measurableT_comp => //. + exact: measurable_fun_f1. + apply/measurable_funTS/measurableT_comp => //. + exact: measurable_gauss_pdf. +- apply: ae_eq_mul2l => /=. + rewrite Radon_NikodymE//=. + exact: gauss01_dom. + move=> gauss01_dom'. + case: cid => //= h [h1 h2 h3]. + apply: integral_ae_eq => //=. + + exact: integrableS h2. + + apply/measurable_funTS/measurableT_comp => //. + exact: measurable_gauss_pdf. + + by move=> E EU mE; rewrite -(h3 _ mE). +Qed. + +(*Hypothesis integral_mgauss01 : forall U, measurable U -> + \int[gauss01 integral_gauss_pdf01]_(y in U) (f1 y)%:E = + \int[mu]_(x0 in U) (gauss_pdf01 x0 * f1 x0)%:E.*) Let mf1 : measurable_fun setT f1. Proof. apply: (measurable_comp (F := [set r : R | r != 0%R])) => //. - exact: open_measurable. -- by move=> /= r [t _ <-]; rewrite gt_eqF// gauss_density_gt0. +- by move=> /= r [t _ <-]; rewrite gt_eqF// gauss_pdf_gt0. - apply: open_continuous_measurable_fun => //. by apply/in_setP => x /= x0; exact: inv_continuous. -- exact: measurable_fun_gauss_density. +- exact: measurable_gauss_pdf. Qed. -Variable mu : {measure set R -> \bar R}. - Definition staton_lebesgue : R.-sfker T ~> _ := - letin (sample_cst (gauss01 integral_gauss01_density : pprobability _ _)) + letin (sample_cst (gauss01 integral_gauss_pdf01 : pprobability _ _)) (letin (score (measurableT_comp mf1 macc1of2)) (ret macc1of3)). @@ -137,22 +212,21 @@ Lemma staton_lebesgueE x U : measurable U -> Proof. move=> mU; rewrite [in LHS]/staton_lebesgue/=. rewrite [in LHS]letinE /=. -transitivity (\int[@mgauss01 R]_(y in U) (f1 y)%:E). +transitivity (\int[gauss01 integral_gauss_pdf01]_(y in U) (f1 y)%:E). rewrite -[in RHS](setTI U) integral_setI_indic//=. apply: eq_integral => //= r. rewrite letinE/= ge0_integral_mscale//= ger0_norm//; last first. - by rewrite invr_ge0// gauss_density_ge0. + by rewrite invr_ge0// gauss_pdf_ge0. by rewrite integral_dirac// diracT mul1e diracE indicE. rewrite integral_mgauss01//. transitivity (\int[lebesgue_measure]_(x in U) (\1_U x)%:E). apply: eq_integral => /= y yU. - by rewrite /f1 divrr ?indicE ?yU// unitfE gt_eqF// gauss_density_gt0. + by rewrite /f1 divrr ?indicE ?yU// unitfE gt_eqF// gauss_pdf_gt0. by rewrite integral_indic//= setIid. Qed. End gauss_lebesgue. -(* TODO: move this elsewhere *) (* assuming x > 0 *) Definition Gamma {R : realType} (x : R) : \bar R := \int[lebesgue_measure]_(t in `[0%R, +oo[%classic) (expR (- t) * powR t (x - 1))%:E. @@ -162,20 +236,21 @@ Definition Rfact {R : realType} (x : R) := Gamma (x + 1)%R. Section poisson. Variable R : realType. Local Open Scope ring_scope. +Notation mu := (@lebesgue_measure R). Hypothesis integral_poisson_density : forall k, - (\int[lebesgue_measure]_x (@poisson R k x)%:E = 1%E)%E. + (\int[mu]_x (@poisson_pdf R k x)%:E = 1%E)%E. (* density function for poisson *) -Definition poisson1 := @poisson R 1%N. +Definition poisson1 := @poisson_pdf R 1%N. Lemma poisson1_ge0 (x : R) : 0 <= poisson1 x. -Proof. exact: poisson_ge0. Qed. +Proof. exact: poisson_pdf_ge0. Qed. Definition mpoisson1 (V : set R) : \bar R := (\int[lebesgue_measure]_(x in V) (poisson1 x)%:E)%E. Lemma measurable_fun_poisson1 : measurable_fun setT poisson1. -Proof. exact: measurable_poisson. Qed. +Proof. exact: measurable_poisson_pdf. Qed. Let mpoisson10 : mpoisson1 set0 = 0%E. Proof. by rewrite /mpoisson1 integral_set0. Qed. @@ -192,12 +267,12 @@ move=> /= F mF tF mUF. rewrite /mpoisson1/= integral_bigcup//=; last first. apply/integrableP; split. apply/EFin_measurable_fun. - exact: measurable_funS (measurable_poisson _). + exact: measurable_funS (measurable_poisson_pdf _). rewrite (_ : (fun x => _) = (EFin \o poisson1)); last first. by apply/funext => x; rewrite gee0_abs// lee_fin poisson1_ge0//. apply: le_lt_trans. apply: (@ge0_subset_integral _ _ _ _ _ setT) => //=. - by apply/EFin_measurable_fun; exact: measurable_poisson. + by apply/EFin_measurable_fun; exact: measurable_poisson_pdf. by move=> ? _; rewrite lee_fin poisson1_ge0//. by rewrite /= integral_poisson_density// ltry. apply: is_cvg_ereal_nneg_natsum_cond => n _ _. @@ -214,7 +289,8 @@ rewrite /poisson1. by rewrite integral_poisson_density. Qed. -HB.instance Definition _ := @Measure_isProbability.Build _ _ R mpoisson1 mpoisson1_setT. +HB.instance Definition _ := @Measure_isProbability.Build _ _ R + mpoisson1 mpoisson1_setT. Definition poisson' := [the probability _ _ of mpoisson1]. @@ -225,21 +301,22 @@ End poisson. Section staton_counting. Context d (X : measurableType d). Variable R : realType. +Notation mu := (@lebesgue_measure R). Import Notations. Hypothesis integral_poisson_density : forall k, - (\int[lebesgue_measure]_x (@poisson R k x)%:E = 1%E)%E. + (\int[mu]_x (@poisson_pdf R k x)%:E = 1%E)%E. Let f1 x := (poisson1 (x : R)) ^-1. Let mf1 : measurable_fun setT f1. -rewrite /f1 /poisson1 /poisson. +rewrite /f1 /poisson1 /poisson_pdf. apply: (measurable_comp (F := [set r : R | r != 0%R])) => //. - exact: open_measurable. - move=> /= r [t ? <-]. by case: ifPn => // t0; rewrite gt_eqF ?mulr_gt0 ?expR_gt0//= invrK ltr0n. - apply: open_continuous_measurable_fun => //. by apply/in_setP => x /= x0; exact: inv_continuous. -- exact: measurable_poisson. +- exact: measurable_poisson_pdf. Qed. Definition staton_counting : R.-sfker X ~> _ :=