From a06fd523c71c1769c72ea45de1402584e1b09ee8 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 8 Jun 2022 13:07:28 +0900 Subject: [PATCH 01/54] tentative definition of kernel --- theories/kernel.v | 67 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 67 insertions(+) create mode 100644 theories/kernel.v diff --git a/theories/kernel.v b/theories/kernel.v new file mode 100644 index 0000000000..ff9806d79c --- /dev/null +++ b/theories/kernel.v @@ -0,0 +1,67 @@ +(* mathcomp analysis (c) 2017 Inria and AIST. License: CeCILL-C. *) +From HB Require Import structures. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval finmap. +Require Import mathcomp_extra boolp classical_sets signed functions cardinality. +Require Import reals ereal topology normedtype sequences esum measure. +Require Import lebesgue_measure fsbigop numfun lebesgue_integral. + +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. + +HB.mixin Record isKernel + (R : realType) (X Y : measurableType) + (k : X -> {measure set Y -> \bar R}) := { + kernel_measurable_fun : + forall U, measurable_fun setT (k ^~ U) +}. + +#[short(type=kernel)] +HB.structure Definition Kernel + (R : realType) (X Y : measurableType) := + {k & isKernel R X Y k}. +Notation "X ^^> Y" := (kernel _ X Y) (at level 42). + +HB.mixin Record isProbabilityKernel + (R : realType) (X Y : measurableType) + (k : X -> {measure set Y -> \bar R}) + of isKernel R X Y k := { + prob_kernel : forall x : X, k x setT = 1 +}. + +HB.structure Definition ProbKernel + (R : realType) (X Y : measurableType) := + {k & isProbabilityKernel R X Y k }. +(* TODO: warning *) + +Definition sum_of_kernels + (R : realType) (X Y : measurableType) + (k : (X ^^> Y)^nat) : X -> {measure set Y -> \bar R} := + fun x => [the {measure _ -> _} of mseries (k ^~ x) 0]. + +Lemma kernel_measurable_fun_sum_of_kernels + (R : realType) (X Y : measurableType) + (k : (kernel R X Y)^nat) : + forall U, measurable_fun setT ((sum_of_kernels k) ^~ U). +Proof. +Admitted. + +HB.instance Definition _ + (R : realType) (X Y : measurableType) + (k : (kernel R X Y)^nat) := + isKernel.Build R X Y (sum_of_kernels k) + (kernel_measurable_fun_sum_of_kernels k). + +Lemma proposition1 + (R : realType) (X Y : measurableType) + (k : (kernel R X Y)^nat) (f : Y -> \bar R) x : + \int[sum_of_kernels k x]_y (f y) = \sum_(i Date: Wed, 15 Jun 2022 12:53:38 +0900 Subject: [PATCH 02/54] tentative statement of lemma 3 --- theories/kernel.v | 54 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) diff --git a/theories/kernel.v b/theories/kernel.v index ff9806d79c..8ecefaa538 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -50,6 +50,15 @@ Lemma kernel_measurable_fun_sum_of_kernels (k : (kernel R X Y)^nat) : forall U, measurable_fun setT ((sum_of_kernels k) ^~ U). Proof. +move=> U; rewrite /sum_of_kernels /= /mseries. +rewrite [X in measurable_fun _ X](_ : _ = + (fun x => elim_sup (fun n => \sum_(i < n) k i x U))); last first. + apply/funext => x. + rewrite -lim_mkord. + (* TODO: see cvg_lim_supE *) + admit. +apply: measurable_fun_elim_sup => n. +(*TODO: use measurable_funD *) Admitted. HB.instance Definition _ @@ -63,5 +72,50 @@ Lemma proposition1 (k : (kernel R X Y)^nat) (f : Y -> \bar R) x : \int[sum_of_kernels k x]_y (f y) = \sum_(i {measure set Y -> \bar R}) + of isKernel R X Y k := { + finite_kernel : exists r : R, forall x : X, k x setT < r%:E +}. + +HB.structure Definition FiniteKernel + (R : realType) (X Y : measurableType) := + {k & isFiniteKernel R X Y k }. + +HB.mixin Record isSFiniteKernel + (R : realType) (X Y : measurableType) + (k : X -> {measure set Y -> \bar R}) + of isKernel R X Y k := { + finite_kernel : exists k_ : (X ^^> Y)^nat, forall x U, + k x U = \sum_(i set Z -> \bar R := + fun x => fun U => \int[l x]_y k (x, y) U. + +Definition star_kernel (R : realType) (X Y Z : measurableType) + (k : sfinitekernel R [the measurableType of (X * Y)%type] Z) + (l : sfinitekernel R X Y) : X -> {measure set Z -> \bar R}. +(* TODO *) +Admitted. + +Lemma lemma3 (R : realType) (X Y Z : measurableType) + (k : sfinitekernel R [the measurableType of (X * Y)%type] Z) + (l : sfinitekernel R X Y) : forall x f, + \int[star_kernel k l x]_z f z = + \int[l x]_y (\int[k (x, y)]_z f z). +Proof. +(* TODO *) +Admitted. From 6f73958d00998f90b2b0498450bf0113d65d4b37 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 22 Jun 2022 11:27:55 +0900 Subject: [PATCH 03/54] complete infinite sum of kernels is a kernel --- theories/kernel.v | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 8ecefaa538..5bb8488bf5 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -45,6 +45,14 @@ Definition sum_of_kernels (k : (X ^^> Y)^nat) : X -> {measure set Y -> \bar R} := fun x => [the {measure _ -> _} of mseries (k ^~ x) 0]. +(* PR in progress *) +Lemma preimage_cst (aT rT : Type) (x : aT) (A : set aT) : + @cst rT _ x @^-1` A = if x \in A then setT else set0. +Proof. +apply/seteqP; rewrite /preimage; split; first by move=> *; rewrite mem_set. +by case: ifPn => [/[!inE] ?//|_]; exact: sub0set. +Qed. + Lemma kernel_measurable_fun_sum_of_kernels (R : realType) (X Y : measurableType) (k : (kernel R X Y)^nat) : @@ -52,14 +60,13 @@ Lemma kernel_measurable_fun_sum_of_kernels Proof. move=> U; rewrite /sum_of_kernels /= /mseries. rewrite [X in measurable_fun _ X](_ : _ = - (fun x => elim_sup (fun n => \sum_(i < n) k i x U))); last first. - apply/funext => x. - rewrite -lim_mkord. - (* TODO: see cvg_lim_supE *) - admit. + (fun x => elim_sup (fun n => \sum_(0 <= i < n) k i x U))); last first. + apply/funext => x; rewrite -lim_mkord is_cvg_elim_supE. + by rewrite -lim_mkord. + exact: is_cvg_nneseries. apply: measurable_fun_elim_sup => n. -(*TODO: use measurable_funD *) -Admitted. +by apply: measurable_fun_sum => *; exact/kernel_measurable_fun. +Qed. HB.instance Definition _ (R : realType) (X Y : measurableType) From c9664d7311a3d7cc5733e266dfc80f315cc1b542 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 22 Jun 2022 17:40:06 +0900 Subject: [PATCH 04/54] prove that star_kernel is a measure --- theories/kernel.v | 49 +++++++++++++++++++++++++++++++---------------- 1 file changed, 33 insertions(+), 16 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 5bb8488bf5..ecd265a5cb 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -45,14 +45,6 @@ Definition sum_of_kernels (k : (X ^^> Y)^nat) : X -> {measure set Y -> \bar R} := fun x => [the {measure _ -> _} of mseries (k ^~ x) 0]. -(* PR in progress *) -Lemma preimage_cst (aT rT : Type) (x : aT) (A : set aT) : - @cst rT _ x @^-1` A = if x \in A then setT else set0. -Proof. -apply/seteqP; rewrite /preimage; split; first by move=> *; rewrite mem_set. -by case: ifPn => [/[!inE] ?//|_]; exact: sub0set. -Qed. - Lemma kernel_measurable_fun_sum_of_kernels (R : realType) (X Y : measurableType) (k : (kernel R X Y)^nat) : @@ -107,16 +99,41 @@ HB.structure Definition SFiniteKernel (R : realType) (X Y : measurableType) := {k & isSFiniteKernel R X Y k}. -Definition star_kernel' (R : realType) (X Y Z : measurableType) - (k : sfinitekernel R [the measurableType of (X * Y)%type] Z) - (l : sfinitekernel R X Y) : X -> set Z -> \bar R := +Section starkernel. +Variables (R : realType) (X Y Z : measurableType). +Variable k : sfinitekernel R [the measurableType of (X * Y)%type] Z. +Variable l : sfinitekernel R X Y. + +Definition star_kernel' : X -> set Z -> \bar R := fun x => fun U => \int[l x]_y k (x, y) U. -Definition star_kernel (R : realType) (X Y Z : measurableType) - (k : sfinitekernel R [the measurableType of (X * Y)%type] Z) - (l : sfinitekernel R X Y) : X -> {measure set Z -> \bar R}. -(* TODO *) -Admitted. +Let star_kernel'0 (x : X) : star_kernel' x set0 = 0. +Proof. +rewrite /star_kernel' (eq_integral (cst 0)) ?integral0// => y _. +by rewrite measure0. +Qed. + +Let star_kernel'_ge0 (x : X) (U : set Z) : 0 <= star_kernel' x U. +Proof. by apply: integral_ge0 => y _; exact: measure_ge0. Qed. + +Let star_kernel'_sigma_additive (x : X) : semi_sigma_additive (star_kernel' x). +Proof. +move=> F mF tF mUF; rewrite [X in _ --> X](_ : _ = + \int[l x]_y (\sum_(n U _. + by apply/esym/cvg_lim => //; apply/measure_semi_sigma_additive. +apply/cvg_closeP; split. + by apply: is_cvg_nneseries => n _; exact: integral_ge0. +rewrite closeE// integral_sum// => n. +move: (@kernel_measurable_fun R _ _ k (F n)) => /measurable_fun_prod1. +exact. +Qed. + +Canonical star_kernel : X -> {measure set Z -> \bar R} := + fun x => Measure.Pack _ (Measure.Axioms (star_kernel'0 x) (star_kernel'_ge0 x) + (@star_kernel'_sigma_additive x)). + +End starkernel. Lemma lemma3 (R : realType) (X Y Z : measurableType) (k : sfinitekernel R [the measurableType of (X * Y)%type] Z) From a420cc0b8f39ec8253d522df756c7c1409052786 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Thu, 23 Jun 2022 00:37:03 +0900 Subject: [PATCH 05/54] proposition 1 --- theories/kernel.v | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index ecd265a5cb..61958577b0 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -66,14 +66,28 @@ HB.instance Definition _ isKernel.Build R X Y (sum_of_kernels k) (kernel_measurable_fun_sum_of_kernels k). +(* PR in progress *) +Section ge0_integral_measure_series. +Local Open Scope ereal_scope. +Variables (T : measurableType) (R : realType) (m_ : {measure set T -> \bar R}^nat). +Let m := measure_series m_ O. + +Lemma ge0_integral_measure_series (D : set T) (mD : measurable D) (f : T -> \bar R) : + (forall t, D t -> 0 <= f t) -> + measurable_fun D f -> + \int[m]_(x in D) f x = \sum_(n \bar R) x : - \int[sum_of_kernels k x]_y (f y) = \sum_(i + measurable_fun setT f -> + \int[sum_of_kernels k x]_y (f y) = \sum_(i f0 mf; rewrite /sum_of_kernels/= ge0_integral_measure_series. +Qed. HB.mixin Record isFiniteKernel (R : realType) (X Y : measurableType) From cdc056be879934c82553704177f87d16d0b02fa7 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Mon, 11 Jul 2022 17:46:33 +0900 Subject: [PATCH 06/54] tentative first part of lemma 3 (admit pending) - tentative example of semantics --- theories/kernel.v | 902 +++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 816 insertions(+), 86 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 61958577b0..6568e49d5b 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -15,73 +15,62 @@ Local Open Scope classical_set_scope. Local Open Scope ring_scope. Local Open Scope ereal_scope. -HB.mixin Record isKernel - (R : realType) (X Y : measurableType) +HB.mixin Record isKernel (d d' : measure_display) + (R : realType) (X : measurableType d) (Y : measurableType d') (k : X -> {measure set Y -> \bar R}) := { - kernel_measurable_fun : - forall U, measurable_fun setT (k ^~ U) + kernelP : forall U, measurable U -> measurable_fun setT (k ^~ U) }. #[short(type=kernel)] -HB.structure Definition Kernel - (R : realType) (X Y : measurableType) := - {k & isKernel R X Y k}. +HB.structure Definition Kernel (d d' : measure_display) + (R : realType) (X : measurableType d) (Y : measurableType d') := + {k & isKernel d d' R X Y k}. Notation "X ^^> Y" := (kernel _ X Y) (at level 42). -HB.mixin Record isProbabilityKernel - (R : realType) (X Y : measurableType) +HB.mixin Record isProbabilityKernel (d d' : measure_display) + (R : realType) (X : measurableType d) (Y : measurableType d') (k : X -> {measure set Y -> \bar R}) - of isKernel R X Y k := { - prob_kernel : forall x : X, k x setT = 1 + of isKernel d d' R X Y k := { + prob_kernelP : forall x : X, k x [set: Y] = 1 }. -HB.structure Definition ProbKernel - (R : realType) (X Y : measurableType) := - {k & isProbabilityKernel R X Y k }. -(* TODO: warning *) +#[short(type=probability_kernel)] +HB.structure Definition ProbabilityKernel (d d' : measure_display) + (R : realType) (X : measurableType d) (Y : measurableType d') := + {k of isProbabilityKernel d d' R X Y k & isKernel d d' R X Y k}. -Definition sum_of_kernels - (R : realType) (X Y : measurableType) - (k : (X ^^> Y)^nat) : X -> {measure set Y -> \bar R} := - fun x => [the {measure _ -> _} of mseries (k ^~ x) 0]. +Section sum_of_kernels. +Variables (d d' : measure_display) (R : realType). +Variables (X : measurableType d) (Y : measurableType d'). +Variable k : (kernel R X Y)^nat. -Lemma kernel_measurable_fun_sum_of_kernels - (R : realType) (X Y : measurableType) - (k : (kernel R X Y)^nat) : - forall U, measurable_fun setT ((sum_of_kernels k) ^~ U). +Definition sum_of_kernels : X -> {measure set Y -> \bar R} := + fun x => [the measure _ _ of mseries (k ^~ x) 0]. + +Lemma kernel_measurable_fun_sum_of_kernels (U : set Y) : + measurable U -> + measurable_fun setT (sum_of_kernels ^~ U). Proof. -move=> U; rewrite /sum_of_kernels /= /mseries. +move=> mU; rewrite /sum_of_kernels /= /mseries. rewrite [X in measurable_fun _ X](_ : _ = (fun x => elim_sup (fun n => \sum_(0 <= i < n) k i x U))); last first. apply/funext => x; rewrite -lim_mkord is_cvg_elim_supE. by rewrite -lim_mkord. exact: is_cvg_nneseries. apply: measurable_fun_elim_sup => n. -by apply: measurable_fun_sum => *; exact/kernel_measurable_fun. +apply: emeasurable_fun_sum => *. +by apply/kernelP. Qed. -HB.instance Definition _ - (R : realType) (X Y : measurableType) - (k : (kernel R X Y)^nat) := - isKernel.Build R X Y (sum_of_kernels k) - (kernel_measurable_fun_sum_of_kernels k). +HB.instance Definition _ := + isKernel.Build d d' R X Y sum_of_kernels + kernel_measurable_fun_sum_of_kernels. -(* PR in progress *) -Section ge0_integral_measure_series. -Local Open Scope ereal_scope. -Variables (T : measurableType) (R : realType) (m_ : {measure set T -> \bar R}^nat). -Let m := measure_series m_ O. +End sum_of_kernels. -Lemma ge0_integral_measure_series (D : set T) (mD : measurable D) (f : T -> \bar R) : - (forall t, D t -> 0 <= f t) -> - measurable_fun D f -> - \int[m]_(x in D) f x = \sum_(n \bar R) x : +Lemma integral_sum_of_kernels (d d' : measure_display) + (R : realType) (X : measurableType d) (Y : measurableType d') + (k : (X ^^> Y)^nat) (f : Y -> \bar R) x : (forall y, 0 <= f y) -> measurable_fun setT f -> \int[sum_of_kernels k x]_y (f y) = \sum_(i f0 mf; rewrite /sum_of_kernels/= ge0_integral_measure_series. Qed. -HB.mixin Record isFiniteKernel - (R : realType) (X Y : measurableType) +HB.mixin Record isFiniteKernel (d d' : measure_display) + (R : realType) (X : measurableType d) (Y : measurableType d') (k : X -> {measure set Y -> \bar R}) - of isKernel R X Y k := { - finite_kernel : exists r : R, forall x : X, k x setT < r%:E + of isKernel d d' R X Y k := { + finite_kernelP : exists r : {posnum R}, forall x, k x [set: Y] < r%:num%:E }. -HB.structure Definition FiniteKernel - (R : realType) (X Y : measurableType) := - {k & isFiniteKernel R X Y k }. +#[short(type=finite_kernel)] +HB.structure Definition FiniteKernel (d d' : measure_display) + (R : realType) (X : measurableType d) (Y : measurableType d') := + {k of isFiniteKernel d d' R X Y k & isKernel d d' R X Y k}. -HB.mixin Record isSFiniteKernel - (R : realType) (X Y : measurableType) +HB.mixin Record isSFiniteKernel (d d' : measure_display) + (R : realType) (X : measurableType d) (Y : measurableType d') (k : X -> {measure set Y -> \bar R}) - of isKernel R X Y k := { - finite_kernel : exists k_ : (X ^^> Y)^nat, forall x U, - k x U = \sum_(i + k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U }. -#[short(type=sfinitekernel)] -HB.structure Definition SFiniteKernel - (R : realType) (X Y : measurableType) := - {k & isSFiniteKernel R X Y k}. +#[short(type=sfinite_kernel)] +HB.structure Definition SFiniteKernel (d d' : measure_display) + (R : realType) (X : measurableType d) (Y : measurableType d') := + {k of isSFiniteKernel d d' R X Y k & + isFiniteKernel d d' R X Y k & + isKernel d d' R X Y k}. -Section starkernel. -Variables (R : realType) (X Y Z : measurableType). -Variable k : sfinitekernel R [the measurableType of (X * Y)%type] Z. -Variable l : sfinitekernel R X Y. +Section star_is_kernel. +Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3). +Variable k : kernel R [the measurableType _ of (X * Y)%type] Z. +Variable l : kernel R X Y. -Definition star_kernel' : X -> set Z -> \bar R := - fun x => fun U => \int[l x]_y k (x, y) U. +Definition star : X -> set Z -> \bar R := fun x U => \int[l x]_y k (x, y) U. -Let star_kernel'0 (x : X) : star_kernel' x set0 = 0. +Let star0 (x : X) : star x set0 = 0. Proof. -rewrite /star_kernel' (eq_integral (cst 0)) ?integral0// => y _. -by rewrite measure0. +by rewrite /star (eq_integral (cst 0)) ?integral0// => y _; rewrite measure0. Qed. -Let star_kernel'_ge0 (x : X) (U : set Z) : 0 <= star_kernel' x U. +Let star_ge0 (x : X) (U : set Z) : 0 <= star x U. Proof. by apply: integral_ge0 => y _; exact: measure_ge0. Qed. -Let star_kernel'_sigma_additive (x : X) : semi_sigma_additive (star_kernel' x). +Let star_sigma_additive (x : X) : semi_sigma_additive (star x). Proof. -move=> F mF tF mUF; rewrite [X in _ --> X](_ : _ = - \int[l x]_y (\sum_(n U _. - by apply/esym/cvg_lim => //; apply/measure_semi_sigma_additive. +move=> U mU tU mUU. +rewrite [X in _ --> X](_ : _ = + \int[l x]_y (\sum_(n V _. + by apply/esym/cvg_lim => //; exact/measure_semi_sigma_additive. apply/cvg_closeP; split. by apply: is_cvg_nneseries => n _; exact: integral_ge0. rewrite closeE// integral_sum// => n. -move: (@kernel_measurable_fun R _ _ k (F n)) => /measurable_fun_prod1. +move: (@kernelP _ _ R _ _ k (U n) (mU n)) => /measurable_fun_prod1. exact. Qed. -Canonical star_kernel : X -> {measure set Z -> \bar R} := - fun x => Measure.Pack _ (Measure.Axioms (star_kernel'0 x) (star_kernel'_ge0 x) - (@star_kernel'_sigma_additive x)). +HB.instance Definition _ (x : X) := + isMeasure.Build _ R _ (star x) (star0 x) (star_ge0 x) (@star_sigma_additive x). + +Definition mstar : X -> {measure set Z -> \bar R} := fun x => [the measure _ _ of star x]. + +End star_is_kernel. + +(* TODO: PR *) +Section integralM_indic. +Local Open Scope ereal_scope. +Variables (d : measure_display) (T : measurableType d) (R : realType). +Variables (m : {measure set T -> \bar R}) (D : set T) (mD : measurable D). + +Lemma integralM_indic_new (f : R -> T -> R) (k : R) + (f0 : forall r t, D t -> (0 <= f r t)%R) : + ((k < 0)%R -> f k = cst 0%R) -> measurable_fun setT (f k) -> + \int[m]_(x in D) (k * (f k) x)%:E = k%:E * \int[m]_(x in D) ((f k) x)%:E. +Proof. +move=> fk0 mfk; have [k0|k0] := ltP k 0%R. + rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0; last first. + by move=> x _; rewrite fk0// mulr0. + rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0// => x _. + by rewrite fk0// indic0. +under eq_integral do rewrite EFinM. +rewrite ge0_integralM//. +- apply/EFin_measurable_fun/(@measurable_funS _ _ _ _ setT) => //. +- by move=> y Dy; rewrite lee_fin f0. +Qed. + +End integralM_indic. + +Section test. +Local Open Scope ereal_scope. +Variables (d : measure_display) (T : measurableType d) (R : realType). +Variables (m : {measure set T -> \bar R}) (D : set T) (mD : measurable D). + +Lemma integralM_indic_test (f : R -> set T) (k : R) : + ((k < 0)%R -> f k = set0) -> measurable (f k) -> + \int[m]_(x in D) (k * \1_(f k) x)%:E = k%:E * \int[m]_(x in D) (\1_(f k) x)%:E. +Proof. +move=> fk0 mfk. +apply: (@integralM_indic_new _ _ _ _ _ _ (fun k x => \1_(f k) x)) => //=. + move/fk0 => -> /=. + apply/funext => x. + by rewrite indicE in_set0. +by rewrite (_ : \1_(f k) = mindic R mfk). +Qed. + +End test. + + +Lemma muleCA (R : realType) : left_commutative ( *%E : _ -> _ -> \bar R). +Proof. by move=> x y z; rewrite muleC (muleC x) muleA. Qed. + +Section integral_mscale. +Variables (R : realType) (k : {nonneg R}). +Variables (d : measure_display) (T : measurableType d). +Variable (m : {measure set T -> \bar R}) (D : set T) (f : T -> \bar R). +Hypotheses (mD : measurable D). + +Let integral_mscale_indic (E : set T) (mE : measurable E) : + \int[mscale k m]_(x in D) (\1_E x)%:E = + k%:num%:E * \int[m]_(x in D) (\1_E x)%:E. +Proof. by rewrite !integral_indic. Qed. + +(*NB: notation { mfun aT >-> rT} broken? *) +Let integral_mscale_nnsfun (h : {nnsfun T >-> R}) : + \int[mscale k m]_(x in D) (h x)%:E = k%:num%:E * \int[m]_(x in D) (h x)%:E. +Proof. +rewrite -ge0_integralM//; last 2 first. +apply/EFin_measurable_fun. + exact: measurable_funS (@measurable_funP _ _ _ h). + by move=> x _; rewrite lee_fin. +under eq_integral do rewrite fimfunE -sumEFin. +under [LHS]eq_integral do rewrite fimfunE -sumEFin. +rewrite /=. +rewrite ge0_integral_sum//; last 2 first. + move=> r. + apply/EFin_measurable_fun/measurable_funrM. + apply: (@measurable_funS _ _ _ _ setT) => //. + have fr : measurable (h @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). + by move=> n x Dx; rewrite EFinM muleindic_ge0. +under eq_integral. + move=> x xD. + rewrite ge0_sume_distrr//; last first. + by move=> r _; rewrite EFinM muleindic_ge0. + over. +rewrite /=. +rewrite ge0_integral_sum//; last 2 first. + move=> r. + apply/EFin_measurable_fun/measurable_funrM/measurable_funrM. + apply: (@measurable_funS _ _ _ _ setT) => //. + have fr : measurable (h @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). + move=> n x Dx. + by rewrite EFinM mule_ge0// muleindic_ge0. +apply eq_bigr => r _. +rewrite ge0_integralM//; last 2 first. + apply/EFin_measurable_fun/measurable_funrM. + apply: (@measurable_funS _ _ _ _ setT) => //. + have fr : measurable (h @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). + by move=> t Dt; rewrite muleindic_ge0. +rewrite (@integralM_indic_new _ _ _ _ _ _ (fun r x => \1_(h @^-1` [set r]) x))//; last 2 first. + move=> r0. + by rewrite preimage_nnfun0// indic0. + have fr : measurable (h @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). +rewrite /=. +rewrite (@integralM_indic_new _ _ _ _ _ _ (fun r x => \1_(h @^-1` [set r]) x))//; last 2 first. + move=> r0. + by rewrite preimage_nnfun0// indic0. + have fr : measurable (h @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). +rewrite integral_mscale_indic//. +by rewrite muleCA. +Qed. + +Lemma ge0_integral_mscale (mf : measurable_fun D f) : + (forall x, D x -> 0 <= f x) -> + \int[mscale k m]_(x in D) f x = k%:num%:E * \int[m]_(x in D) f x. +Proof. +move=> f0; have [f_ [ndf_ f_f]] := approximation mD mf f0. +transitivity (lim (fun n => \int[mscale k m]_(x in D) (f_ n x)%:E)). + rewrite -monotone_convergence//=; last 3 first. + move=> n; apply/EFin_measurable_fun. + by apply: (@measurable_funS _ _ _ _ setT). + by move=> n x Dx; rewrite lee_fin. + by move=> x Dx a b /ndf_ /lefP; rewrite lee_fin. + apply eq_integral => x /[!inE] xD; apply/esym/cvg_lim => //=. + exact: f_f. +rewrite (_ : \int[m]_(x in D) _ = lim (fun n => \int[m]_(x in D) (f_ n x)%:E)); last first. + rewrite -monotone_convergence//. + apply: eq_integral => x /[!inE] xD. + apply/esym/cvg_lim => //. + exact: f_f. + move=> n. + apply/EFin_measurable_fun. + by apply: (@measurable_funS _ _ _ _ setT). + by move=> n x Dx; rewrite lee_fin. + by move=> x Dx a b /ndf_ /lefP; rewrite lee_fin. +rewrite -ereal_limrM//; last first. + apply/ereal_nondecreasing_is_cvg => a b ab. + apply ge0_le_integral => //. + by move=> x Dx; rewrite lee_fin. + apply/EFin_measurable_fun. + by apply: (@measurable_funS _ _ _ _ setT). + by move=> x Dx; rewrite lee_fin. + apply/EFin_measurable_fun. + by apply: (@measurable_funS _ _ _ _ setT). + move=> x Dx. + rewrite lee_fin. + by move/ndf_ : ab => /lefP. +congr (lim _). +apply/funext => n /=. +by rewrite integral_mscale_nnsfun//. +Qed. + +End integral_mscale. + +(* TODO: rename emeasurable_funeM? *) + +Section ndseq_closed_B. +Variables (d1 d2 : measure_display). +Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). +Implicit Types A : set (T1 * T2). + +Section xsection. +Variables (pt2 : T2) (m2 : T1 -> {measure set T2 -> \bar R}). +Let phi A x := m2 x (xsection A x). +Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. + +Lemma xsection_ndseq_closed : ndseq_closed B. +Proof. +move=> F ndF; rewrite /B /= => BF; split. + by apply: bigcupT_measurable => n; have [] := BF n. +have phiF x : (fun i => phi (F i) x) --> phi (\bigcup_i F i) x. + rewrite /phi /= xsection_bigcup; apply: cvg_mu_inc => //. + - by move=> n; apply: measurable_xsection; case: (BF n). + - by apply: bigcupT_measurable => i; apply: measurable_xsection; case: (BF i). + - move=> m n mn; apply/subsetPset => y; rewrite /xsection/= !inE. + by have /subsetPset FmFn := ndF _ _ mn; exact: FmFn. +apply: (emeasurable_fun_cvg (phi \o F)) => //. +- by move=> i; have [] := BF i. +- by move=> x _; exact: phiF. +Qed. +End xsection. + +End ndseq_closed_B. + +Section measurable_prod_subset. +Variables (d1 d2 : measure_display). +Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). +Implicit Types A : set (T1 * T2). + +Section xsection. +Variable (m2 : T1 -> {measure set T2 -> \bar R}) (D : set T2) (mD : measurable D). +Let m2D x := mrestr (m2 x) mD. +HB.instance Definition _ x := Measure.on (m2D x). +Let phi A := fun x => m2D x (xsection A x). +Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. + +Hypothesis H1 : forall X2, measurable X2 -> measurable_fun [set: T1] (m2D^~ X2). + +Lemma measurable_prod_subset_xsection + (m2D_bounded : forall x, exists M, forall X, measurable X -> (m2D x X < M%:E)%E) : + measurable `<=` B. +Proof. +rewrite measurable_prod_measurableType. +set C := [set A1 `*` A2 | A1 in measurable & A2 in measurable]. +have CI : setI_closed C. + move=> X Y [X1 mX1 [X2 mX2 <-{X}]] [Y1 mY1 [Y2 mY2 <-{Y}]]. + exists (X1 `&` Y1); first exact: measurableI. + by exists (X2 `&` Y2); [exact: measurableI|rewrite setMI]. +have CT : C setT by exists setT => //; exists setT => //; rewrite setMTT. +have CB : C `<=` B. + move=> X [X1 mX1 [X2 mX2 <-{X}]]; split; first exact: measurableM. + have -> : phi (X1 `*` X2) = (fun x => m2D x X2 * (\1_X1 x)%:E)%E. + rewrite funeqE => x; rewrite indicE /phi /m2/= /mrestr. + have [xX1|xX1] := boolP (x \in X1); first by rewrite mule1 in_xsectionM. + by rewrite mule0 notin_xsectionM// set0I measure0. + apply: emeasurable_funM => //. + by apply: H1. + apply/EFin_measurable_fun. + by rewrite (_ : \1_ _ = mindic R mX1). +suff monoB : monotone_class setT B by exact: monotone_class_subset. +split => //; [exact: CB| |exact: xsection_ndseq_closed]. +move=> X Y XY [mX mphiX] [mY mphiY]; split; first exact: measurableD. +have -> : phi (X `\` Y) = (fun x => phi X x - phi Y x)%E. + rewrite funeqE => x; rewrite /phi/= xsectionD// /m2D measureD. + - by rewrite setIidr//; exact: le_xsection. + - exact: measurable_xsection. + - exact: measurable_xsection. + - move: (m2D_bounded x) => [M m2M]. + rewrite (lt_le_trans (m2M (xsection X x) _))// ?leey//. + exact: measurable_xsection. +exact: emeasurable_funB. +Qed. + +End xsection. + +End measurable_prod_subset. + +(*NB: measurable_xsection as a superfluous parameter*) + +Section measurable_fun_xsection. +Variables (d1 d2 : measure_display). +Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). +Variables (m2 : T1 -> {measure set T2 -> \bar R}). +Implicit Types A : set (T1 * T2). +Hypotheses (sm2 : exists r : {posnum R}, forall x, m2 x [set: T2] < r%:num%:E). + +Hypothesis H1 : forall X2, measurable X2 -> measurable_fun [set: T1] ((fun x => mrestr (m2 x) measurableT)^~ X2). + +Let phi A := (fun x => m2 x (xsection A x)). +Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. + +Lemma measurable_fun_xsection A : + A \in measurable -> measurable_fun setT (phi A). +Proof. +move: A; suff : measurable `<=` B by move=> + A; rewrite inE => /[apply] -[]. +move=> X mX. +(*move/sigma_finiteP : sf_m2 => [F F_T [F_nd F_oo]] X mX.*) +(*have -> : X = \bigcup_n (X `&` (setT `*` F n)). + by rewrite -setI_bigcupr -setM_bigcupr -F_T setMTT setIT. +apply: xsection_ndseq_closed. + move=> m n mn; apply/subsetPset; apply: setIS; apply: setSM => //. + exact/subsetPset/F_nd. +move=> n; rewrite -/B; have [? ?] := F_oo n.*) +(*pose m2Fn := [the measure _ _ of mrestr m2 (F_oo n).1].*) +rewrite /B/=; split => //. +rewrite /phi. +rewrite -(_ : (fun x : T1 => mrestr (m2 x) measurableT (xsection X x)) = (fun x => (m2 x) (xsection X x)))//; last first. + apply/funext => x//=. + by rewrite /mrestr setIT. +apply measurable_prod_subset_xsection => //; last first. + move=> x. + case: sm2 => r hr. + exists r%:num => Y mY. + apply: (le_lt_trans _ (hr x)) => //. + rewrite /mrestr. + apply le_measure => //. + rewrite inE. + apply: measurableI => //. + by rewrite inE. + +Qed. + +End measurable_fun_xsection. + +Section fubini_F_dep. +Local Open Scope ereal_scope. +Variables (d1 d2 : measure_display). +Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). +Variables (m2 : T1 -> {measure set T2 -> \bar R}). +Variable f : T1 * T2 -> \bar R. + +Definition fubini_F_dep x := \int[m2 x]_y f (x, y). + +End fubini_F_dep. + +Section fubini_tonelli. +Local Open Scope ereal_scope. +Variables (d1 d2 : measure_display). +Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). +Variables (m1 : {measure set T1 -> \bar R}) (m2 : T1 -> {measure set T2 -> \bar R}). +Hypotheses (sm2 : exists r : {posnum R}, forall x, m2 x [set: T2] < r%:num%:E). + +Section indic_fubini_tonelli. +Variables (A : set (T1 * T2)) (mA : measurable A). +Implicit Types A : set (T1 * T2). +Let f : (T1 * T2) -> R := \1_A. + +Let F := fubini_F_dep m2 (EFin \o f). + +Lemma indic_fubini_tonelli_FE : F = (fun x => m2 x (xsection A x)). +Proof. +rewrite funeqE => x; rewrite /= -(setTI (xsection _ _)). +rewrite -integral_indic//; last exact: measurable_xsection. +rewrite /F /fubini_F -(setTI (xsection _ _)). +rewrite integral_setI_indic; [|exact: measurable_xsection|by []]. +apply: eq_integral => y _ /=; rewrite indicT mul1e /f !indicE. +have [|] /= := boolP (y \in xsection _ _). + by rewrite inE /xsection /= => ->. +by rewrite /xsection /= notin_set /= => /negP/negbTE ->. +Qed. + +Hypothesis H1 : forall X2, measurable X2 -> + measurable_fun [set: T1] ((fun x => mrestr (m2 x) measurableT)^~ X2). + +Lemma indic_measurable_fun_fubini_tonelli_F_dep : measurable_fun setT F. +Proof. +rewrite indic_fubini_tonelli_FE//. +apply: measurable_fun_xsection => //. +by rewrite inE. +Qed. + +End indic_fubini_tonelli. + +End fubini_tonelli. + +Lemma pollard (d d' : measure_display) + (R : realType) + (X : measurableType d) + (Y : measurableType d') + (k : (X * Y)%type -> \bar R) + (k0 : (forall t : X * Y, True -> 0 <= k t)) + (mk : measurable_fun setT k) + (l : finite_kernel R X Y) : +measurable_fun [set: X] (fun x : X => \int[l x]_y k (x, y)). +Proof. +have [k_ [ndk_ k_k]] := @approximation _ _ _ _ measurableT k mk k0. +simpl in *. +rewrite (_ : (fun x => \int[l x]_y k (x, y)) = + (fun x => elim_sup (fun n => \int[l x]_y (k_ n (x, y))%:E))); last first. + apply/funeqP => x. + transitivity (lim (fun n => \int[l x]_y (k_ n (x, y))%:E)); last first. + rewrite is_cvg_elim_supE//. + apply: ereal_nondecreasing_is_cvg => m n mn. + apply: ge0_le_integral => //. + - by move=> y' _; rewrite lee_fin. + - exact/EFin_measurable_fun/measurable_fun_prod1. + - by move=> y' _; rewrite lee_fin. + - exact/EFin_measurable_fun/measurable_fun_prod1. + - by move=> y' _; rewrite lee_fin; apply/lefP/ndk_. + rewrite -monotone_convergence//. + - by apply: eq_integral => y _; apply/esym/cvg_lim => //; exact: k_k. + - by move=> n; exact/EFin_measurable_fun/measurable_fun_prod1. + - by move=> n y' _; rewrite lee_fin. + - by move=> y' _ m n mn; rewrite lee_fin; apply/lefP/ndk_. +apply: measurable_fun_elim_sup => n. +rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \int[l x0]_y + ((\sum_(r <- fset_set (range (k_ n))) + r * \1_(k_ n @^-1` [set r]) (x0, y)))%:E)); last first. + by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. +rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \sum_(r <- fset_set (range (k_ n))) + (\int[l x0]_y + (r * \1_(k_ n @^-1` [set r]) (x0, y))%:E))); last first. + apply/funext => x; rewrite -ge0_integral_sum//. + - by apply: eq_integral => y _; rewrite sumEFin. + - move=> r. + apply/EFin_measurable_fun/measurable_funrM/measurable_fun_prod1 => /=. + by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). + - by move=> m y _; rewrite muleindic_ge0. +apply emeasurable_fun_sum => r. +rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * + \int[l x]_y (\1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. + apply/funext => x. + rewrite (@integralM_indic_new _ _ _ _ _ _ (fun k y => \1_(k_ n @^-1` [set r]) (x, y)))//. + - move=> r_lt0; apply/funext => y. + by rewrite preimage_nnfun0// ?indicE ?in_set0. + - apply/measurable_fun_prod1 => /=. + by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). +apply: emeasurable_funeM. +apply: indic_measurable_fun_fubini_tonelli_F_dep. +- by apply/finite_kernelP. +- by apply/measurable_sfunP. +- move=> X2. + rewrite (_ : (fun x : X => mrestr (l x) measurableT X2) = (fun x : X => (l x) X2))//. + by apply/kernelP. + apply/funeqP => x. + by rewrite /mrestr setIT. +Qed. + +Section star_is_kernel2. +Variables (d d' : _) (R : realType) (X : measurableType d) (Y : measurableType d') + (Z : measurableType (d, d').-prod). +Variable k : finite_kernel R [the measurableType _ of (X * Y)%type] Z. +Variable l : finite_kernel R X Y. -End starkernel. +Lemma star_measurable U : measurable U -> measurable_fun setT (mstar k l ^~ U). +Proof. +(* k is a bounded measurable function *) +(* l is a finite kernel *) +move=> mU. +rewrite /star. +apply: (@pollard _ _ R X Y (fun xy => k xy U)) => //. +by apply: (@kernelP _ _ R [the measurableType (d, d').-prod of (X * Y)%type] Z k U) => //. +Qed. + +HB.instance Definition _ := + isKernel.Build _ _ R X Z (mstar k l) star_measurable. + +End star_is_kernel2. + +Section star_is_finite_kernel. +Variables (d d' : _) (R : realType) (X : measurableType d) (Y : measurableType d') + (Z : measurableType (d, d').-prod). +Variable k : finite_kernel R [the measurableType _ of (X * Y)%type] Z. +Variable l : finite_kernel R X Y. + +Lemma star_finite : exists r : {posnum R}, forall x, star k l x [set: Z] < r%:num%:E. +Proof. +have [r hr] := @finite_kernelP _ _ _ _ _ k. +have [s hs] := @finite_kernelP _ _ _ _ _ l. +exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x. +rewrite /star. +apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). + apply ge0_le_integral => //. + - have := @kernelP _ _ _ _ _ k setT measurableT. + exact/measurable_fun_prod1. + - exact/measurable_fun_cst. + - by move=> y _; apply/ltW/hr. +by rewrite integral_cst//= EFinM lte_pmul2l. +Qed. + +HB.instance Definition _ := + isFiniteKernel.Build _ _ R X Z (mstar k l) star_finite. + +End star_is_finite_kernel. + +Lemma eq_measure (d : measure_display) (T : measurableType d) (R : realType) + (m1 m2 : {measure set T -> \bar R}) : + (forall U, measurable U -> m1 U = m2 U) -> m1 = m2. +Proof. +Abort. + +Section eq_measure_integral_new. +Local Open Scope ereal_scope. +Variables (d : measure_display) (T : measurableType d) (R : realType) + (D : set T). +Implicit Types m : {measure set T -> \bar R}. + +Let eq_measure_integral0 m2 m1 (f : T -> \bar R) : + (forall A, measurable A -> A `<=` D -> m1 A = m2 A) -> + [set sintegral m1 h | h in + [set h : {nnsfun T >-> R} | (forall x, (h x)%:E <= (f \_ D) x)]] `<=` + [set sintegral m2 h | h in + [set h : {nnsfun T >-> R} | (forall x, (h x)%:E <= (f \_ D) x)]]. +Proof. +move=> m12 _ [h hfD <-] /=; exists h => //; apply: eq_fsbigr => r _. +have [hrD|hrD] := pselect (h @^-1` [set r] `<=` D); first by rewrite m12. +suff : r = 0%R by move=> ->; rewrite !mul0e. +apply: contra_notP hrD => /eqP r0 t/= htr. +have := hfD t. +rewrite /patch/=; case: ifPn; first by rewrite inE. +move=> tD. +move: r0; rewrite -htr => ht0. +by rewrite le_eqVlt eqe (negbTE ht0)/= lte_fin// ltNge// fun_ge0. +Qed. + +Lemma eq_measure_integral_new m2 m1 (f : T -> \bar R) : + (forall A, measurable A -> A `<=` D -> m1 A = m2 A) -> + \int[m1]_(x in D) f x = \int[m2]_(x in D) f x. +Proof. +move=> m12; rewrite /integral funepos_restrict funeneg_restrict. +congr (ereal_sup _ - ereal_sup _)%E; rewrite eqEsubset; split; + apply: eq_measure_integral0 => A /m12 //. +by move=> /[apply]. +by move=> /[apply]. +Qed. + +End eq_measure_integral_new. +Arguments eq_measure_integral_new {d T R D} m2 {m1 f}. + +Section star_is_sfinite_kernel. +Variables (d d' : _) (R : realType) (X : measurableType d) (Y : measurableType d') + (Z : measurableType (d, d').-prod). +Variable k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z. +Variable l : sfinite_kernel R X Y. + +Lemma star_sfinite : exists k_ : (finite_kernel R X Z)^nat, forall x U, measurable U -> + mstar k l x U = [the measure _ _ of mseries (k_ ^~ x) O] U. +Proof. +have [k_ hk_] := @sfinite_kernelP _ _ _ _ _ k. +have [l_ hl_] := @sfinite_kernelP _ _ _ _ _ l. +pose K := [the kernel _ _ _ of sum_of_kernels k_]. +pose L := [the kernel _ _ _ of sum_of_kernels l_]. +have H1 x U : measurable U -> star k l x U = star K L x U. + move=> mU. + rewrite /star /L /K /=. + transitivity (\int[ + [the measure _ _ of mseries (fun x0 : nat => l_ x0 x) 0] +]_y k (x, y) U). + apply eq_measure_integral_new => A mA _ . + by rewrite hl_. + apply eq_integral => y _. + by rewrite hk_//. +have H2 x U : star K L x U = + \int[mseries (l_ ^~ x) 0]_y (\sum_(i y _. +have H3 x U : measurable U -> + \int[mseries (l_ ^~ x) 0]_y (\sum_(i mU. + rewrite integral_sum//= => n. + have := @kernelP _ _ _ _ _ (k_ n) _ mU. + by move/measurable_fun_prod1; exact. +have H4 x U : measurable U -> + \sum_(i mU. + apply: eq_nneseries => i _. + rewrite integral_sum_of_kernels//. + have := @kernelP _ _ _ _ _ (k_ i) _ mU. + by move/measurable_fun_prod1; exact. +have H5 x U : \sum_(i i _; exact: eq_nneseries. +suff: exists k_0 : (finite_kernel R X Z) ^nat, forall x U, + \esum_(i in setT) star (k_ i.1) (l_ i.2) x U = \sum_(i [kl_ hkl_]. + exists kl_ => x U mU. + rewrite /=. + rewrite /mstar/= /mseries H1// H2 H3//. + rewrite H4//. + rewrite H5// -hkl_ /=. + rewrite (_ : setT = setT `*`` (fun=> setT)); last by apply/seteqP; split. + rewrite -(@esum_esum _ _ _ _ _ (fun i j => star (k_ i) (l_ j) x U))//. + rewrite nneseries_esum; last by move=> n _; exact: nneseries_lim_ge0(* TODO: rename this lemma *). + by rewrite fun_true; apply: eq_esum => /= i _; rewrite nneseries_esum// fun_true. +rewrite /=. +have /ppcard_eqP[f] : ([set: nat] #= [set: nat * nat])%card. + by rewrite card_eq_sym; exact: card_nat2. +exists (fun i => [the finite_kernel _ _ _ of mstar (k_ (f i).1) (l_ (f i).2)]) => x U. +rewrite (reindex_esum [set: nat] [set: nat * nat] f)//. +by rewrite nneseries_esum// fun_true. +Qed. + +HB.instance Definition _ := + isSFiniteKernel.Build d ((d, d').-prod)%mdisp R X Z (mstar k l) star_sfinite. + +End star_is_sfinite_kernel. -Lemma lemma3 (R : realType) (X Y Z : measurableType) - (k : sfinitekernel R [the measurableType of (X * Y)%type] Z) - (l : sfinitekernel R X Y) : forall x f, - \int[star_kernel k l x]_z f z = - \int[l x]_y (\int[k (x, y)]_z f z). +Lemma lemma3_indic d d' (R : realType) (X : measurableType d) + (Y : measurableType d') (Z : measurableType (d, d').-prod) + (k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z) + (l : sfinite_kernel R X Y) x (E : set _) (mE : measurable E) : + \int[mstar k l x]_z (\1_E z)%:E = \int[l x]_y (\int[k (x, y)]_z (\1_E z)%:E). Proof. +rewrite integral_indic// /mstar/= /star/=. +by apply eq_integral => y _; rewrite integral_indic. +Qed. + +Lemma lemma3_nnsfun d d' (R : realType) (X : measurableType d) + (Y : measurableType d') (Z : measurableType (d, d').-prod) + (k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z) + (l : sfinite_kernel R X Y) x (f : {nnsfun Z >-> R}) : + \int[mstar k l x]_z (f z)%:E = \int[l x]_y (\int[k (x, y)]_z (f z)%:E). +Proof. +under eq_integral do rewrite fimfunE -sumEFin. +rewrite ge0_integral_sum//; last 2 first. + move=> r. + apply/EFin_measurable_fun/measurable_funrM. + have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). + by move=> r z _; rewrite EFinM muleindic_ge0. +under eq_bigr. + move=> r _. + rewrite /=. + rewrite (@integralM_indic_new _ _ _ _ _ _ (fun r x0 => \1_(f @^-1` [set r]) x0))//; last 2 first. + move=> r0. + apply/funext => z/=. + by rewrite indicE memNset// preimage_nnfun0. + have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). + rewrite /=. + rewrite lemma3_indic//. + over. +rewrite /=. +apply/esym. +Admitted. + +Lemma lemma3 d d' (R : realType) (X : measurableType d) + (Y : measurableType d') (Z : measurableType (d, d').-prod) + (k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z) + (l : sfinite_kernel R X Y) x f : (forall z, 0 <= f z) -> measurable_fun setT f -> + \int[mstar k l x]_z f z = \int[l x]_y (\int[k (x, y)]_z f z). +Proof. +move=> f0 mf. +have [f_ [ndf_ f_f]] := approximation measurableT mf (fun z _ => f0 z). +simpl in *. (* TODO *) Admitted. + +HB.mixin Record isProbability (d : measure_display) (T : measurableType d) + (R : realType) (P : set T -> \bar R) of isMeasure d R T P := + { probability_setT : P setT = 1%E }. + +#[short(type=probability)] +HB.structure Definition Probability (d : measure_display) (T : measurableType d) + (R : realType) := + {P of isProbability d T R P & isMeasure d R T P }. + +Section discrete_measurable2. + +Definition discrete_measurable_bool : set (set bool) := [set: set bool]. + +Let discrete_measurable0 : discrete_measurable_bool set0. Proof. by []. Qed. + +Let discrete_measurableC X : + discrete_measurable_bool X -> discrete_measurable_bool (~` X). +Proof. by []. Qed. + +Let discrete_measurableU (F : (set bool)^nat) : + (forall i, discrete_measurable_bool (F i)) -> + discrete_measurable_bool (\bigcup_i F i). +Proof. by []. Qed. + +HB.instance Definition _ := @isMeasurable.Build default_measure_display bool (Pointed.class _) + discrete_measurable_bool discrete_measurable0 discrete_measurableC + discrete_measurableU. + +End discrete_measurable2. + +Definition twoseven (R : realType) : {nonneg R}. +Admitted. + +Definition fiveseven (R : realType) : {nonneg R}. +Admitted. + +Definition bernoulli (R : realType) : {measure set _ -> \bar R} := + [the measure _ _ of measure_add + [the measure _ _ of mscale (twoseven R) [the measure _ _ of dirac true]] + [the measure _ _ of mscale (fiveseven R) [the measure _ _ of dirac false]]]. + +Canonical unit_pointedType := PointedType unit tt. + +Section unit_measurable. + +Definition unit_measurable : set (set unit) := [set: set unit]. + +Let unit_measurable0 : unit_measurable set0. Proof. by []. Qed. + +Let unit_measurableC X : unit_measurable X -> unit_measurable (~` X). +Proof. by []. Qed. + +Let unit_measurableU (F : (set unit)^nat) : + (forall i, unit_measurable (F i)) -> unit_measurable (\bigcup_i F i). +Proof. by []. Qed. + +HB.instance Definition _ := @isMeasurable.Build default_measure_display unit (Pointed.class _) + unit_measurable unit_measurable0 unit_measurableC + unit_measurableU. + +End unit_measurable. + +(* semantics for a sample operation? *) +Section kernel_from_measure. +Variables (d : measure_display) (R : realType) (X : measurableType d). +Variable m : {measure set X -> \bar R}. (* measure, probability measure *) + +Definition kernel_from_measure : unit -> {measure set X -> \bar R} := + fun _ : unit => m. + +Lemma kernel_from_measureP : forall U, measurable U -> measurable_fun setT (kernel_from_measure ^~ U). +Proof. by []. Qed. + +HB.instance Definition _ := + @isKernel.Build default_measure_display d R _ X kernel_from_measure + kernel_from_measureP. +End kernel_from_measure. + +(* semantics for return? *) +Section kernel_from_dirac. +Variables (R : realType) (d : _) (T : measurableType d). + +Definition kernel_from_dirac : T -> {measure set T -> \bar R} := + fun x => [the measure _ _ of dirac x]. + +Lemma kernel_from_diracP : forall U, measurable U -> measurable_fun setT (kernel_from_dirac ^~ U). +Proof. +move=> U mU. +rewrite /kernel_from_dirac. +rewrite /=. +rewrite /dirac/=. +apply/EFin_measurable_fun. +rewrite [X in measurable_fun _ X](_ : _ = mindic R mU)//. +Qed. + +HB.instance Definition _ := + isKernel.Build _ _ R _ _ kernel_from_dirac kernel_from_diracP. +End kernel_from_dirac. + +(* let x = sample (bernoulli 2/7) in + return x *) + +Definition letin (d d' d3 : measure_display) (R : realType) + (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) + (l : X ^^> Y) (k : _ ^^> Z) : X -> {measure set Z -> \bar R}:= + @mstar _ _ _ R _ _ _ k l. + +Section sample_program. +Variables (R : realType). + +Definition sample_bernoulli27 (*NB: 1 ^^> bool *) := + [the kernel _ _ _ of kernel_from_measure (bernoulli R)] . + +Definition Return : kernel R _ [the measurableType (default_measure_display,default_measure_display).-prod of (Datatypes_unit__canonical__measure_SemiRingOfSets * Datatypes_bool__canonical__measure_SemiRingOfSets)%type] (* NB: 1 * bool ^^> 1 * bool *) := + [the kernel _ _ _ of @kernel_from_dirac R _ _]. + +Definition program : unit -> set (unit * bool) -> \bar R (* NB: 1 ^^> 1 * bool *) := + letin + sample_bernoulli27 + Return. + +Lemma programE : forall U, program tt U = + ((twoseven R)%:num)%:E * \d_(tt, true) U + + ((fiveseven R)%:num)%:E * \d_(tt, false) U. +Proof. +move=> U. +rewrite /program/= /star/=. +rewrite ge0_integral_measure_sum// 2!big_ord_recl/= big_ord0 adde0/=. +rewrite !ge0_integral_mscale//=. +rewrite !integral_dirac//=. +by rewrite indicE in_setT mul1e indicE in_setT mul1e. +Qed. + +End sample_program. From 2f3d34cf851436e3c65305142a7da4e15f1aef72 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Fri, 22 Jul 2022 19:20:17 +0900 Subject: [PATCH 07/54] complete lemma 3 and s-finite proofs - s-finite proofs for bernoulli, return, score - various fixes --- theories/kernel.v | 1168 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 910 insertions(+), 258 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 6568e49d5b..1e1abeb33c 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -15,6 +15,26 @@ Local Open Scope classical_set_scope. Local Open Scope ring_scope. Local Open Scope ereal_scope. +(* PR 516 in progress *) +HB.mixin Record isProbability (d : measure_display) (T : measurableType d) + (R : realType) (P : set T -> \bar R) of isMeasure d R T P := + { probability_setT : P setT = 1%E }. + +#[short(type=probability)] +HB.structure Definition Probability (d : measure_display) (T : measurableType d) + (R : realType) := + {P of isProbability d T R P & isMeasure d R T P }. + +Section probability_lemmas. +Variables (d : _) (T : measurableType d) (R : realType) (P : probability T R). + +Lemma probability_le1 (A : set T) : measurable A -> (P A <= 1)%E. +Proof. +Admitted. + +End probability_lemmas. +(* /PR 516 in progress *) + HB.mixin Record isKernel (d d' : measure_display) (R : realType) (X : measurableType d) (Y : measurableType d') (k : X -> {measure set Y -> \bar R}) := { @@ -27,6 +47,7 @@ HB.structure Definition Kernel (d d' : measure_display) {k & isKernel d d' R X Y k}. Notation "X ^^> Y" := (kernel _ X Y) (at level 42). +(* TODO: define using the probability type *) HB.mixin Record isProbabilityKernel (d d' : measure_display) (R : realType) (X : measurableType d) (Y : measurableType d') (k : X -> {measure set Y -> \bar R}) @@ -58,8 +79,7 @@ rewrite [X in measurable_fun _ X](_ : _ = by rewrite -lim_mkord. exact: is_cvg_nneseries. apply: measurable_fun_elim_sup => n. -apply: emeasurable_fun_sum => *. -by apply/kernelP. +by apply: emeasurable_fun_sum => *; exact/kernelP. Qed. HB.instance Definition _ := @@ -78,12 +98,18 @@ Proof. by move=> f0 mf; rewrite /sum_of_kernels/= ge0_integral_measure_series. Qed. +Section kernel_uub. +Variables (d d' : measure_display) (R : numFieldType) (X : measurableType d) + (Y : measurableType d') (k : X -> set Y -> \bar R). + +Definition kernel_uub := exists r : {posnum R}, forall x, k x [set: Y] < r%:num%:E. + +End kernel_uub. + HB.mixin Record isFiniteKernel (d d' : measure_display) (R : realType) (X : measurableType d) (Y : measurableType d') (k : X -> {measure set Y -> \bar R}) - of isKernel d d' R X Y k := { - finite_kernelP : exists r : {posnum R}, forall x, k x [set: Y] < r%:num%:E -}. + := { finite_kernelP : kernel_uub k }. #[short(type=finite_kernel)] HB.structure Definition FiniteKernel (d d' : measure_display) @@ -93,63 +119,85 @@ HB.structure Definition FiniteKernel (d d' : measure_display) HB.mixin Record isSFiniteKernel (d d' : measure_display) (R : realType) (X : measurableType d) (Y : measurableType d') (k : X -> {measure set Y -> \bar R}) - of isKernel d d' R X Y k := { - sfinite_kernelP : exists k_ : (finite_kernel R X Y)^nat, forall x U, - measurable U -> - k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U + := { + sfinite_kernelP : exists k_ : (finite_kernel R X Y)^nat, + forall x U, measurable U -> + k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U }. #[short(type=sfinite_kernel)] HB.structure Definition SFiniteKernel (d d' : measure_display) (R : realType) (X : measurableType d) (Y : measurableType d') := {k of isSFiniteKernel d d' R X Y k & - isFiniteKernel d d' R X Y k & isKernel d d' R X Y k}. -Section star_is_kernel. -Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3). +Section star_is_measure. +Variables (d1 d2 d3 : _) (R : realType) (X : measurableType d1) + (Y : measurableType d2) (Z : measurableType d3). Variable k : kernel R [the measurableType _ of (X * Y)%type] Z. Variable l : kernel R X Y. Definition star : X -> set Z -> \bar R := fun x U => \int[l x]_y k (x, y) U. -Let star0 (x : X) : star x set0 = 0. +Let star0 x : star x set0 = 0. Proof. by rewrite /star (eq_integral (cst 0)) ?integral0// => y _; rewrite measure0. Qed. -Let star_ge0 (x : X) (U : set Z) : 0 <= star x U. +Let star_ge0 x U : 0 <= star x U. Proof. by apply: integral_ge0 => y _; exact: measure_ge0. Qed. -Let star_sigma_additive (x : X) : semi_sigma_additive (star x). +Let star_sigma_additive x : semi_sigma_additive (star x). Proof. -move=> U mU tU mUU. -rewrite [X in _ --> X](_ : _ = +move=> U mU tU mUU; rewrite [X in _ --> X](_ : _ = \int[l x]_y (\sum_(n V _. by apply/esym/cvg_lim => //; exact/measure_semi_sigma_additive. apply/cvg_closeP; split. by apply: is_cvg_nneseries => n _; exact: integral_ge0. rewrite closeE// integral_sum// => n. -move: (@kernelP _ _ R _ _ k (U n) (mU n)) => /measurable_fun_prod1. -exact. +have := @kernelP _ _ R _ _ k (U n) (mU n). +exact/measurable_fun_prod1. Qed. -HB.instance Definition _ (x : X) := - isMeasure.Build _ R _ (star x) (star0 x) (star_ge0 x) (@star_sigma_additive x). +HB.instance Definition _ x := isMeasure.Build _ R _ + (star x) (star0 x) (star_ge0 x) (@star_sigma_additive x). -Definition mstar : X -> {measure set Z -> \bar R} := fun x => [the measure _ _ of star x]. +Definition mstar : X -> {measure set Z -> \bar R} := + fun x => [the measure _ _ of star x]. -End star_is_kernel. +End star_is_measure. (* TODO: PR *) -Section integralM_indic. +Section integralM_0ifneg. +Local Open Scope ereal_scope. +Variables (d : measure_display) (T : measurableType d) (R : realType). +Variables (m : {measure set T -> \bar R}) (D : set T) (mD : measurable D). + +Lemma integralM_0ifneg (f : R -> T -> \bar R) (k : R) + (f0 : forall r t, D t -> (0 <= f r t)) : + ((k < 0)%R -> f k = cst 0%E) -> measurable_fun setT (f k) -> + \int[m]_(x in D) (k%:E * (f k) x) = k%:E * \int[m]_(x in D) ((f k) x). +Proof. +move=> fk0 mfk; have [k0|k0] := ltP k 0%R. + rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0; last first. + by move=> x _; rewrite fk0// mule0. + rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0// => x _. + by rewrite fk0// indic0. +rewrite ge0_integralM//. +- by apply/(@measurable_funS _ _ _ _ setT) => //. +- by move=> y Dy; rewrite f0. +Qed. + +End integralM_0ifneg. +Arguments integralM_0ifneg {d T R} m {D} mD f. + +(*Section integralM_0ifneg. Local Open Scope ereal_scope. Variables (d : measure_display) (T : measurableType d) (R : realType). Variables (m : {measure set T -> \bar R}) (D : set T) (mD : measurable D). -Lemma integralM_indic_new (f : R -> T -> R) (k : R) +Lemma integralM_0ifneg (f : R -> T -> R) (k : R) (f0 : forall r t, D t -> (0 <= f r t)%R) : ((k < 0)%R -> f k = cst 0%R) -> measurable_fun setT (f k) -> \int[m]_(x in D) (k * (f k) x)%:E = k%:E * \int[m]_(x in D) ((f k) x)%:E. @@ -165,31 +213,31 @@ rewrite ge0_integralM//. - by move=> y Dy; rewrite lee_fin f0. Qed. -End integralM_indic. +End integralM_0ifneg. +Arguments integralM_0ifneg {d T R} m {D} mD f.*) -Section test. +Section integralM_indic. Local Open Scope ereal_scope. Variables (d : measure_display) (T : measurableType d) (R : realType). Variables (m : {measure set T -> \bar R}) (D : set T) (mD : measurable D). -Lemma integralM_indic_test (f : R -> set T) (k : R) : +Let integralM_indic (f : R -> set T) (k : R) : ((k < 0)%R -> f k = set0) -> measurable (f k) -> \int[m]_(x in D) (k * \1_(f k) x)%:E = k%:E * \int[m]_(x in D) (\1_(f k) x)%:E. Proof. move=> fk0 mfk. -apply: (@integralM_indic_new _ _ _ _ _ _ (fun k x => \1_(f k) x)) => //=. - move/fk0 => -> /=. - apply/funext => x. - by rewrite indicE in_set0. -by rewrite (_ : \1_(f k) = mindic R mfk). +under eq_integral do rewrite EFinM. +apply: (integralM_0ifneg _ _ (fun k x => (\1_(f k) x)%:E)) => //=. +- by move=> r t Dt; rewrite lee_fin. +- by move/fk0 => -> /=; apply/funext => x; rewrite indicE in_set0. +- apply/EFin_measurable_fun. + by rewrite (_ : \1_(f k) = mindic R mfk). Qed. -End test. - - -Lemma muleCA (R : realType) : left_commutative ( *%E : _ -> _ -> \bar R). -Proof. by move=> x y z; rewrite muleC (muleC x) muleA. Qed. +End integralM_indic. +Arguments integralM_indic {d T R} m {D} mD f. +(* NB: PR in progress *) Section integral_mscale. Variables (R : realType) (k : {nonneg R}). Variables (d : measure_display) (T : measurableType d). @@ -201,7 +249,6 @@ Let integral_mscale_indic (E : set T) (mE : measurable E) : k%:num%:E * \int[m]_(x in D) (\1_E x)%:E. Proof. by rewrite !integral_indic. Qed. -(*NB: notation { mfun aT >-> rT} broken? *) Let integral_mscale_nnsfun (h : {nnsfun T >-> R}) : \int[mscale k m]_(x in D) (h x)%:E = k%:num%:E * \int[m]_(x in D) (h x)%:E. Proof. @@ -240,19 +287,7 @@ rewrite ge0_integralM//; last 2 first. have fr : measurable (h @^-1` [set r]) by exact/measurable_sfunP. by rewrite (_ : \1__ = mindic R fr). by move=> t Dt; rewrite muleindic_ge0. -rewrite (@integralM_indic_new _ _ _ _ _ _ (fun r x => \1_(h @^-1` [set r]) x))//; last 2 first. - move=> r0. - by rewrite preimage_nnfun0// indic0. - have fr : measurable (h @^-1` [set r]) by exact/measurable_sfunP. - by rewrite (_ : \1__ = mindic R fr). -rewrite /=. -rewrite (@integralM_indic_new _ _ _ _ _ _ (fun r x => \1_(h @^-1` [set r]) x))//; last 2 first. - move=> r0. - by rewrite preimage_nnfun0// indic0. - have fr : measurable (h @^-1` [set r]) by exact/measurable_sfunP. - by rewrite (_ : \1__ = mindic R fr). -rewrite integral_mscale_indic//. -by rewrite muleCA. +by rewrite !integralM_indic_nnsfun//= integral_mscale_indic// muleCA. Qed. Lemma ge0_integral_mscale (mf : measurable_fun D f) : @@ -290,15 +325,12 @@ rewrite -ereal_limrM//; last first. move=> x Dx. rewrite lee_fin. by move/ndf_ : ab => /lefP. -congr (lim _). -apply/funext => n /=. -by rewrite integral_mscale_nnsfun//. +congr (lim _); apply/funext => n /=. +by rewrite integral_mscale_nnsfun. Qed. End integral_mscale. -(* TODO: rename emeasurable_funeM? *) - Section ndseq_closed_B. Variables (d1 d2 : measure_display). Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). @@ -309,7 +341,7 @@ Variables (pt2 : T2) (m2 : T1 -> {measure set T2 -> \bar R}). Let phi A x := m2 x (xsection A x). Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. -Lemma xsection_ndseq_closed : ndseq_closed B. +Lemma xsection_ndseq_closed_dep : ndseq_closed B. Proof. move=> F ndF; rewrite /B /= => BF; split. by apply: bigcupT_measurable => n; have [] := BF n. @@ -341,7 +373,7 @@ Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. Hypothesis H1 : forall X2, measurable X2 -> measurable_fun [set: T1] (m2D^~ X2). -Lemma measurable_prod_subset_xsection +Lemma measurable_prod_subset_xsection_dep (m2D_bounded : forall x, exists M, forall X, measurable X -> (m2D x X < M%:E)%E) : measurable `<=` B. Proof. @@ -363,7 +395,7 @@ have CB : C `<=` B. apply/EFin_measurable_fun. by rewrite (_ : \1_ _ = mindic R mX1). suff monoB : monotone_class setT B by exact: monotone_class_subset. -split => //; [exact: CB| |exact: xsection_ndseq_closed]. +split => //; [exact: CB| |exact: xsection_ndseq_closed_dep]. move=> X Y XY [mX mphiX] [mY mphiY]; split; first exact: measurableD. have -> : phi (X `\` Y) = (fun x => phi X x - phi Y x)%E. rewrite funeqE => x; rewrite /phi/= xsectionD// /m2D measureD. @@ -380,49 +412,39 @@ End xsection. End measurable_prod_subset. -(*NB: measurable_xsection as a superfluous parameter*) - Section measurable_fun_xsection. -Variables (d1 d2 : measure_display). -Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). +Variables (d1 d2 : measure_display) (T1 : measurableType d1) + (T2 : measurableType d2) (R : realType). Variables (m2 : T1 -> {measure set T2 -> \bar R}). Implicit Types A : set (T1 * T2). -Hypotheses (sm2 : exists r : {posnum R}, forall x, m2 x [set: T2] < r%:num%:E). +Hypotheses m2_ub : kernel_uub m2. -Hypothesis H1 : forall X2, measurable X2 -> measurable_fun [set: T1] ((fun x => mrestr (m2 x) measurableT)^~ X2). +Hypothesis H1 : forall X2, measurable X2 -> + measurable_fun [set: T1] ((fun x => mrestr (m2 x) measurableT)^~ X2). Let phi A := (fun x => m2 x (xsection A x)). Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. -Lemma measurable_fun_xsection A : +Lemma measurable_fun_xsection_dep A : A \in measurable -> measurable_fun setT (phi A). Proof. move: A; suff : measurable `<=` B by move=> + A; rewrite inE => /[apply] -[]. move=> X mX. -(*move/sigma_finiteP : sf_m2 => [F F_T [F_nd F_oo]] X mX.*) -(*have -> : X = \bigcup_n (X `&` (setT `*` F n)). - by rewrite -setI_bigcupr -setM_bigcupr -F_T setMTT setIT. -apply: xsection_ndseq_closed. - move=> m n mn; apply/subsetPset; apply: setIS; apply: setSM => //. - exact/subsetPset/F_nd. -move=> n; rewrite -/B; have [? ?] := F_oo n.*) -(*pose m2Fn := [the measure _ _ of mrestr m2 (F_oo n).1].*) rewrite /B/=; split => //. rewrite /phi. rewrite -(_ : (fun x : T1 => mrestr (m2 x) measurableT (xsection X x)) = (fun x => (m2 x) (xsection X x)))//; last first. apply/funext => x//=. by rewrite /mrestr setIT. -apply measurable_prod_subset_xsection => //; last first. - move=> x. - case: sm2 => r hr. - exists r%:num => Y mY. - apply: (le_lt_trans _ (hr x)) => //. - rewrite /mrestr. - apply le_measure => //. - rewrite inE. - apply: measurableI => //. - by rewrite inE. - +apply measurable_prod_subset_xsection_dep => //. +move=> x. +case: m2_ub => r hr. +exists r%:num => Y mY. +apply: (le_lt_trans _ (hr x)) => //. +rewrite /mrestr. +apply le_measure => //. +rewrite inE. +apply: measurableI => //. +by rewrite inE. Qed. End measurable_fun_xsection. @@ -443,7 +465,7 @@ Local Open Scope ereal_scope. Variables (d1 d2 : measure_display). Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). Variables (m1 : {measure set T1 -> \bar R}) (m2 : T1 -> {measure set T2 -> \bar R}). -Hypotheses (sm2 : exists r : {posnum R}, forall x, m2 x [set: T2] < r%:num%:E). +Hypotheses m2_ub : kernel_uub m2. Section indic_fubini_tonelli. Variables (A : set (T1 * T2)) (mA : measurable A). @@ -452,7 +474,7 @@ Let f : (T1 * T2) -> R := \1_A. Let F := fubini_F_dep m2 (EFin \o f). -Lemma indic_fubini_tonelli_FE : F = (fun x => m2 x (xsection A x)). +Lemma indic_fubini_tonelli_FE_dep : F = (fun x => m2 x (xsection A x)). Proof. rewrite funeqE => x; rewrite /= -(setTI (xsection _ _)). rewrite -integral_indic//; last exact: measurable_xsection. @@ -469,8 +491,7 @@ Hypothesis H1 : forall X2, measurable X2 -> Lemma indic_measurable_fun_fubini_tonelli_F_dep : measurable_fun setT F. Proof. -rewrite indic_fubini_tonelli_FE//. -apply: measurable_fun_xsection => //. +rewrite indic_fubini_tonelli_FE_dep//; apply: measurable_fun_xsection_dep => //. by rewrite inE. Qed. @@ -478,15 +499,11 @@ End indic_fubini_tonelli. End fubini_tonelli. -Lemma pollard (d d' : measure_display) - (R : realType) - (X : measurableType d) - (Y : measurableType d') - (k : (X * Y)%type -> \bar R) - (k0 : (forall t : X * Y, True -> 0 <= k t)) - (mk : measurable_fun setT k) - (l : finite_kernel R X Y) : -measurable_fun [set: X] (fun x : X => \int[l x]_y k (x, y)). +Lemma pollard_finite (d d' : measure_display) (R : realType) + (X : measurableType d) (Y : measurableType d') + (k : (X * Y)%type -> \bar R) (k0 : (forall t : X * Y, True -> 0 <= k t)) + (mk : measurable_fun setT k) (l : finite_kernel R X Y) : + measurable_fun [set: X] (fun x : X => \int[l x]_y k (x, y)). Proof. have [k_ [ndk_ k_k]] := @approximation _ _ _ _ measurableT k mk k0. simpl in *. @@ -525,12 +542,13 @@ apply emeasurable_fun_sum => r. rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * \int[l x]_y (\1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. apply/funext => x. - rewrite (@integralM_indic_new _ _ _ _ _ _ (fun k y => \1_(k_ n @^-1` [set r]) (x, y)))//. - - move=> r_lt0; apply/funext => y. - by rewrite preimage_nnfun0// ?indicE ?in_set0. - - apply/measurable_fun_prod1 => /=. + under eq_integral do rewrite EFinM. + rewrite (integralM_0ifneg _ _ (fun k y => (\1_(k_ n @^-1` [set r]) (x, y))%:E))//. + - by move=> _ t _; rewrite lee_fin. + - by move=> r_lt0; apply/funext => y; rewrite preimage_nnfun0// indicE in_set0. + - apply/EFin_measurable_fun/measurable_fun_prod1 => /=. by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). -apply: emeasurable_funeM. +apply: measurable_funeM. apply: indic_measurable_fun_fubini_tonelli_F_dep. - by apply/finite_kernelP. - by apply/measurable_sfunP. @@ -541,41 +559,43 @@ apply: indic_measurable_fun_fubini_tonelli_F_dep. by rewrite /mrestr setIT. Qed. -Section star_is_kernel2. -Variables (d d' : _) (R : realType) (X : measurableType d) (Y : measurableType d') - (Z : measurableType (d, d').-prod). -Variable k : finite_kernel R [the measurableType _ of (X * Y)%type] Z. +Module STAR_IS_FINITE_KERNEL. + +Section star_is_kernel_finite. +Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3). +Variable k : kernel R [the measurableType _ of (X * Y)%type] Z. Variable l : finite_kernel R X Y. -Lemma star_measurable U : measurable U -> measurable_fun setT (mstar k l ^~ U). +Lemma star_measurable_finite U : measurable U -> measurable_fun setT (star k l ^~ U). Proof. (* k is a bounded measurable function *) (* l is a finite kernel *) move=> mU. rewrite /star. -apply: (@pollard _ _ R X Y (fun xy => k xy U)) => //. +apply: (@pollard_finite _ _ R X Y (fun xy => k xy U)) => //. by apply: (@kernelP _ _ R [the measurableType (d, d').-prod of (X * Y)%type] Z k U) => //. Qed. HB.instance Definition _ := - isKernel.Build _ _ R X Z (mstar k l) star_measurable. + isKernel.Build _ _ R X Z (mstar k l) star_measurable_finite. -End star_is_kernel2. +End star_is_kernel_finite. Section star_is_finite_kernel. -Variables (d d' : _) (R : realType) (X : measurableType d) (Y : measurableType d') - (Z : measurableType (d, d').-prod). +Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3). Variable k : finite_kernel R [the measurableType _ of (X * Y)%type] Z. Variable l : finite_kernel R X Y. -Lemma star_finite : exists r : {posnum R}, forall x, star k l x [set: Z] < r%:num%:E. +Lemma star_finite : kernel_uub (mstar k l). Proof. have [r hr] := @finite_kernelP _ _ _ _ _ k. have [s hs] := @finite_kernelP _ _ _ _ _ l. exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x. rewrite /star. apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). - apply ge0_le_integral => //. + apply: ge0_le_integral => //. - have := @kernelP _ _ _ _ _ k setT measurableT. exact/measurable_fun_prod1. - exact/measurable_fun_cst. @@ -587,57 +607,159 @@ HB.instance Definition _ := isFiniteKernel.Build _ _ R X Z (mstar k l) star_finite. End star_is_finite_kernel. - -Lemma eq_measure (d : measure_display) (T : measurableType d) (R : realType) - (m1 m2 : {measure set T -> \bar R}) : - (forall U, measurable U -> m1 U = m2 U) -> m1 = m2. +End STAR_IS_FINITE_KERNEL. + +Lemma pollard_sfinite (d d' d3 : measure_display) (R : realType) + (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) + (k : Z -> \bar R) (k0 : (forall z, True -> 0 <= k z)) + (mk : measurable_fun setT k) + (l : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z) c : + measurable_fun [set: Y] (fun x0 : Y => \int[l (c, x0)]_z k z). Proof. -Abort. +have [k_ [ndk_ k_k]] := @approximation _ _ _ _ measurableT k mk k0. +simpl in *. +rewrite (_ : (fun x0 => \int[l (c, x0)]_z k z) = + (fun x0 => elim_sup (fun n => \int[l (c, x0)]_z (k_ n z)%:E))); last first. + apply/funeqP => x. + transitivity (lim (fun n => \int[l (c, x)]_z (k_ n z)%:E)); last first. + rewrite is_cvg_elim_supE//. + apply: ereal_nondecreasing_is_cvg => m n mn. + apply: ge0_le_integral => //. + - by move=> y' _; rewrite lee_fin. + - exact/EFin_measurable_fun. + - by move=> y' _; rewrite lee_fin. + - exact/EFin_measurable_fun. + - by move=> y' _; rewrite lee_fin; apply/lefP/ndk_. + rewrite -monotone_convergence//. + - by apply: eq_integral => y _; apply/esym/cvg_lim => //; exact: k_k. + - by move=> n; exact/EFin_measurable_fun. + - by move=> n y' _; rewrite lee_fin. + - by move=> y' _ m n mn; rewrite lee_fin; apply/lefP/ndk_. +apply: measurable_fun_elim_sup => n. +rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \int[l (c, x0)]_z + ((\sum_(r <- fset_set (range (k_ n))) + r * \1_(k_ n @^-1` [set r]) z))%:E)); last first. + by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. +rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \sum_(r <- fset_set (range (k_ n))) + (\int[l (c, x0)]_z + (r * \1_(k_ n @^-1` [set r]) z)%:E))); last first. + apply/funext => x; rewrite -ge0_integral_sum//. + - by apply: eq_integral => y _; rewrite sumEFin. + - move=> r. + apply/EFin_measurable_fun/measurable_funrM => /=. + by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). + - by move=> m y _; rewrite muleindic_ge0. +apply emeasurable_fun_sum => r. +rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * + \int[l (c ,x)]_z (\1_(k_ n @^-1` [set r]) z)%:E)); last first. + apply/funext => x. + under eq_integral do rewrite EFinM. + rewrite (integralM_0ifneg _ _ (fun k z => (\1_(k_ n @^-1` [set r]) z)%:E))//. + - by move=> _ t _; rewrite lee_fin. + - by move=> r_lt0; apply/funext => y; rewrite preimage_nnfun0// indicE in_set0. + - apply/EFin_measurable_fun => /=. + by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). +apply: measurable_funeM. +rewrite (_ : (fun x : Y => \int[l (c, x)]_z (\1_(k_ n @^-1` [set r]) z)%:E) = + (fun x : Y => l (c, x) (k_ n @^-1` [set r]))); last first. + apply/funext => y. + by rewrite integral_indic// setIT. +have := @kernelP _ _ R _ _ l (k_ n @^-1` [set r]) (measurable_sfunP (k_ n) r). +rewrite /=. +move/measurable_fun_prod1. +exact. +Qed. -Section eq_measure_integral_new. -Local Open Scope ereal_scope. -Variables (d : measure_display) (T : measurableType d) (R : realType) - (D : set T). -Implicit Types m : {measure set T -> \bar R}. - -Let eq_measure_integral0 m2 m1 (f : T -> \bar R) : - (forall A, measurable A -> A `<=` D -> m1 A = m2 A) -> - [set sintegral m1 h | h in - [set h : {nnsfun T >-> R} | (forall x, (h x)%:E <= (f \_ D) x)]] `<=` - [set sintegral m2 h | h in - [set h : {nnsfun T >-> R} | (forall x, (h x)%:E <= (f \_ D) x)]]. -Proof. -move=> m12 _ [h hfD <-] /=; exists h => //; apply: eq_fsbigr => r _. -have [hrD|hrD] := pselect (h @^-1` [set r] `<=` D); first by rewrite m12. -suff : r = 0%R by move=> ->; rewrite !mul0e. -apply: contra_notP hrD => /eqP r0 t/= htr. -have := hfD t. -rewrite /patch/=; case: ifPn; first by rewrite inE. -move=> tD. -move: r0; rewrite -htr => ht0. -by rewrite le_eqVlt eqe (negbTE ht0)/= lte_fin// ltNge// fun_ge0. -Qed. - -Lemma eq_measure_integral_new m2 m1 (f : T -> \bar R) : - (forall A, measurable A -> A `<=` D -> m1 A = m2 A) -> - \int[m1]_(x in D) f x = \int[m2]_(x in D) f x. -Proof. -move=> m12; rewrite /integral funepos_restrict funeneg_restrict. -congr (ereal_sup _ - ereal_sup _)%E; rewrite eqEsubset; split; - apply: eq_measure_integral0 => A /m12 //. -by move=> /[apply]. -by move=> /[apply]. -Qed. - -End eq_measure_integral_new. -Arguments eq_measure_integral_new {d T R D} m2 {m1 f}. +Lemma pollard_sfinite2 (d d' : measure_display) (R : realType) + (X : measurableType d) (Y : measurableType d') + (k : (X * Y)%type -> \bar R) (k0 : (forall (t : X * Y), True -> 0 <= k t)) + (l : sfinite_kernel R X Y) + (mk : measurable_fun setT k) : + measurable_fun [set: X] (fun x : X => \int[l x]_y k (x, y)). +Proof. +have [k_ [ndk_ k_k]] := @approximation _ _ _ _ measurableT k mk k0. +simpl in *. +rewrite (_ : (fun x => \int[l x]_y k (x, y)) = + (fun x => elim_sup (fun n => \int[l x]_y (k_ n (x, y))%:E))); last first. + apply/funeqP => x. + transitivity (lim (fun n => \int[l x]_y (k_ n (x, y))%:E)); last first. + rewrite is_cvg_elim_supE//. + apply: ereal_nondecreasing_is_cvg => m n mn. + apply: ge0_le_integral => //. + - by move=> y' _; rewrite lee_fin. + - exact/EFin_measurable_fun/measurable_fun_prod1. + - by move=> y' _; rewrite lee_fin. + - exact/EFin_measurable_fun/measurable_fun_prod1. + - by move=> y' _; rewrite lee_fin; apply/lefP/ndk_. + rewrite -monotone_convergence//. + - by apply: eq_integral => y _; apply/esym/cvg_lim => //; exact: k_k. + - by move=> n; exact/EFin_measurable_fun/measurable_fun_prod1. + - by move=> n y' _; rewrite lee_fin. + - by move=> y' _ m n mn; rewrite lee_fin; apply/lefP/ndk_. +apply: measurable_fun_elim_sup => n. +rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \int[l x0]_y + ((\sum_(r <- fset_set (range (k_ n))) + r * \1_(k_ n @^-1` [set r]) (x0, y)))%:E)); last first. + by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. +rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \sum_(r <- fset_set (range (k_ n))) + (\int[l x0]_y + (r * \1_(k_ n @^-1` [set r]) (x0, y))%:E))); last first. + apply/funext => x; rewrite -ge0_integral_sum//. + - by apply: eq_integral => y _; rewrite sumEFin. + - move=> r. + apply/EFin_measurable_fun/measurable_funrM/measurable_fun_prod1 => /=. + by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). + - by move=> m y _; rewrite muleindic_ge0. +apply emeasurable_fun_sum => r. +rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * + \int[l x]_y (\1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. + apply/funext => x. + under eq_integral do rewrite EFinM. + rewrite (integralM_0ifneg _ _ (fun k y => (\1_(k_ n @^-1` [set r]) (x, y))%:E))//. + - by move=> _ t _; rewrite lee_fin. + - by move=> r_lt0; apply/funext => y; rewrite preimage_nnfun0// indicE in_set0. + - apply/EFin_measurable_fun/measurable_fun_prod1 => /=. + by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). +apply: measurable_funeM. +rewrite (_ : (fun x : X => \int[l x]_z (\1_(k_ n @^-1` [set r]) (x, z))%:E) = + (fun x : X => l x (xsection (k_ n @^-1` [set r]) x))); last first. + apply/funext => y. + rewrite integral_indic//; last first. + rewrite (_ : (fun x : Y => (k_ n @^-1` [set r]) (y, x)) = xsection (k_ n @^-1` [set r]) y); last first. + apply/seteqP; split. + by move=> y2/=; rewrite /xsection/= inE//. + by rewrite /xsection/= => y2/=; rewrite inE /preimage/=. + by apply: measurable_xsection. + congr (l y _). + apply/funext => y1/=. + rewrite /xsection/= inE. + by apply/propext; tauto. +have [l_ hl_] := @sfinite_kernelP _ _ _ _ _ l. +rewrite (_ : (fun x : X => _) = + (fun x : X => mseries (l_ ^~ x) 0 (xsection (k_ n @^-1` [set r]) x)) +); last first. + apply/funext => x. + rewrite hl_//. + by apply/measurable_xsection. +rewrite /mseries/=. +apply: ge0_emeasurable_fun_sum => // k1. +apply: measurable_fun_xsection_dep => //. +by have := @finite_kernelP _ _ _ _ _ (l_ k1). +move=> X2 mX2. +rewrite /mrestr. +apply/kernelP. +by rewrite setIT. +by rewrite inE. +Qed. Section star_is_sfinite_kernel. -Variables (d d' : _) (R : realType) (X : measurableType d) (Y : measurableType d') - (Z : measurableType (d, d').-prod). +Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3). Variable k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z. Variable l : sfinite_kernel R X Y. +Import STAR_IS_FINITE_KERNEL. + Lemma star_sfinite : exists k_ : (finite_kernel R X Z)^nat, forall x U, measurable U -> mstar k l x U = [the measure _ _ of mseries (k_ ^~ x) O] U. Proof. @@ -649,9 +771,8 @@ have H1 x U : measurable U -> star k l x U = star K L x U. move=> mU. rewrite /star /L /K /=. transitivity (\int[ - [the measure _ _ of mseries (fun x0 : nat => l_ x0 x) 0] -]_y k (x, y) U). - apply eq_measure_integral_new => A mA _ . + [the measure _ _ of mseries (fun x0 : nat => l_ x0 x) 0] ]_y k (x, y) U). + apply eq_measure_integral => A mA _ . by rewrite hl_. apply eq_integral => y _. by rewrite hk_//. @@ -697,13 +818,36 @@ rewrite (reindex_esum [set: nat] [set: nat * nat] f)//. by rewrite nneseries_esum// fun_true. Qed. +Lemma star_measurable_sfinite U : measurable U -> measurable_fun setT (star k l ^~ U). +Proof. +move=> mU. +rewrite /star. +apply: (@pollard_sfinite2 _ _ _ _ _ (k ^~ U)) => //. +by apply/kernelP. +Qed. + +End star_is_sfinite_kernel. + +Module STAR_IS_SFINITE_KERNEL. +Section star_is_sfinite_kernel. +Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3). +Variable k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z. +Variable l : sfinite_kernel R X Y. + HB.instance Definition _ := - isSFiniteKernel.Build d ((d, d').-prod)%mdisp R X Z (mstar k l) star_sfinite. + isKernel.Build _ _ R X Z (mstar k l) (star_measurable_sfinite k l). + +#[export] +HB.instance Definition _ := + isSFiniteKernel.Build d d3 R X Z (mstar k l) (star_sfinite k l). End star_is_sfinite_kernel. +End STAR_IS_SFINITE_KERNEL. +HB.export STAR_IS_SFINITE_KERNEL. -Lemma lemma3_indic d d' (R : realType) (X : measurableType d) - (Y : measurableType d') (Z : measurableType (d, d').-prod) +Lemma lemma3_indic d d' d3 (R : realType) (X : measurableType d) + (Y : measurableType d') (Z : measurableType d3) (k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z) (l : sfinite_kernel R X Y) x (E : set _) (mE : measurable E) : \int[mstar k l x]_z (\1_E z)%:E = \int[l x]_y (\int[k (x, y)]_z (\1_E z)%:E). @@ -712,57 +856,125 @@ rewrite integral_indic// /mstar/= /star/=. by apply eq_integral => y _; rewrite integral_indic. Qed. -Lemma lemma3_nnsfun d d' (R : realType) (X : measurableType d) - (Y : measurableType d') (Z : measurableType (d, d').-prod) +Lemma lemma3_nnsfun d d' d3 (R : realType) (X : measurableType d) + (Y : measurableType d') (Z : measurableType d3) (k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z) (l : sfinite_kernel R X Y) x (f : {nnsfun Z >-> R}) : \int[mstar k l x]_z (f z)%:E = \int[l x]_y (\int[k (x, y)]_z (f z)%:E). Proof. -under eq_integral do rewrite fimfunE -sumEFin. +under [in LHS]eq_integral do rewrite fimfunE -sumEFin. rewrite ge0_integral_sum//; last 2 first. - move=> r. - apply/EFin_measurable_fun/measurable_funrM. + move=> r; apply/EFin_measurable_fun/measurable_funrM. have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. by rewrite (_ : \1__ = mindic R fr). by move=> r z _; rewrite EFinM muleindic_ge0. -under eq_bigr. - move=> r _. - rewrite /=. - rewrite (@integralM_indic_new _ _ _ _ _ _ (fun r x0 => \1_(f @^-1` [set r]) x0))//; last 2 first. - move=> r0. - apply/funext => z/=. - by rewrite indicE memNset// preimage_nnfun0. - have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. - by rewrite (_ : \1__ = mindic R fr). - rewrite /=. - rewrite lemma3_indic//. +under [in RHS]eq_integral. + move=> y _. + under eq_integral. + move=> z _. + rewrite fimfunE -sumEFin. + over. + rewrite /= ge0_integral_sum//; last 2 first. + move=> r; apply/EFin_measurable_fun/measurable_funrM. + have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). + by move=> r z _; rewrite EFinM muleindic_ge0. + under eq_bigr. + move=> r _. + rewrite (@integralM_indic _ _ _ _ _ _ (fun r => f @^-1` [set r]))//; last first. + by move=> r0; rewrite preimage_nnfun0. + rewrite integral_indic// setIT. + over. over. -rewrite /=. -apply/esym. -Admitted. +rewrite /= ge0_integral_sum//; last 2 first. + move=> r; apply: measurable_funeM. + have := @kernelP _ _ _ _ _ k (f @^-1` [set r]) (measurable_sfunP f r). + by move/measurable_fun_prod1; exact. + move=> n y _. + have := @mulem_ge0 _ _ _ (k (x, y)) n (fun n => f @^-1` [set n]). + apply. + exact: preimage_nnfun0. +apply eq_bigr => r _. +rewrite (@integralM_indic _ _ _ _ _ _ (fun r => f @^-1` [set r]))//; last first. + exact: preimage_nnfun0. +rewrite /= lemma3_indic; last exact/measurable_sfunP. +rewrite (@integralM_0ifneg _ _ _ _ _ _ (fun r t => k (x, t) (f @^-1` [set r])))//; last 2 first. + move=> r0. + apply/funext => y. + by rewrite preimage_nnfun0// measure0. + have := @kernelP _ _ _ _ _ k (f @^-1` [set r]) (measurable_sfunP f r). + by move/measurable_fun_prod1; exact. +congr (_ * _). +apply eq_integral => y _. +by rewrite integral_indic// setIT. +Qed. -Lemma lemma3 d d' (R : realType) (X : measurableType d) - (Y : measurableType d') (Z : measurableType (d, d').-prod) +Lemma lemma3 d d' d3 (R : realType) (X : measurableType d) + (Y : measurableType d') (Z : measurableType d3) (k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z) (l : sfinite_kernel R X Y) x f : (forall z, 0 <= f z) -> measurable_fun setT f -> \int[mstar k l x]_z f z = \int[l x]_y (\int[k (x, y)]_z f z). Proof. move=> f0 mf. have [f_ [ndf_ f_f]] := approximation measurableT mf (fun z _ => f0 z). -simpl in *. -(* TODO *) -Admitted. +transitivity (\int[mstar k l x]_z (lim (EFin \o (f_^~ z)))). + apply/eq_integral => z _. + apply/esym/cvg_lim => //=. + exact: f_f. +rewrite monotone_convergence//; last 3 first. + by move=> n; apply/EFin_measurable_fun. + by move=> n z _; rewrite lee_fin. + by move=> z _ a b /ndf_ /lefP ab; rewrite lee_fin. +rewrite (_ : (fun _ => _) = (fun n => \int[l x]_y (\int[k (x, y)]_z (f_ n z)%:E)))//; last first. + by apply/funext => n; rewrite lemma3_nnsfun. +transitivity (\int[l x]_y lim (fun n => \int[k (x, y)]_z (f_ n z)%:E)). + rewrite -monotone_convergence//; last 3 first. + move=> n. + apply: pollard_sfinite => //. + - by move=> z; rewrite lee_fin. + - by apply/EFin_measurable_fun. + - move=> n y _. + by apply integral_ge0 => // z _; rewrite lee_fin. + - move=> y _ a b ab. + apply: ge0_le_integral => //. + + by move=> z _; rewrite lee_fin. + + exact/EFin_measurable_fun. + + by move=> z _; rewrite lee_fin. + + exact/EFin_measurable_fun. + + move: ab => /ndf_ /lefP ab z _. + by rewrite lee_fin. +apply eq_integral => y _. +rewrite -monotone_convergence//; last 3 first. + move=> n; exact/EFin_measurable_fun. + by move=> n z _; rewrite lee_fin. + by move=> z _ a b /ndf_ /lefP; rewrite lee_fin. +apply eq_integral => z _. +apply/cvg_lim => //. +exact: f_f. +Qed. -HB.mixin Record isProbability (d : measure_display) (T : measurableType d) - (R : realType) (P : set T -> \bar R) of isMeasure d R T P := - { probability_setT : P setT = 1%E }. +Canonical unit_pointedType := PointedType unit tt. -#[short(type=probability)] -HB.structure Definition Probability (d : measure_display) (T : measurableType d) - (R : realType) := - {P of isProbability d T R P & isMeasure d R T P }. +Section discrete_measurable_unit. + +Definition discrete_measurable_unit : set (set unit) := [set: set unit]. -Section discrete_measurable2. +Let discrete_measurable0 : discrete_measurable_unit set0. Proof. by []. Qed. + +Let discrete_measurableC X : discrete_measurable_unit X -> discrete_measurable_unit (~` X). +Proof. by []. Qed. + +Let discrete_measurableU (F : (set unit)^nat) : + (forall i, discrete_measurable_unit (F i)) -> discrete_measurable_unit (\bigcup_i F i). +Proof. by []. Qed. + +HB.instance Definition _ := @isMeasurable.Build default_measure_display unit (Pointed.class _) + discrete_measurable_unit discrete_measurable0 discrete_measurableC + discrete_measurableU. + +End discrete_measurable_unit. + +Section discrete_measurable_bool. Definition discrete_measurable_bool : set (set bool) := [set: set bool]. @@ -781,109 +993,549 @@ HB.instance Definition _ := @isMeasurable.Build default_measure_display bool (Po discrete_measurable_bool discrete_measurable0 discrete_measurableC discrete_measurableU. -End discrete_measurable2. +End discrete_measurable_bool. -Definition twoseven (R : realType) : {nonneg R}. -Admitted. +Section nonneg_constants. +Variable R : realType. +Let twoseven_proof : (0 <= 2 / 7 :> R)%R. +Proof. by rewrite divr_ge0// ler0n. Qed. -Definition fiveseven (R : realType) : {nonneg R}. -Admitted. +Definition twoseven : {nonneg R} := NngNum twoseven_proof. -Definition bernoulli (R : realType) : {measure set _ -> \bar R} := - [the measure _ _ of measure_add +Let fiveseven_proof : (0 <= 5 / 7 :> R)%R. +Proof. by rewrite divr_ge0// ler0n. Qed. + +Definition fiveseven : {nonneg R} := NngNum fiveseven_proof. + +End nonneg_constants. + +Lemma measure_diract_setT_true (R : realType) : + [the measure _ _ of dirac true] [set: bool] = 1 :> \bar R. +Proof. by rewrite /= diracE in_setT. Qed. + +Lemma measure_diract_setT_false (R : realType) : + [the measure _ _ of dirac false] [set: bool] = 1 :> \bar R. +Proof. by rewrite /= diracE in_setT. Qed. + +Section bernoulli27. +Variable R : realType. + +Definition bernoulli27 : set _ -> \bar R := + measure_add [the measure _ _ of mscale (twoseven R) [the measure _ _ of dirac true]] - [the measure _ _ of mscale (fiveseven R) [the measure _ _ of dirac false]]]. + [the measure _ _ of mscale (fiveseven R) [the measure _ _ of dirac false]]. -Canonical unit_pointedType := PointedType unit tt. +HB.instance Definition _ := Measure.on bernoulli27. -Section unit_measurable. +Lemma bernoulli27_setT : bernoulli27 [set: _] = 1. +Proof. +rewrite /bernoulli27/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. +rewrite /mscale/= !diracE !in_setT !mule1 -EFinD. +by rewrite -mulrDl -natrD divrr// unitfE pnatr_eq0. +Qed. -Definition unit_measurable : set (set unit) := [set: set unit]. +HB.instance Definition _ := @isProbability.Build _ _ R bernoulli27 bernoulli27_setT. -Let unit_measurable0 : unit_measurable set0. Proof. by []. Qed. +End bernoulli27. -Let unit_measurableC X : unit_measurable X -> unit_measurable (~` X). -Proof. by []. Qed. +Section kernel_from_mzero. +Variables (d : measure_display) (T : measurableType d) (R : realType). +Variables (d' : measure_display) (T' : measurableType d'). -Let unit_measurableU (F : (set unit)^nat) : - (forall i, unit_measurable (F i)) -> unit_measurable (\bigcup_i F i). -Proof. by []. Qed. +Definition kernel_from_mzero : T' -> {measure set T -> \bar R} := + fun _ : T' => [the measure _ _ of mzero]. -HB.instance Definition _ := @isMeasurable.Build default_measure_display unit (Pointed.class _) - unit_measurable unit_measurable0 unit_measurableC - unit_measurableU. +Lemma kernel_from_mzeroP : forall U, measurable U -> + measurable_fun setT (kernel_from_mzero ^~ U). +Proof. by move=> U mU/=; exact: measurable_fun_cst. Qed. + +HB.instance Definition _ := + @isKernel.Build d' d R T' T kernel_from_mzero + kernel_from_mzeroP. -End unit_measurable. +Lemma kernel_from_mzero_uub : kernel_uub kernel_from_mzero. +Proof. +exists (PosNum ltr01) => /= t. +by rewrite /mzero/=. +Qed. + +HB.instance Definition _ := + @isFiniteKernel.Build d' d R _ T kernel_from_mzero + kernel_from_mzero_uub. + +End kernel_from_mzero. + +(* a finite kernel is always an s-finite kernel *) +Lemma finite_kernel_sfinite_kernelP (d : measure_display) + (R : realType) (X : measurableType d) (d' : measure_display) (T : measurableType d') + (k : finite_kernel R T X) : + exists k_ : (finite_kernel R _ _)^nat, forall x U, measurable U -> + k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. +exists (fun n => if n is O then + k + else + [the finite_kernel _ _ _ of @kernel_from_mzero _ X R _ T] + ). +move=> t U mU/=. +rewrite /mseries. +rewrite (nneseries_split 1%N)// big_ord_recl/= big_ord0 adde0. +rewrite ereal_series (@eq_nneseries _ _ (fun=> 0%E)); last first. + by case. +by rewrite nneseries0// adde0. +Qed. (* semantics for a sample operation? *) -Section kernel_from_measure. +Section kernel_probability. Variables (d : measure_display) (R : realType) (X : measurableType d). -Variable m : {measure set X -> \bar R}. (* measure, probability measure *) +Variables (d' : _) (T' : measurableType d'). +Variable m : probability X R. -Definition kernel_from_measure : unit -> {measure set X -> \bar R} := - fun _ : unit => m. +Definition kernel_probability : T' -> {measure set X -> \bar R} := + fun _ : T' => m. -Lemma kernel_from_measureP : forall U, measurable U -> measurable_fun setT (kernel_from_measure ^~ U). -Proof. by []. Qed. +Lemma kernel_probabilityP : forall U, measurable U -> + measurable_fun setT (kernel_probability ^~ U). +Proof. +move=> U mU. +rewrite /kernel_probability. +exact: measurable_fun_cst. +Qed. + +HB.instance Definition _ := + @isKernel.Build _ d R _ X kernel_probability + kernel_probabilityP. + +Lemma kernel_probability_uub : kernel_uub kernel_probability. +Proof. +(*NB: shouldn't this work? exists 2%:pos. *) +exists (PosNum (addr_gt0 ltr01 ltr01)) => /= ?. +rewrite (le_lt_trans (probability_le1 m measurableT))//. +by rewrite lte_fin ltr_addr. +Qed. + +HB.instance Definition _ := + @isFiniteKernel.Build _ d R _ X kernel_probability + kernel_probability_uub. + +Lemma kernel_probability_sfinite_kernelP : exists k_ : (finite_kernel R _ _)^nat, + forall x U, measurable U -> + kernel_probability x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. exact: finite_kernel_sfinite_kernelP. Qed. HB.instance Definition _ := - @isKernel.Build default_measure_display d R _ X kernel_from_measure - kernel_from_measureP. -End kernel_from_measure. + @isSFiniteKernel.Build _ d R _ X kernel_probability + kernel_probability_sfinite_kernelP. + +End kernel_probability. (* semantics for return? *) -Section kernel_from_dirac. +Section kernel_dirac. Variables (R : realType) (d : _) (T : measurableType d). -Definition kernel_from_dirac : T -> {measure set T -> \bar R} := +Definition kernel_dirac : T -> {measure set T -> \bar R} := fun x => [the measure _ _ of dirac x]. -Lemma kernel_from_diracP : forall U, measurable U -> measurable_fun setT (kernel_from_dirac ^~ U). +Lemma kernel_diracP U : measurable U -> measurable_fun setT (kernel_dirac ^~ U). Proof. -move=> U mU. -rewrite /kernel_from_dirac. -rewrite /=. -rewrite /dirac/=. -apply/EFin_measurable_fun. -rewrite [X in measurable_fun _ X](_ : _ = mindic R mU)//. +move=> mU; apply/EFin_measurable_fun. +by rewrite [X in measurable_fun _ X](_ : _ = mindic R mU). +Qed. + +HB.instance Definition _ := isKernel.Build _ _ R _ _ kernel_dirac kernel_diracP. + +Lemma kernel_dirac_uub : kernel_uub kernel_dirac. +Proof. +exists (PosNum (addr_gt0 ltr01 ltr01)) => t/=. +by rewrite diracE in_setT lte_fin ltr_addr. Qed. HB.instance Definition _ := - isKernel.Build _ _ R _ _ kernel_from_dirac kernel_from_diracP. -End kernel_from_dirac. + @isFiniteKernel.Build d d R _ T kernel_dirac kernel_dirac_uub. -(* let x = sample (bernoulli 2/7) in - return x *) +Lemma kernel_dirac_sfinite_kernelP : exists k_ : (finite_kernel R _ _)^nat, + forall x U, measurable U -> + kernel_dirac x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. exact: finite_kernel_sfinite_kernelP. Qed. + +HB.instance Definition _ := + @isSFiniteKernel.Build d d R T T kernel_dirac kernel_dirac_sfinite_kernelP. + +End kernel_dirac. + +Section kernel_dirac2. +Variables (R : realType) (d d' : _) (T : measurableType d) (T' : measurableType d'). +Variable (f : T -> T'). + +Definition kernel_dirac2 (mf : measurable_fun setT f) : T -> {measure set T' -> \bar R} := + fun x => [the measure _ _ of dirac (f x)]. + +Variable (mf : measurable_fun setT f). + +Lemma kernel_dirac2P U : measurable U -> measurable_fun setT (kernel_dirac2 mf ^~ U). +Proof. +move=> mU; apply/EFin_measurable_fun. +have mTU : measurable (f @^-1` U). + have := mf measurableT mU. + by rewrite setTI. +by rewrite [X in measurable_fun _ X](_ : _ = mindic R mTU). +Qed. + +HB.instance Definition _ := + isKernel.Build _ _ R _ _ (kernel_dirac2 mf) kernel_dirac2P. + +Lemma kernel_dirac2_uub : kernel_uub (kernel_dirac2 mf). +Proof. +exists (PosNum (addr_gt0 ltr01 ltr01)) => t/=. +by rewrite diracE in_setT lte_fin ltr_addr. +Qed. + +HB.instance Definition _ := + @isFiniteKernel.Build _ _ R _ _ (kernel_dirac2 mf) kernel_dirac2_uub. + +Lemma kernel_dirac2_sfinite_kernelP : exists k_ : (finite_kernel R _ _)^nat, + forall x U, measurable U -> + kernel_dirac2 mf x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. exact: finite_kernel_sfinite_kernelP. Qed. + +HB.instance Definition _ := + @isSFiniteKernel.Build _ _ R _ _ (kernel_dirac2 mf) kernel_dirac2_sfinite_kernelP. + +End kernel_dirac2. Definition letin (d d' d3 : measure_display) (R : realType) (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) - (l : X ^^> Y) (k : _ ^^> Z) : X -> {measure set Z -> \bar R}:= - @mstar _ _ _ R _ _ _ k l. + (l : sfinite_kernel R X Y) + (k : sfinite_kernel R [the measurableType (d, d').-prod of (X * Y)%type] Z) + : sfinite_kernel R X Z := + [the sfinite_kernel _ _ _ of @mstar d d' d3 R X Y Z k l]. -Section sample_program. +(* semantics for score? *) + +Lemma set_unit (A : set unit) : A = set0 \/ A = setT. +Proof. +have [->|/set0P[[] Att]] := eqVneq A set0; [by left|right]. +by apply/seteqP; split => [|] []. +Qed. + +Section score_measure. +Variables (R : realType). + +Definition mscore (r : R) (U : set unit) : \bar R := if U == set0 then 0 else `| r%:E |. + +Lemma mscore0 r : mscore r (set0 : set unit) = 0 :> \bar R. +Proof. by rewrite /mscore eqxx. Qed. + +Lemma mscore_ge0 r U : 0 <= mscore r U. +Proof. by rewrite /mscore; case: ifP. Qed. + +Lemma mscore_sigma_additive r : semi_sigma_additive (mscore r). +Proof. +move=> /= F mF tF mUF; rewrite /mscore; case: ifPn => [/eqP/bigcup0P F0|]. + rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. + apply/funext => k. + under eq_bigr do rewrite F0// eqxx. + by rewrite big1. +move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. +rewrite -(cvg_shiftn k.+1)/=. +rewrite (_ : (fun _ => _) = cst `|r%:E|); first exact: cvg_cst. +apply/funext => n. +rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. +rewrite (negbTE Fk0) big1 ?adde0// => i/= ik; rewrite ifT//. +have [/eqP//|Fitt] := set_unit (F i). +move/trivIsetP : tF => /(_ i k Logic.I Logic.I ik). +by rewrite Fitt setTI => /eqP; rewrite (negbTE Fk0). +Qed. + +HB.instance Definition _ (r : R) := isMeasure.Build _ _ _ + (mscore r) (mscore0 r) (mscore_ge0 r) (@mscore_sigma_additive r). + +End score_measure. + +(* NB: score r = observe 0 from exp r, + the density of the exponential distribution exp(r) at 0 is r = r e^(-r * 0) + more generally, score (r e^(-r * t)) = observe t from exp(r), + score (f(r)) = observe r from p where f is the density of p + +*) + +Module KERNEL_SCORE. +Section kernel_score. +Variable (R : realType) (d : _) (T : measurableType d). + +Definition k_' (r : R) (i : nat) : T -> set unit -> \bar R := + fun _ U => + if i%:R%:E <= mscore r U < i.+1%:R%:E then + mscore r U + else + 0. + +Lemma k_'0 (r : R) i (t : T) : k_' r i t (set0 : set unit) = 0 :> \bar R. +Proof. by rewrite /k_' measure0; case: ifP. Qed. + +Lemma k_'ge0 (r : R) i (t : T) B : 0 <= k_' r i t B. +Proof. by rewrite /k_'; case: ifP. Qed. + +Lemma k_'sigma_additive (r : R) i (t : T) : semi_sigma_additive (k_' r i t). +Proof. +move=> /= F mF tF mUF. +rewrite /k_' /=. +have [F0|] := eqVneq (\bigcup_n F n) set0. + rewrite [in X in _ --> X]/mscore F0 eqxx. + rewrite (_ : (fun _ => _) = cst 0). + by case: ifPn => _; exact: cvg_cst. + apply/funext => k; rewrite big1// => n _. + move : F0 => /bigcup0P F0. + by rewrite /mscore F0// eqxx; case: ifP. +move=> UF0; move: (UF0). +move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. +rewrite [in X in _ --> X]/mscore (negbTE UF0). +rewrite -(cvg_shiftn k.+1)/=. +case: ifPn => ir. + rewrite (_ : (fun _ => _) = cst `|r%:E|); first exact: cvg_cst. + apply/funext => n. + rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. + rewrite [in X in X + _]/mscore (negbTE Fk0) ir big1 ?adde0// => /= j jk. + rewrite /mscore. + have /eqP Fj0 : F j == set0. + have [/eqP//|Fjtt] := set_unit (F j). + move/trivIsetP : tF => /(_ j k Logic.I Logic.I jk). + by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fk0). + rewrite Fj0 eqxx. + by case: ifP. +rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. +apply/funext => n. +rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. +rewrite [in X in if X then _ else _]/mscore (negbTE Fk0) (negbTE ir) add0e. +rewrite big1//= => j jk. +rewrite /mscore. +have /eqP Fj0 : F j == set0. + have [/eqP//|Fjtt] := set_unit (F j). + move/trivIsetP : tF => /(_ j k Logic.I Logic.I jk). + by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fk0). +rewrite Fj0 eqxx. +by case: ifP. +Qed. + +HB.instance Definition _ (r : R) (i : nat) (t : T) := isMeasure.Build _ _ _ + (k_' r i t) (k_'0 r i t) (k_'ge0 r i t) (@k_'sigma_additive r i t). + +Lemma k_kernelP (r : R) (i : nat) : forall U, measurable U -> measurable_fun setT (k_' r i ^~ U). +Proof. +move=> /= U mU. +rewrite /k_'. +by case: ifPn => _; exact: measurable_fun_cst. +Qed. + +Definition mk_' (r : R) i (t : T) := [the measure _ _ of k_' r i t]. + +HB.instance Definition _ (r : R) (i : nat) := + isKernel.Build _ _ R _ _ (mk_' r i) (k_kernelP r i). + +Lemma k_uub (r : R) (i : nat) : kernel_uub (mk_' r i). +Proof. +exists (PosNum (ltr0Sn _ i)) => /= t. +rewrite /k_' /mscore setT_unit. +rewrite (_ : [set tt] == set0 = false); last first. + by apply/eqP => /seteqP[] /(_ tt) /(_ erefl). +by case: ifPn => // /andP[]. +Qed. + +HB.instance Definition _ (r : R) (i : nat) := + @isFiniteKernel.Build _ _ R _ _ (mk_' r i) (k_uub r i). + +End kernel_score. +End KERNEL_SCORE. + +Section kernel_score_kernel. +Variables (R : realType) (d : _) (T : measurableType d). + +Definition kernel_score (r : R) : T -> {measure set _ -> \bar R} := + fun _ : T => [the measure _ _ of mscore r]. + +Lemma kernel_scoreP (r : R) : forall U, measurable U -> + measurable_fun setT (kernel_score r ^~ U). +Proof. +move=> /= U mU; rewrite /mscore; case: ifP => U0. + exact: measurable_fun_cst. +apply: measurable_fun_comp => //. +apply/EFin_measurable_fun. +exact: measurable_fun_cst. +Qed. + +HB.instance Definition _ (r : R) := + isKernel.Build _ _ R T + _ (*Datatypes_unit__canonical__measure_Measurable*) + (kernel_score r) (kernel_scoreP r). +End kernel_score_kernel. + +Section kernel_score_sfinite_kernel. +Variables (R : realType) (d : _) (T : measurableType d). + +Import KERNEL_SCORE. + +Lemma kernel_score_sfinite_kernelP (r : R) : exists k_ : (finite_kernel R T _)^nat, + forall x U, measurable U -> + kernel_score r x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. +exists (fun i => [the finite_kernel _ _ _ of mk_' r i]) => /= r' U mU. +rewrite /mseries /mscore; case: ifPn => [/eqP U0|U0]. + by apply/esym/nneseries0 => i _; rewrite U0 measure0. +rewrite /mk_' /= /k_' /= /mscore (negbTE U0). +apply/esym/cvg_lim => //. +rewrite -(cvg_shiftn `|floor (fine `|r%:E|)|%N.+1)/=. +rewrite (_ : (fun _ => _) = cst `|r%:E|); first exact: cvg_cst. +apply/funext => n. +pose floor_r := widen_ord (leq_addl n `|floor `|r| |.+1) (Ordinal (ltnSn `|floor `|r| |)). +rewrite big_mkord (bigD1 floor_r)//= ifT; last first. + rewrite lee_fin lte_fin; apply/andP; split. + by rewrite natr_absz (@ger0_norm _ (floor `|r|)) ?floor_ge0 ?floor_le. + by rewrite -addn1 natrD natr_absz (@ger0_norm _ (floor `|r|)) ?floor_ge0 ?lt_succ_floor. +rewrite big1 ?adde0//= => j jk. +rewrite ifF// lte_fin lee_fin. +move: jk; rewrite neq_ltn/= => /orP[|] jr. +- suff : (j.+1%:R <= `|r|)%R by rewrite leNgt => /negbTE ->; rewrite andbF. + rewrite (_ : j.+1%:R = j.+1%:~R)// floor_ge_int. + move: jr; rewrite -lez_nat => /le_trans; apply. + by rewrite -[leRHS](@ger0_norm _ (floor `|r|)) ?floor_ge0. +- suff : (`|r| < j%:R)%R by rewrite ltNge => /negbTE ->. + move: jr; rewrite -ltz_nat -(@ltr_int R) (@gez0_abs (floor `|r|)) ?floor_ge0// ltr_int. + by rewrite -floor_lt_int. +Qed. + +HB.instance Definition _ (r : R) := @isSFiniteKernel.Build _ _ _ _ _ + (kernel_score r) (kernel_score_sfinite_kernelP r). + +End kernel_score_sfinite_kernel. + +Section ite. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables + (u1 : sfinite_kernel R + [the measurableType _ of (T * bool)%type] + [the measurableType _ of T']) + (u2 : sfinite_kernel R + [the measurableType _ of (T * bool)%type] + [the measurableType _ of T']). + +Definition ite : T * bool -> set _ -> \bar R := + fun t => if t.2 then u1 t else u2 t. + +Lemma ite0 tb : ite tb set0 = 0. +Proof. by rewrite /ite; case: ifPn => //. Qed. + +Lemma ite_ge0 tb (U : set _) : 0 <= ite tb U. +Proof. by rewrite /ite; case: ifPn => //. Qed. + +Lemma ite_sigma_additive tb : semi_sigma_additive (ite tb). +Proof. +Admitted. + +HB.instance Definition _ tb := isMeasure.Build _ _ _ + (ite tb) + (ite0 tb) (ite_ge0 tb) (@ite_sigma_additive tb). + +Lemma ite_kernelP : forall U, measurable U -> measurable_fun setT (ite ^~ U). +Admitted. + +Definition mite tb := [the measure _ _ of ite tb]. + +HB.instance Definition _ := isKernel.Build _ _ R _ _ mite ite_kernelP. + +Lemma ite_sfinite_kernelP : exists k_ : (finite_kernel R _ _)^nat, + forall x U, measurable U -> + ite x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Admitted. + +HB.instance Definition _ := + @isSFiniteKernel.Build _ _ _ _ _ mite ite_sfinite_kernelP. + +End ite. + +Section insn. Variables (R : realType). -Definition sample_bernoulli27 (*NB: 1 ^^> bool *) := - [the kernel _ _ _ of kernel_from_measure (bernoulli R)] . +Definition sample_bernoulli27 (d : _) (T : measurableType d) := + [the sfinite_kernel _ T _ of + kernel_probability [the probability _ _ of bernoulli27 R]] . + +Definition Ite (d d' : _) (T : measurableType d) (T' : measurableType d') + (u1 : sfinite_kernel R [the measurableType _ of (T * bool)%type] + [the measurableType _ of T']) + (u2 : sfinite_kernel R [the measurableType _ of (T * bool)%type] + [the measurableType _ of T']) + : sfinite_kernel R [the measurableType _ of (T * bool)%type] _ := + [the sfinite_kernel R _ _ of mite u1 u2]. -Definition Return : kernel R _ [the measurableType (default_measure_display,default_measure_display).-prod of (Datatypes_unit__canonical__measure_SemiRingOfSets * Datatypes_bool__canonical__measure_SemiRingOfSets)%type] (* NB: 1 * bool ^^> 1 * bool *) := - [the kernel _ _ _ of @kernel_from_dirac R _ _]. +Definition Return (d : _) (T : measurableType d) : sfinite_kernel R T T := + [the sfinite_kernel _ _ _ of @kernel_dirac R _ _]. -Definition program : unit -> set (unit * bool) -> \bar R (* NB: 1 ^^> 1 * bool *) := +Definition Return2 (d d' : _) (T : measurableType d) (T' : measurableType d') + (f : T -> T') (mf : measurable_fun setT f) : sfinite_kernel R T T' := + [the sfinite_kernel _ _ _ of @kernel_dirac2 R _ _ T T' f mf]. + +Definition Score (d : _) (T : measurableType d) (r : R) : + sfinite_kernel R T Datatypes_unit__canonical__measure_Measurable := + [the sfinite_kernel R _ _ of @kernel_score R _ _ r]. + +End insn. + +Section program1. +Variables (R : realType) (d : _) (T : measurableType d). + +Lemma measurable_fun_snd : measurable_fun setT (snd : T * bool -> bool). Admitted. + +Definition program1 : sfinite_kernel R T + _ := letin - sample_bernoulli27 - Return. + (sample_bernoulli27 R T) (* T -> B *) + (Return2 R measurable_fun_snd) (* T * B -> B *). -Lemma programE : forall U, program tt U = - ((twoseven R)%:num)%:E * \d_(tt, true) U + - ((fiveseven R)%:num)%:E * \d_(tt, false) U. +Lemma program1E (t : T) (U : _) : program1 t U = + ((twoseven R)%:num)%:E * \d_true U + + ((fiveseven R)%:num)%:E * \d_false U. Proof. -move=> U. -rewrite /program/= /star/=. +rewrite /program1/= /star/=. rewrite ge0_integral_measure_sum// 2!big_ord_recl/= big_ord0 adde0/=. rewrite !ge0_integral_mscale//=. rewrite !integral_dirac//=. by rewrite indicE in_setT mul1e indicE in_setT mul1e. Qed. -End sample_program. +End program1. + +Section program2. +Variables (R : realType) (d : _) (T : measurableType d). + +Definition program2 : sfinite_kernel R T Datatypes_unit__canonical__measure_Measurable := + letin + (sample_bernoulli27 R T) (* T -> B *) + (Score _ (1%:R : R)). + +End program2. + +Section program3. +Variables (R : realType) (d : _) (T : measurableType d). + +(* let x = sample (bernoulli (2/7)) in + let r = case x of {(1, _) => return (k3()), (2, _) => return (k10())} in + let _ = score (1/4! r^4 e^-r) in + return x *) + +Definition k3' : T * bool -> R := cst 3. +Definition k10' : T * bool -> R := cst 10. + +Lemma mk3 : measurable_fun setT k3'. +exact: measurable_fun_cst. +Qed. + +Lemma mk10 : measurable_fun setT k10'. +exact: measurable_fun_cst. +Qed. + +Definition program10 : sfinite_kernel R T _ := + letin + (sample_bernoulli27 R T) (* T -> B *) + (Return2 R mk3). + +End program3. From c93592ce06ad70fe40d704627045d1fe02bb3329 Mon Sep 17 00:00:00 2001 From: saito ayumu Date: Mon, 8 Aug 2022 12:05:23 +0900 Subject: [PATCH 08/54] nonneg 2/7 --- theories/kernel.v | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 1e1abeb33c..34f48e4c1d 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -997,15 +997,20 @@ End discrete_measurable_bool. Section nonneg_constants. Variable R : realType. +(* Let twoseven_proof : (0 <= 2 / 7 :> R)%R. Proof. by rewrite divr_ge0// ler0n. Qed. +*) -Definition twoseven : {nonneg R} := NngNum twoseven_proof. +(* Check (2%:R / 7%:R)%:nng. *) +(* Definition twoseven : {nonneg R} := (2%:R / 7%:R)%:nng. *) +(* Let fiveseven_proof : (0 <= 5 / 7 :> R)%R. Proof. by rewrite divr_ge0// ler0n. Qed. Definition fiveseven : {nonneg R} := NngNum fiveseven_proof. + *) End nonneg_constants. @@ -1020,13 +1025,20 @@ Proof. by rewrite /= diracE in_setT. Qed. Section bernoulli27. Variable R : realType. +Local Open Scope ring_scope. +Notation "'2/7'" := (2%:R / 7%:R)%:nng. +Definition twoseven : {nonneg R} := (2%:R / 7%:R)%:nng. +Definition fiveseven : {nonneg R} := (5%:R / 7%:R)%:nng. + Definition bernoulli27 : set _ -> \bar R := measure_add - [the measure _ _ of mscale (twoseven R) [the measure _ _ of dirac true]] - [the measure _ _ of mscale (fiveseven R) [the measure _ _ of dirac false]]. + [the measure _ _ of mscale twoseven [the measure _ _ of dirac true]] + [the measure _ _ of mscale fiveseven [the measure _ _ of dirac false]]. HB.instance Definition _ := Measure.on bernoulli27. +Local Close Scope ring_scope. + Lemma bernoulli27_setT : bernoulli27 [set: _] = 1. Proof. rewrite /bernoulli27/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. @@ -1522,8 +1534,8 @@ Variables (R : realType) (d : _) (T : measurableType d). let _ = score (1/4! r^4 e^-r) in return x *) -Definition k3' : T * bool -> R := cst 3. -Definition k10' : T * bool -> R := cst 10. +Definition k3' : T * bool -> R := cst 3%:R. +Definition k10' : T * bool -> R := cst 10%:R. Lemma mk3 : measurable_fun setT k3'. exact: measurable_fun_cst. From a001c2c2a3a18fa719f594bff29074b13ca7505a Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Mon, 8 Aug 2022 17:31:23 +0900 Subject: [PATCH 09/54] s-finite kernels for ite and examples - some rewriting laws for programs --- _CoqProject | 2 + theories/kernel.v | 1730 +++++++++++++++++----------------- theories/lebesgue_integral.v | 8 +- theories/prob_lang.v | 357 +++++++ 4 files changed, 1219 insertions(+), 878 deletions(-) create mode 100644 theories/prob_lang.v diff --git a/_CoqProject b/_CoqProject index 1a9dd0cdc9..b92567752e 100644 --- a/_CoqProject +++ b/_CoqProject @@ -36,6 +36,8 @@ theories/derive.v theories/measure.v theories/numfun.v theories/lebesgue_integral.v +theories/kernel.v +theories/prob_lang.v theories/summability.v theories/signed.v theories/altreals/xfinmap.v diff --git a/theories/kernel.v b/theories/kernel.v index 34f48e4c1d..1ea424ee32 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -5,6 +5,20 @@ Require Import mathcomp_extra boolp classical_sets signed functions cardinality. Require Import reals ereal topology normedtype sequences esum measure. Require Import lebesgue_measure fsbigop numfun lebesgue_integral. +(******************************************************************************) +(* Kernels *) +(* *) +(* R.-ker X ~> Y == kernel *) +(* R.-fker X ~> Y == finite kernel *) +(* R.-sfker X ~> Y == s-finite kernel *) +(* sum_of_kernels == *) +(* l \; k == composition of kernels *) +(* kernel_mfun == kernel defined by a measurable function *) +(* mscore == *) +(* ite_true/ite_false == *) +(* add_of_kernels == *) +(******************************************************************************) + Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -35,147 +49,14 @@ Admitted. End probability_lemmas. (* /PR 516 in progress *) -HB.mixin Record isKernel (d d' : measure_display) - (R : realType) (X : measurableType d) (Y : measurableType d') - (k : X -> {measure set Y -> \bar R}) := { - kernelP : forall U, measurable U -> measurable_fun setT (k ^~ U) -}. - -#[short(type=kernel)] -HB.structure Definition Kernel (d d' : measure_display) - (R : realType) (X : measurableType d) (Y : measurableType d') := - {k & isKernel d d' R X Y k}. -Notation "X ^^> Y" := (kernel _ X Y) (at level 42). - -(* TODO: define using the probability type *) -HB.mixin Record isProbabilityKernel (d d' : measure_display) - (R : realType) (X : measurableType d) (Y : measurableType d') - (k : X -> {measure set Y -> \bar R}) - of isKernel d d' R X Y k := { - prob_kernelP : forall x : X, k x [set: Y] = 1 -}. - -#[short(type=probability_kernel)] -HB.structure Definition ProbabilityKernel (d d' : measure_display) - (R : realType) (X : measurableType d) (Y : measurableType d') := - {k of isProbabilityKernel d d' R X Y k & isKernel d d' R X Y k}. - -Section sum_of_kernels. -Variables (d d' : measure_display) (R : realType). -Variables (X : measurableType d) (Y : measurableType d'). -Variable k : (kernel R X Y)^nat. - -Definition sum_of_kernels : X -> {measure set Y -> \bar R} := - fun x => [the measure _ _ of mseries (k ^~ x) 0]. - -Lemma kernel_measurable_fun_sum_of_kernels (U : set Y) : - measurable U -> - measurable_fun setT (sum_of_kernels ^~ U). -Proof. -move=> mU; rewrite /sum_of_kernels /= /mseries. -rewrite [X in measurable_fun _ X](_ : _ = - (fun x => elim_sup (fun n => \sum_(0 <= i < n) k i x U))); last first. - apply/funext => x; rewrite -lim_mkord is_cvg_elim_supE. - by rewrite -lim_mkord. - exact: is_cvg_nneseries. -apply: measurable_fun_elim_sup => n. -by apply: emeasurable_fun_sum => *; exact/kernelP. -Qed. - -HB.instance Definition _ := - isKernel.Build d d' R X Y sum_of_kernels - kernel_measurable_fun_sum_of_kernels. - -End sum_of_kernels. - -Lemma integral_sum_of_kernels (d d' : measure_display) - (R : realType) (X : measurableType d) (Y : measurableType d') - (k : (X ^^> Y)^nat) (f : Y -> \bar R) x : - (forall y, 0 <= f y) -> - measurable_fun setT f -> - \int[sum_of_kernels k x]_y (f y) = \sum_(i f0 mf; rewrite /sum_of_kernels/= ge0_integral_measure_series. -Qed. - -Section kernel_uub. -Variables (d d' : measure_display) (R : numFieldType) (X : measurableType d) - (Y : measurableType d') (k : X -> set Y -> \bar R). - -Definition kernel_uub := exists r : {posnum R}, forall x, k x [set: Y] < r%:num%:E. - -End kernel_uub. - -HB.mixin Record isFiniteKernel (d d' : measure_display) - (R : realType) (X : measurableType d) (Y : measurableType d') - (k : X -> {measure set Y -> \bar R}) - := { finite_kernelP : kernel_uub k }. - -#[short(type=finite_kernel)] -HB.structure Definition FiniteKernel (d d' : measure_display) - (R : realType) (X : measurableType d) (Y : measurableType d') := - {k of isFiniteKernel d d' R X Y k & isKernel d d' R X Y k}. - -HB.mixin Record isSFiniteKernel (d d' : measure_display) - (R : realType) (X : measurableType d) (Y : measurableType d') - (k : X -> {measure set Y -> \bar R}) - := { - sfinite_kernelP : exists k_ : (finite_kernel R X Y)^nat, - forall x U, measurable U -> - k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U -}. - -#[short(type=sfinite_kernel)] -HB.structure Definition SFiniteKernel (d d' : measure_display) - (R : realType) (X : measurableType d) (Y : measurableType d') := - {k of isSFiniteKernel d d' R X Y k & - isKernel d d' R X Y k}. - -Section star_is_measure. -Variables (d1 d2 d3 : _) (R : realType) (X : measurableType d1) - (Y : measurableType d2) (Z : measurableType d3). -Variable k : kernel R [the measurableType _ of (X * Y)%type] Z. -Variable l : kernel R X Y. - -Definition star : X -> set Z -> \bar R := fun x U => \int[l x]_y k (x, y) U. - -Let star0 x : star x set0 = 0. -Proof. -by rewrite /star (eq_integral (cst 0)) ?integral0// => y _; rewrite measure0. -Qed. - -Let star_ge0 x U : 0 <= star x U. -Proof. by apply: integral_ge0 => y _; exact: measure_ge0. Qed. - -Let star_sigma_additive x : semi_sigma_additive (star x). -Proof. -move=> U mU tU mUU; rewrite [X in _ --> X](_ : _ = - \int[l x]_y (\sum_(n V _. - by apply/esym/cvg_lim => //; exact/measure_semi_sigma_additive. -apply/cvg_closeP; split. - by apply: is_cvg_nneseries => n _; exact: integral_ge0. -rewrite closeE// integral_sum// => n. -have := @kernelP _ _ R _ _ k (U n) (mU n). -exact/measurable_fun_prod1. -Qed. - -HB.instance Definition _ x := isMeasure.Build _ R _ - (star x) (star0 x) (star_ge0 x) (@star_sigma_additive x). - -Definition mstar : X -> {measure set Z -> \bar R} := - fun x => [the measure _ _ of star x]. - -End star_is_measure. - -(* TODO: PR *) +(* TODO: PR? *) Section integralM_0ifneg. Local Open Scope ereal_scope. -Variables (d : measure_display) (T : measurableType d) (R : realType). +Variables (d : _) (T : measurableType d) (R : realType). Variables (m : {measure set T -> \bar R}) (D : set T) (mD : measurable D). Lemma integralM_0ifneg (f : R -> T -> \bar R) (k : R) - (f0 : forall r t, D t -> (0 <= f r t)) : + (f0 : forall r t, D t -> 0 <= f r t) : ((k < 0)%R -> f k = cst 0%E) -> measurable_fun setT (f k) -> \int[m]_(x in D) (k%:E * (f k) x) = k%:E * \int[m]_(x in D) ((f k) x). Proof. @@ -192,30 +73,6 @@ Qed. End integralM_0ifneg. Arguments integralM_0ifneg {d T R} m {D} mD f. -(*Section integralM_0ifneg. -Local Open Scope ereal_scope. -Variables (d : measure_display) (T : measurableType d) (R : realType). -Variables (m : {measure set T -> \bar R}) (D : set T) (mD : measurable D). - -Lemma integralM_0ifneg (f : R -> T -> R) (k : R) - (f0 : forall r t, D t -> (0 <= f r t)%R) : - ((k < 0)%R -> f k = cst 0%R) -> measurable_fun setT (f k) -> - \int[m]_(x in D) (k * (f k) x)%:E = k%:E * \int[m]_(x in D) ((f k) x)%:E. -Proof. -move=> fk0 mfk; have [k0|k0] := ltP k 0%R. - rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0; last first. - by move=> x _; rewrite fk0// mulr0. - rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0// => x _. - by rewrite fk0// indic0. -under eq_integral do rewrite EFinM. -rewrite ge0_integralM//. -- apply/EFin_measurable_fun/(@measurable_funS _ _ _ _ setT) => //. -- by move=> y Dy; rewrite lee_fin f0. -Qed. - -End integralM_0ifneg. -Arguments integralM_0ifneg {d T R} m {D} mD f.*) - Section integralM_indic. Local Open Scope ereal_scope. Variables (d : measure_display) (T : measurableType d) (R : realType). @@ -331,49 +188,276 @@ Qed. End integral_mscale. -Section ndseq_closed_B. -Variables (d1 d2 : measure_display). -Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). -Implicit Types A : set (T1 * T2). +(* TODO: PR *) +Canonical unit_pointedType := PointedType unit tt. -Section xsection. -Variables (pt2 : T2) (m2 : T1 -> {measure set T2 -> \bar R}). -Let phi A x := m2 x (xsection A x). -Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. +Section discrete_measurable_unit. + +Definition discrete_measurable_unit : set (set unit) := [set: set unit]. + +Let discrete_measurable0 : discrete_measurable_unit set0. Proof. by []. Qed. + +Let discrete_measurableC X : discrete_measurable_unit X -> discrete_measurable_unit (~` X). +Proof. by []. Qed. + +Let discrete_measurableU (F : (set unit)^nat) : + (forall i, discrete_measurable_unit (F i)) -> discrete_measurable_unit (\bigcup_i F i). +Proof. by []. Qed. + +HB.instance Definition _ := @isMeasurable.Build default_measure_display unit (Pointed.class _) + discrete_measurable_unit discrete_measurable0 discrete_measurableC + discrete_measurableU. + +End discrete_measurable_unit. + +Section discrete_measurable_bool. + +Definition discrete_measurable_bool : set (set bool) := [set: set bool]. + +Let discrete_measurable0 : discrete_measurable_bool set0. Proof. by []. Qed. + +Let discrete_measurableC X : + discrete_measurable_bool X -> discrete_measurable_bool (~` X). +Proof. by []. Qed. + +Let discrete_measurableU (F : (set bool)^nat) : + (forall i, discrete_measurable_bool (F i)) -> + discrete_measurable_bool (\bigcup_i F i). +Proof. by []. Qed. + +HB.instance Definition _ := @isMeasurable.Build default_measure_display bool (Pointed.class _) + discrete_measurable_bool discrete_measurable0 discrete_measurableC + discrete_measurableU. + +End discrete_measurable_bool. + +Lemma measurable_fun_fst (d1 d2 : _) (T1 : measurableType d1) + (T2 : measurableType d2) : measurable_fun setT (@fst T1 T2). +Proof. +have := @measurable_fun_id _ [the measurableType _ of (T1 * T2)%type] setT. +by move=> /prod_measurable_funP[]. +Qed. + +Lemma measurable_fun_snd (d1 d2 : _) (T1 : measurableType d1) + (T2 : measurableType d2) : measurable_fun setT (@snd T1 T2). +Proof. +have := @measurable_fun_id _ [the measurableType _ of (T1 * T2)%type] setT. +by move=> /prod_measurable_funP[]. +Qed. + +Lemma measurable_uncurry (T1 T2 : Type) (d : _) (T : semiRingOfSetsType d) + (G : T1 -> T2 -> set T) (x : T1 * T2) : + measurable (G x.1 x.2) <-> measurable (uncurry G x). +Proof. by case: x. Qed. + +Lemma measurable_curry (T1 T2 : Type) (d : _) (T : semiRingOfSetsType d) + (G : T1 * T2 -> set T) (x : T1 * T2) : + measurable (G x) <-> measurable (curry G x.1 x.2). +Proof. by case: x. Qed. + +Lemma measurable_fun_if (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') : + measurable_fun setT x -> + measurable_fun setT y -> + measurable_fun setT (fun b : T * bool => if b.2 then x b.1 else y b.1). +Proof. +move=> mx my /= _ Y mY. +rewrite setTI. +have := mx measurableT Y mY. +rewrite setTI => xY. +have := my measurableT Y mY. +rewrite setTI => yY. +rewrite (_ : _ @^-1` Y = (x @^-1` Y) `*` [set true] `|` (y @^-1` Y) `*` [set false]); last first. + apply/seteqP; split. + move=> [t [|]]/=. + by left. + by right. + move=> [t [|]]/=. + by case=> [[]//|[]]. + by case=> [[]//|[]]. +by apply: measurableU; apply: measurableM => //. +Qed. + +(*/ PR*) + +Reserved Notation "R .-ker X ~> Y" (at level 42). +Reserved Notation "R .-fker X ~> Y" (at level 42). +Reserved Notation "R .-sfker X ~> Y" (at level 42). + +HB.mixin Record isKernel d d' (X : measurableType d) (Y : measurableType d') + (R : realType) (k : X -> {measure set Y -> \bar R}) := + { measurable_kernel : forall U, measurable U -> measurable_fun setT (k ^~ U) }. + +#[short(type=kernel)] +HB.structure Definition Kernel + d d' (X : measurableType d) (Y : measurableType d') (R : realType) := + { k & isKernel _ _ X Y R k }. +Notation "R .-ker X ~> Y" := (kernel X Y R). + +Arguments measurable_kernel {_ _ _ _ _} _. + +Section sum_of_kernels. +Variables (d d' : measure_display) (R : realType). +Variables (X : measurableType d) (Y : measurableType d'). +Variable k : (R.-ker X ~> Y)^nat. + +Definition sum_of_kernels : X -> {measure set Y -> \bar R} := + fun x => [the measure _ _ of mseries (k ^~ x) 0]. + +Lemma kernel_measurable_fun_sum_of_kernels (U : set Y) : + measurable U -> + measurable_fun setT (sum_of_kernels ^~ U). +Proof. +move=> mU; rewrite /sum_of_kernels /= /mseries. +rewrite [X in measurable_fun _ X](_ : _ = + (fun x => elim_sup (fun n => \sum_(0 <= i < n) k i x U))); last first. + apply/funext => x; rewrite -lim_mkord is_cvg_elim_supE. + by rewrite -lim_mkord. + exact: is_cvg_nneseries. +apply: measurable_fun_elim_sup => n. +by apply: emeasurable_fun_sum => *; exact/measurable_kernel. +Qed. + +HB.instance Definition _ := + isKernel.Build _ _ _ _ _ sum_of_kernels + kernel_measurable_fun_sum_of_kernels. -Lemma xsection_ndseq_closed_dep : ndseq_closed B. +End sum_of_kernels. + +Lemma integral_sum_of_kernels + (d d' : _) (X : measurableType d) (Y : measurableType d') + (R : realType) (k : (R.-ker X ~> Y)^nat) (f : Y -> \bar R) x : + (forall y, 0 <= f y) -> + measurable_fun setT f -> + \int[sum_of_kernels k x]_y (f y) = \sum_(i f0 mf; rewrite /sum_of_kernels/= ge0_integral_measure_series. +Qed. + +(* TODO: define using the probability type *) +HB.mixin Record isProbabilityKernel + d d' (X : measurableType d) (Y : measurableType d') + (R : realType) (k : X -> {measure set Y -> \bar R}) + of isKernel _ _ X Y R k := { + prob_kernelP : forall x, k x [set: Y] = 1 +}. + +#[short(type=probability_kernel)] +HB.structure Definition ProbabilityKernel + (d d' : _) (X : measurableType d) (Y : measurableType d') + (R : realType) := + {k of isProbabilityKernel _ _ X Y R k & isKernel _ _ X Y R k}. + +Section measure_uub. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : numFieldType) (k : X -> {measure set Y -> \bar R}). + +Definition measure_uub := exists r, forall x, k x [set: Y] < r%:E. + +Lemma measure_uubP : measure_uub <-> + exists r : {posnum R}, forall x, k x [set: Y] < r%:num%:E. +Proof. +split => [|] [r kr]; last by exists r%:num. +suff r_gt0 : (0 < r)%R by exists (PosNum r_gt0). +by rewrite -lte_fin; apply: (le_lt_trans _ (kr point)). +Qed. + +End measure_uub. + +HB.mixin Record isFiniteKernel + d d' (X : measurableType d) (Y : measurableType d') + (R : realType) (k : X -> {measure set Y -> \bar R}) := + { kernel_uub : measure_uub k }. + +#[short(type=finite_kernel)] +HB.structure Definition FiniteKernel + d d' (X : measurableType d) (Y : measurableType d') + (R : realType) := + {k of isFiniteKernel _ _ X Y R k & isKernel _ _ X Y R k}. +Notation "R .-fker X ~> Y" := (finite_kernel X Y R). + +Arguments kernel_uub {_ _ _ _ _} _. + +Section kernel_from_mzero. +Variables (d : _) (T : measurableType d) (R : realType). +Variables (d' : _) (T' : measurableType d'). + +Definition kernel_from_mzero : T' -> {measure set T -> \bar R} := + fun _ : T' => [the measure _ _ of mzero]. + +Lemma kernel_from_mzeroP : forall U, measurable U -> + measurable_fun setT (kernel_from_mzero ^~ U). +Proof. by move=> U mU/=; exact: measurable_fun_cst. Qed. + +HB.instance Definition _ := + @isKernel.Build _ _ T' T R kernel_from_mzero + kernel_from_mzeroP. + +Lemma kernel_from_mzero_uub : measure_uub kernel_from_mzero. +Proof. +exists 1%R => /= t. +by rewrite /mzero/=. +Qed. + +HB.instance Definition _ := + @isFiniteKernel.Build _ _ _ T R kernel_from_mzero + kernel_from_mzero_uub. + +End kernel_from_mzero. + +HB.mixin Record isSFiniteKernel + d d' (X : measurableType d) (Y : measurableType d') + (R : realType) (k : X -> {measure set Y -> \bar R}) := { + sfinite : exists s : (R.-fker X ~> Y)^nat, + forall x U, measurable U -> + k x U = [the measure _ _ of mseries (s ^~ x) 0] U }. + +#[short(type=sfinite_kernel)] +HB.structure Definition SFiniteKernel + d d' (X : measurableType d) (Y : measurableType d') + (R : realType) := + {k of isSFiniteKernel _ _ X Y R k & + isKernel _ _ X Y _ k}. +Notation "R .-sfker X ~> Y" := (sfinite_kernel X Y R). + +Arguments sfinite {_ _ _ _ _} _. + +(* a finite kernel is always an s-finite kernel *) +Section finite_is_sfinite. +Variables (d d' : _) (X : measurableType d) (T : measurableType d'). +Variables (R : realType) (k : R.-fker T ~> X). + +Lemma sfinite_finite : + exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> + k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. Proof. -move=> F ndF; rewrite /B /= => BF; split. - by apply: bigcupT_measurable => n; have [] := BF n. -have phiF x : (fun i => phi (F i) x) --> phi (\bigcup_i F i) x. - rewrite /phi /= xsection_bigcup; apply: cvg_mu_inc => //. - - by move=> n; apply: measurable_xsection; case: (BF n). - - by apply: bigcupT_measurable => i; apply: measurable_xsection; case: (BF i). - - move=> m n mn; apply/subsetPset => y; rewrite /xsection/= !inE. - by have /subsetPset FmFn := ndF _ _ mn; exact: FmFn. -apply: (emeasurable_fun_cvg (phi \o F)) => //. -- by move=> i; have [] := BF i. -- by move=> x _; exact: phiF. +exists (fun n => if n is O then k else + [the finite_kernel _ _ _ of @kernel_from_mzero _ X R _ T]). +move=> t U mU/=. +rewrite /mseries. +rewrite (nneseries_split 1%N)// big_ord_recl/= big_ord0 adde0. +rewrite ereal_series (@eq_nneseries _ _ (fun=> 0%E)); last by case. +by rewrite nneseries0// adde0. Qed. -End xsection. -End ndseq_closed_B. +End finite_is_sfinite. -Section measurable_prod_subset. -Variables (d1 d2 : measure_display). -Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). +(* see measurable_prod_subset in lebesgue_integral.v; + the differences between the two are: + - m2 is a kernel instead of a measure + - m2D_bounded holds for all x *) +Section measurable_prod_subset_kernel. +Variables (d1 d2 : _) (T1 : measurableType d1) (T2 : measurableType d2) + (R : realType). Implicit Types A : set (T1 * T2). -Section xsection. -Variable (m2 : T1 -> {measure set T2 -> \bar R}) (D : set T2) (mD : measurable D). +Section xsection_kernel. +Variable (m2 : R.-ker T1 ~> T2) (D : set T2) (mD : measurable D). Let m2D x := mrestr (m2 x) mD. HB.instance Definition _ x := Measure.on (m2D x). Let phi A := fun x => m2D x (xsection A x). Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. -Hypothesis H1 : forall X2, measurable X2 -> measurable_fun [set: T1] (m2D^~ X2). - -Lemma measurable_prod_subset_xsection_dep +Lemma measurable_prod_subset_xsection_kernel (m2D_bounded : forall x, exists M, forall X, measurable X -> (m2D x X < M%:E)%E) : measurable `<=` B. Proof. @@ -390,123 +474,68 @@ have CB : C `<=` B. rewrite funeqE => x; rewrite indicE /phi /m2/= /mrestr. have [xX1|xX1] := boolP (x \in X1); first by rewrite mule1 in_xsectionM. by rewrite mule0 notin_xsectionM// set0I measure0. - apply: emeasurable_funM => //. - by apply: H1. + apply: emeasurable_funM => //; first exact/measurable_kernel/measurableI. apply/EFin_measurable_fun. by rewrite (_ : \1_ _ = mindic R mX1). suff monoB : monotone_class setT B by exact: monotone_class_subset. -split => //; [exact: CB| |exact: xsection_ndseq_closed_dep]. +split => //; [exact: CB| |exact: xsection_ndseq_closed]. move=> X Y XY [mX mphiX] [mY mphiY]; split; first exact: measurableD. -have -> : phi (X `\` Y) = (fun x => phi X x - phi Y x)%E. - rewrite funeqE => x; rewrite /phi/= xsectionD// /m2D measureD. - - by rewrite setIidr//; exact: le_xsection. - - exact: measurable_xsection. - - exact: measurable_xsection. - - move: (m2D_bounded x) => [M m2M]. - rewrite (lt_le_trans (m2M (xsection X x) _))// ?leey//. - exact: measurable_xsection. -exact: emeasurable_funB. +suff : phi (X `\` Y) = (fun x => phi X x - phi Y x)%E. + by move=> ->; exact: emeasurable_funB. +rewrite funeqE => x; rewrite /phi/= xsectionD// /m2D measureD. +- by rewrite setIidr//; exact: le_xsection. +- exact: measurable_xsection. +- exact: measurable_xsection. +- move: (m2D_bounded x) => [M m2M]. + rewrite (lt_le_trans (m2M (xsection X x) _))// ?leey//. + exact: measurable_xsection. Qed. -End xsection. +End xsection_kernel. -End measurable_prod_subset. +End measurable_prod_subset_kernel. -Section measurable_fun_xsection. -Variables (d1 d2 : measure_display) (T1 : measurableType d1) - (T2 : measurableType d2) (R : realType). -Variables (m2 : T1 -> {measure set T2 -> \bar R}). +(* see measurable_fun_xsection in lebesgue_integral.v + the difference is that this section uses a finite kernel m2 + instead of a sigma-finite measure m2 *) +Section measurable_fun_xsection_finite_kernel. +Variables (d1 d2 : _) (T1 : measurableType d1) (T2 : measurableType d2) + (R : realType). +Variable m2 : R.-fker T1 ~> T2. Implicit Types A : set (T1 * T2). -Hypotheses m2_ub : kernel_uub m2. -Hypothesis H1 : forall X2, measurable X2 -> - measurable_fun [set: T1] ((fun x => mrestr (m2 x) measurableT)^~ X2). - -Let phi A := (fun x => m2 x (xsection A x)). +Let phi A := fun x => m2 x (xsection A x). Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. -Lemma measurable_fun_xsection_dep A : +Lemma measurable_fun_xsection_finite_kernel A : A \in measurable -> measurable_fun setT (phi A). Proof. move: A; suff : measurable `<=` B by move=> + A; rewrite inE => /[apply] -[]. move=> X mX. rewrite /B/=; split => //. rewrite /phi. -rewrite -(_ : (fun x : T1 => mrestr (m2 x) measurableT (xsection X x)) = (fun x => (m2 x) (xsection X x)))//; last first. - apply/funext => x//=. - by rewrite /mrestr setIT. -apply measurable_prod_subset_xsection_dep => //. +rewrite -(_ : (fun x => mrestr (m2 x) measurableT (xsection X x)) = + (fun x => (m2 x) (xsection X x)))//; last first. + by apply/funext => x//=; rewrite /mrestr setIT. +apply measurable_prod_subset_xsection_kernel => //. move=> x. -case: m2_ub => r hr. -exists r%:num => Y mY. +have [r hr] := kernel_uub m2. +exists r => Y mY. apply: (le_lt_trans _ (hr x)) => //. rewrite /mrestr. -apply le_measure => //. -rewrite inE. -apply: measurableI => //. -by rewrite inE. +by apply le_measure => //; rewrite inE//; exact: measurableI. Qed. -End measurable_fun_xsection. +End measurable_fun_xsection_finite_kernel. -Section fubini_F_dep. -Local Open Scope ereal_scope. -Variables (d1 d2 : measure_display). -Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). -Variables (m2 : T1 -> {measure set T2 -> \bar R}). -Variable f : T1 * T2 -> \bar R. - -Definition fubini_F_dep x := \int[m2 x]_y f (x, y). - -End fubini_F_dep. - -Section fubini_tonelli. -Local Open Scope ereal_scope. -Variables (d1 d2 : measure_display). -Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). -Variables (m1 : {measure set T1 -> \bar R}) (m2 : T1 -> {measure set T2 -> \bar R}). -Hypotheses m2_ub : kernel_uub m2. - -Section indic_fubini_tonelli. -Variables (A : set (T1 * T2)) (mA : measurable A). -Implicit Types A : set (T1 * T2). -Let f : (T1 * T2) -> R := \1_A. - -Let F := fubini_F_dep m2 (EFin \o f). - -Lemma indic_fubini_tonelli_FE_dep : F = (fun x => m2 x (xsection A x)). +(* pollard *) +Lemma measurable_fun_integral_finite_kernel + (d d' : _) (X : measurableType d) (Y : measurableType d') + (R : realType) (l : R.-fker X ~> Y) (k : (X * Y)%type -> \bar R) + (k0 : (forall z, True -> 0 <= k z)) (mk : measurable_fun setT k) : + measurable_fun setT (fun x => \int[l x]_y k (x, y)). Proof. -rewrite funeqE => x; rewrite /= -(setTI (xsection _ _)). -rewrite -integral_indic//; last exact: measurable_xsection. -rewrite /F /fubini_F -(setTI (xsection _ _)). -rewrite integral_setI_indic; [|exact: measurable_xsection|by []]. -apply: eq_integral => y _ /=; rewrite indicT mul1e /f !indicE. -have [|] /= := boolP (y \in xsection _ _). - by rewrite inE /xsection /= => ->. -by rewrite /xsection /= notin_set /= => /negP/negbTE ->. -Qed. - -Hypothesis H1 : forall X2, measurable X2 -> - measurable_fun [set: T1] ((fun x => mrestr (m2 x) measurableT)^~ X2). - -Lemma indic_measurable_fun_fubini_tonelli_F_dep : measurable_fun setT F. -Proof. -rewrite indic_fubini_tonelli_FE_dep//; apply: measurable_fun_xsection_dep => //. -by rewrite inE. -Qed. - -End indic_fubini_tonelli. - -End fubini_tonelli. - -Lemma pollard_finite (d d' : measure_display) (R : realType) - (X : measurableType d) (Y : measurableType d') - (k : (X * Y)%type -> \bar R) (k0 : (forall t : X * Y, True -> 0 <= k t)) - (mk : measurable_fun setT k) (l : finite_kernel R X Y) : - measurable_fun [set: X] (fun x : X => \int[l x]_y k (x, y)). -Proof. -have [k_ [ndk_ k_k]] := @approximation _ _ _ _ measurableT k mk k0. -simpl in *. +have [k_ [ndk_ k_k]] := approximation measurableT mk k0. rewrite (_ : (fun x => \int[l x]_y k (x, y)) = (fun x => elim_sup (fun n => \int[l x]_y (k_ n (x, y))%:E))); last first. apply/funeqP => x. @@ -525,13 +554,12 @@ rewrite (_ : (fun x => \int[l x]_y k (x, y)) = - by move=> n y' _; rewrite lee_fin. - by move=> y' _ m n mn; rewrite lee_fin; apply/lefP/ndk_. apply: measurable_fun_elim_sup => n. -rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \int[l x0]_y - ((\sum_(r <- fset_set (range (k_ n))) - r * \1_(k_ n @^-1` [set r]) (x0, y)))%:E)); last first. +rewrite [X in measurable_fun _ X](_ : _ = (fun x => \int[l x]_y + (\sum_(r <- fset_set (range (k_ n))) + r * \1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. -rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \sum_(r <- fset_set (range (k_ n))) - (\int[l x0]_y - (r * \1_(k_ n @^-1` [set r]) (x0, y))%:E))); last first. +rewrite [X in measurable_fun _ X](_ : _ = (fun x => \sum_(r <- fset_set (range (k_ n))) + (\int[l x]_y (r * \1_(k_ n @^-1` [set r]) (x, y))%:E))); last first. apply/funext => x; rewrite -ge0_integral_sum//. - by apply: eq_integral => y _; rewrite sumEFin. - move=> r. @@ -549,135 +577,126 @@ rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * - apply/EFin_measurable_fun/measurable_fun_prod1 => /=. by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). apply: measurable_funeM. -apply: indic_measurable_fun_fubini_tonelli_F_dep. -- by apply/finite_kernelP. -- by apply/measurable_sfunP. -- move=> X2. - rewrite (_ : (fun x : X => mrestr (l x) measurableT X2) = (fun x : X => (l x) X2))//. - by apply/kernelP. - apply/funeqP => x. - by rewrite /mrestr setIT. +rewrite (_ : (fun x => _) = (fun x => l x (xsection (k_ n @^-1` [set r]) x))); last first. + apply/funext => y. + rewrite integral_indic//; last first. + rewrite (_ : (fun x => _) = xsection (k_ n @^-1` [set r]) y); last first. + apply/seteqP; split. + by move=> y2/=; rewrite /xsection/= inE//. + by rewrite /xsection/= => y2/=; rewrite inE. + exact: measurable_xsection. + congr (l y _). + apply/funext => y1/=. + rewrite /xsection/= inE. + by apply/propext; tauto. +have [l_ hl_] := kernel_uub l. +by apply: measurable_fun_xsection_finite_kernel => // /[!inE]. Qed. -Module STAR_IS_FINITE_KERNEL. +Section kcomp_def. +Variables (d1 d2 d3 : _) (X : measurableType d1) (Y : measurableType d2) + (Z : measurableType d3) (R : realType). +Variable l : X -> {measure set Y -> \bar R}. +Variable k : (X * Y)%type -> {measure set Z -> \bar R}. -Section star_is_kernel_finite. -Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3). -Variable k : kernel R [the measurableType _ of (X * Y)%type] Z. -Variable l : finite_kernel R X Y. +Definition kcomp x U := \int[l x]_y k (x, y) U. -Lemma star_measurable_finite U : measurable U -> measurable_fun setT (star k l ^~ U). -Proof. -(* k is a bounded measurable function *) -(* l is a finite kernel *) -move=> mU. -rewrite /star. -apply: (@pollard_finite _ _ R X Y (fun xy => k xy U)) => //. -by apply: (@kernelP _ _ R [the measurableType (d, d').-prod of (X * Y)%type] Z k U) => //. -Qed. +End kcomp_def. -HB.instance Definition _ := - isKernel.Build _ _ R X Z (mstar k l) star_measurable_finite. +Section kcomp_is_measure. +Variables (d1 d2 d3 : _) (X : measurableType d1) (Y : measurableType d2) + (Z : measurableType d3) (R : realType). +Variable l : R.-ker X ~> Y. +Variable k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z. -End star_is_kernel_finite. +Local Notation "l \; k" := (kcomp l k). -Section star_is_finite_kernel. -Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3). -Variable k : finite_kernel R [the measurableType _ of (X * Y)%type] Z. -Variable l : finite_kernel R X Y. +Let kcomp0 x : (l \; k) x set0 = 0. +Proof. +by rewrite /kcomp (eq_integral (cst 0)) ?integral0// => y _; rewrite measure0. +Qed. -Lemma star_finite : kernel_uub (mstar k l). +Let kcomp_ge0 x U : 0 <= (l \; k) x U. Proof. exact: integral_ge0. Qed. + +Let kcomp_sigma_additive x : semi_sigma_additive ((l \; k) x). Proof. -have [r hr] := @finite_kernelP _ _ _ _ _ k. -have [s hs] := @finite_kernelP _ _ _ _ _ l. -exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x. -rewrite /star. -apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). - apply: ge0_le_integral => //. - - have := @kernelP _ _ _ _ _ k setT measurableT. - exact/measurable_fun_prod1. - - exact/measurable_fun_cst. - - by move=> y _; apply/ltW/hr. -by rewrite integral_cst//= EFinM lte_pmul2l. +move=> U mU tU mUU; rewrite [X in _ --> X](_ : _ = + \int[l x]_y (\sum_(n V _. + by apply/esym/cvg_lim => //; exact/measure_semi_sigma_additive. +apply/cvg_closeP; split. + by apply: is_cvg_nneseries => n _; exact: integral_ge0. +rewrite closeE// integral_sum// => n. +by have /measurable_fun_prod1 := measurable_kernel k (U n) (mU n). Qed. -HB.instance Definition _ := - isFiniteKernel.Build _ _ R X Z (mstar k l) star_finite. +HB.instance Definition _ x := isMeasure.Build _ R _ + ((l \; k) x) (kcomp0 x) (kcomp_ge0 x) (@kcomp_sigma_additive x). + +Definition mkcomp : X -> {measure set Z -> \bar R} := + fun x => [the measure _ _ of (l \; k) x]. + +End kcomp_is_measure. + +Notation "l \; k" := (mkcomp l k). + +Module KCOMP_FINITE_KERNEL. -End star_is_finite_kernel. -End STAR_IS_FINITE_KERNEL. +Section kcomp_finite_kernel_kernel. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) (l : R.-fker X ~> Y) + (k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z). -Lemma pollard_sfinite (d d' d3 : measure_display) (R : realType) - (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) - (k : Z -> \bar R) (k0 : (forall z, True -> 0 <= k z)) - (mk : measurable_fun setT k) - (l : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z) c : - measurable_fun [set: Y] (fun x0 : Y => \int[l (c, x0)]_z k z). +Lemma measurable_fun_kcomp_finite U : + measurable U -> measurable_fun setT ((l \; k) ^~ U). Proof. -have [k_ [ndk_ k_k]] := @approximation _ _ _ _ measurableT k mk k0. -simpl in *. -rewrite (_ : (fun x0 => \int[l (c, x0)]_z k z) = - (fun x0 => elim_sup (fun n => \int[l (c, x0)]_z (k_ n z)%:E))); last first. - apply/funeqP => x. - transitivity (lim (fun n => \int[l (c, x)]_z (k_ n z)%:E)); last first. - rewrite is_cvg_elim_supE//. - apply: ereal_nondecreasing_is_cvg => m n mn. - apply: ge0_le_integral => //. - - by move=> y' _; rewrite lee_fin. - - exact/EFin_measurable_fun. - - by move=> y' _; rewrite lee_fin. - - exact/EFin_measurable_fun. - - by move=> y' _; rewrite lee_fin; apply/lefP/ndk_. - rewrite -monotone_convergence//. - - by apply: eq_integral => y _; apply/esym/cvg_lim => //; exact: k_k. - - by move=> n; exact/EFin_measurable_fun. - - by move=> n y' _; rewrite lee_fin. - - by move=> y' _ m n mn; rewrite lee_fin; apply/lefP/ndk_. -apply: measurable_fun_elim_sup => n. -rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \int[l (c, x0)]_z - ((\sum_(r <- fset_set (range (k_ n))) - r * \1_(k_ n @^-1` [set r]) z))%:E)); last first. - by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. -rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \sum_(r <- fset_set (range (k_ n))) - (\int[l (c, x0)]_z - (r * \1_(k_ n @^-1` [set r]) z)%:E))); last first. - apply/funext => x; rewrite -ge0_integral_sum//. - - by apply: eq_integral => y _; rewrite sumEFin. - - move=> r. - apply/EFin_measurable_fun/measurable_funrM => /=. - by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). - - by move=> m y _; rewrite muleindic_ge0. -apply emeasurable_fun_sum => r. -rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * - \int[l (c ,x)]_z (\1_(k_ n @^-1` [set r]) z)%:E)); last first. - apply/funext => x. - under eq_integral do rewrite EFinM. - rewrite (integralM_0ifneg _ _ (fun k z => (\1_(k_ n @^-1` [set r]) z)%:E))//. - - by move=> _ t _; rewrite lee_fin. - - by move=> r_lt0; apply/funext => y; rewrite preimage_nnfun0// indicE in_set0. - - apply/EFin_measurable_fun => /=. - by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). -apply: measurable_funeM. -rewrite (_ : (fun x : Y => \int[l (c, x)]_z (\1_(k_ n @^-1` [set r]) z)%:E) = - (fun x : Y => l (c, x) (k_ n @^-1` [set r]))); last first. - apply/funext => y. - by rewrite integral_indic// setIT. -have := @kernelP _ _ R _ _ l (k_ n @^-1` [set r]) (measurable_sfunP (k_ n) r). +move=> mU. +rewrite /kcomp. +apply: (@measurable_fun_integral_finite_kernel _ _ _ _ _ _ (k ^~ U)) => //=. +exact/measurable_kernel. +Qed. + +HB.instance Definition _ := + isKernel.Build _ _ X Z R (l \; k) measurable_fun_kcomp_finite. + +End kcomp_finite_kernel_kernel. + +Section kcomp_finite_kernel_finite. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : R.-fker X ~> Y. +Variable k : R.-fker [the measurableType _ of (X * Y)%type] ~> Z. + +Lemma mkcomp_finite : measure_uub (l \; k). +Proof. +have /measure_uubP[r hr] := kernel_uub k. +have /measure_uubP[s hs] := kernel_uub l. +apply/measure_uubP; exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x. rewrite /=. -move/measurable_fun_prod1. -exact. +apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). + apply: ge0_le_integral => //. + - have /measurable_fun_prod1 := measurable_kernel k setT measurableT. + exact. + - exact/measurable_fun_cst. + - by move=> y _; exact/ltW/hr. +by rewrite integral_cst//= EFinM lte_pmul2l. Qed. -Lemma pollard_sfinite2 (d d' : measure_display) (R : realType) - (X : measurableType d) (Y : measurableType d') - (k : (X * Y)%type -> \bar R) (k0 : (forall (t : X * Y), True -> 0 <= k t)) - (l : sfinite_kernel R X Y) - (mk : measurable_fun setT k) : - measurable_fun [set: X] (fun x : X => \int[l x]_y k (x, y)). +HB.instance Definition _ := + isFiniteKernel.Build _ _ X Z R (l \; k) mkcomp_finite. + +End kcomp_finite_kernel_finite. +End KCOMP_FINITE_KERNEL. + +(* pollard *) +Lemma measurable_fun_integral_sfinite_kernel + (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType) + (l : R.-sfker X ~> Y) + (k : (X * Y)%type -> \bar R) (k0 : (forall t, True -> 0 <= k t)) + (mk : measurable_fun setT k) : + measurable_fun [set: X] (fun x => \int[l x]_y k (x, y)). Proof. -have [k_ [ndk_ k_k]] := @approximation _ _ _ _ measurableT k mk k0. +have [k_ [ndk_ k_k]] := approximation measurableT mk k0. simpl in *. rewrite (_ : (fun x => \int[l x]_y k (x, y)) = (fun x => elim_sup (fun n => \int[l x]_y (k_ n (x, y))%:E))); last first. @@ -698,8 +717,8 @@ rewrite (_ : (fun x => \int[l x]_y k (x, y)) = - by move=> y' _ m n mn; rewrite lee_fin; apply/lefP/ndk_. apply: measurable_fun_elim_sup => n. rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \int[l x0]_y - ((\sum_(r <- fset_set (range (k_ n))) - r * \1_(k_ n @^-1` [set r]) (x0, y)))%:E)); last first. + (\sum_(r <- fset_set (range (k_ n))) + r * \1_(k_ n @^-1` [set r]) (x0, y))%:E)); last first. by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \sum_(r <- fset_set (range (k_ n))) (\int[l x0]_y @@ -721,146 +740,194 @@ rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * - apply/EFin_measurable_fun/measurable_fun_prod1 => /=. by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). apply: measurable_funeM. -rewrite (_ : (fun x : X => \int[l x]_z (\1_(k_ n @^-1` [set r]) (x, z))%:E) = - (fun x : X => l x (xsection (k_ n @^-1` [set r]) x))); last first. +rewrite (_ : (fun x => \int[l x]_z (\1_(k_ n @^-1` [set r]) (x, z))%:E) = + (fun x => l x (xsection (k_ n @^-1` [set r]) x))); last first. apply/funext => y. rewrite integral_indic//; last first. - rewrite (_ : (fun x : Y => (k_ n @^-1` [set r]) (y, x)) = xsection (k_ n @^-1` [set r]) y); last first. + rewrite (_ : (fun x => (k_ n @^-1` [set r]) (y, x)) = xsection (k_ n @^-1` [set r]) y); last first. apply/seteqP; split. by move=> y2/=; rewrite /xsection/= inE//. by rewrite /xsection/= => y2/=; rewrite inE /preimage/=. - by apply: measurable_xsection. + exact: measurable_xsection. congr (l y _). apply/funext => y1/=. rewrite /xsection/= inE. by apply/propext; tauto. -have [l_ hl_] := @sfinite_kernelP _ _ _ _ _ l. -rewrite (_ : (fun x : X => _) = - (fun x : X => mseries (l_ ^~ x) 0 (xsection (k_ n @^-1` [set r]) x)) -); last first. +have [l_ hl_] := sfinite l. +rewrite (_ : (fun x => _) = (fun x => mseries (l_ ^~ x) 0 (xsection (k_ n @^-1` [set r]) x))); last first. apply/funext => x. rewrite hl_//. - by apply/measurable_xsection. + exact/measurable_xsection. rewrite /mseries/=. apply: ge0_emeasurable_fun_sum => // k1. -apply: measurable_fun_xsection_dep => //. -by have := @finite_kernelP _ _ _ _ _ (l_ k1). -move=> X2 mX2. -rewrite /mrestr. -apply/kernelP. -by rewrite setIT. +apply: measurable_fun_xsection_finite_kernel => //. by rewrite inE. Qed. -Section star_is_sfinite_kernel. -Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3). -Variable k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z. -Variable l : sfinite_kernel R X Y. +Section kcomp_sfinite_kernel. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : R.-sfker X ~> Y. +Variable k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. -Import STAR_IS_FINITE_KERNEL. +Import KCOMP_FINITE_KERNEL. -Lemma star_sfinite : exists k_ : (finite_kernel R X Z)^nat, forall x U, measurable U -> - mstar k l x U = [the measure _ _ of mseries (k_ ^~ x) O] U. +Lemma mkcomp_sfinite : exists k_ : (R.-fker X ~> Z)^nat, forall x U, measurable U -> + (l \; k) x U = [the measure _ _ of mseries (k_ ^~ x) O] U. Proof. -have [k_ hk_] := @sfinite_kernelP _ _ _ _ _ k. -have [l_ hl_] := @sfinite_kernelP _ _ _ _ _ l. +have [k_ hk_] := sfinite k. +have [l_ hl_] := sfinite l. pose K := [the kernel _ _ _ of sum_of_kernels k_]. pose L := [the kernel _ _ _ of sum_of_kernels l_]. -have H1 x U : measurable U -> star k l x U = star K L x U. - move=> mU. - rewrite /star /L /K /=. +have H1 x U : measurable U -> (l \; k) x U = (L \; K) x U. + move=> mU /=. + rewrite /kcomp /L /K /=. transitivity (\int[ - [the measure _ _ of mseries (fun x0 : nat => l_ x0 x) 0] ]_y k (x, y) U). - apply eq_measure_integral => A mA _ . - by rewrite hl_. - apply eq_integral => y _. - by rewrite hk_//. -have H2 x U : star K L x U = + [the measure _ _ of mseries (l_ ^~ x) 0] ]_y k (x, y) U). + by apply eq_measure_integral => A mA _; rewrite hl_. + by apply eq_integral => y _; rewrite hk_. +have H2 x U : (L \; K) x U = \int[mseries (l_ ^~ x) 0]_y (\sum_(i y _. + exact: eq_integral. have H3 x U : measurable U -> \int[mseries (l_ ^~ x) 0]_y (\sum_(i mU. rewrite integral_sum//= => n. - have := @kernelP _ _ _ _ _ (k_ n) _ mU. - by move/measurable_fun_prod1; exact. + have := measurable_kernel (k_ n) _ mU. + by move=> /measurable_fun_prod1; exact. have H4 x U : measurable U -> \sum_(i mU. apply: eq_nneseries => i _. rewrite integral_sum_of_kernels//. - have := @kernelP _ _ _ _ _ (k_ i) _ mU. - by move/measurable_fun_prod1; exact. + have := measurable_kernel (k_ i) _ mU. + by move=> /measurable_fun_prod1; exact. have H5 x U : \sum_(i i _; exact: eq_nneseries. -suff: exists k_0 : (finite_kernel R X Z) ^nat, forall x U, - \esum_(i in setT) star (k_ i.1) (l_ i.2) x U = \sum_(i Z) ^nat, forall x U, + \esum_(i in setT) ((l_ i.2) \; (k_ i.1)) x U = \sum_(i [kl_ hkl_]. exists kl_ => x U mU. - rewrite /=. - rewrite /mstar/= /mseries H1// H2 H3//. - rewrite H4//. - rewrite H5// -hkl_ /=. + rewrite /= H1// H2 H3// H4// H5// /mseries -hkl_/=. rewrite (_ : setT = setT `*`` (fun=> setT)); last by apply/seteqP; split. - rewrite -(@esum_esum _ _ _ _ _ (fun i j => star (k_ i) (l_ j) x U))//. - rewrite nneseries_esum; last by move=> n _; exact: nneseries_lim_ge0(* TODO: rename this lemma *). + rewrite -(@esum_esum _ _ _ _ _ (fun i j => (l_ j \; k_ i) x U))//. + rewrite nneseries_esum; last by move=> n _; exact: nneseries_lim_ge0. by rewrite fun_true; apply: eq_esum => /= i _; rewrite nneseries_esum// fun_true. rewrite /=. have /ppcard_eqP[f] : ([set: nat] #= [set: nat * nat])%card. by rewrite card_eq_sym; exact: card_nat2. -exists (fun i => [the finite_kernel _ _ _ of mstar (k_ (f i).1) (l_ (f i).2)]) => x U. +exists (fun i => [the _.-fker _ ~> _ of (l_ (f i).2) \; (k_ (f i).1)]) => x U. rewrite (reindex_esum [set: nat] [set: nat * nat] f)//. by rewrite nneseries_esum// fun_true. Qed. -Lemma star_measurable_sfinite U : measurable U -> measurable_fun setT (star k l ^~ U). +Lemma measurable_fun_mkcomp_sfinite U : measurable U -> measurable_fun setT ((l \; k) ^~ U). Proof. move=> mU. -rewrite /star. -apply: (@pollard_sfinite2 _ _ _ _ _ (k ^~ U)) => //. -by apply/kernelP. +apply: (@measurable_fun_integral_sfinite_kernel _ _ _ _ _ _ (k ^~ U)) => //. +exact/measurable_kernel. Qed. -End star_is_sfinite_kernel. +End kcomp_sfinite_kernel. -Module STAR_IS_SFINITE_KERNEL. -Section star_is_sfinite_kernel. -Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3). -Variable k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z. -Variable l : sfinite_kernel R X Y. +Module KCOMP_SFINITE_KERNEL. +Section kcomp_sfinite_kernel. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : R.-sfker X ~> Y. +Variable k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. HB.instance Definition _ := - isKernel.Build _ _ R X Z (mstar k l) (star_measurable_sfinite k l). + isKernel.Build _ _ X Z R (l \; k) (measurable_fun_mkcomp_sfinite l k). #[export] HB.instance Definition _ := - isSFiniteKernel.Build d d3 R X Z (mstar k l) (star_sfinite k l). + isSFiniteKernel.Build _ _ X Z R (l \; k) (mkcomp_sfinite l k). + +End kcomp_sfinite_kernel. +End KCOMP_SFINITE_KERNEL. +HB.export KCOMP_SFINITE_KERNEL. + +(* pollard *) +Lemma measurable_fun_integral_sfinite_kernel_prod + (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) + (l : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) c + (k : Z -> \bar R) (k0 : (forall z, True -> 0 <= k z)) (mk : measurable_fun setT k) : + measurable_fun [set: Y] (fun y => \int[l (c, y)]_z k z). +Proof. +have [k_ [ndk_ k_k]] := approximation measurableT mk k0. +simpl in *. +rewrite (_ : (fun x0 => \int[l (c, x0)]_z k z) = + (fun x0 => elim_sup (fun n => \int[l (c, x0)]_z (k_ n z)%:E))); last first. + apply/funeqP => x. + transitivity (lim (fun n => \int[l (c, x)]_z (k_ n z)%:E)); last first. + rewrite is_cvg_elim_supE//. + apply: ereal_nondecreasing_is_cvg => m n mn. + apply: ge0_le_integral => //. + - by move=> y' _; rewrite lee_fin. + - exact/EFin_measurable_fun. + - by move=> y' _; rewrite lee_fin. + - exact/EFin_measurable_fun. + - by move=> y' _; rewrite lee_fin; apply/lefP/ndk_. + rewrite -monotone_convergence//. + - by apply: eq_integral => y _; apply/esym/cvg_lim => //; exact: k_k. + - by move=> n; exact/EFin_measurable_fun. + - by move=> n y' _; rewrite lee_fin. + - by move=> y' _ m n mn; rewrite lee_fin; apply/lefP/ndk_. +apply: measurable_fun_elim_sup => n. +rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \int[l (c, x0)]_z + ((\sum_(r <- fset_set (range (k_ n))) + r * \1_(k_ n @^-1` [set r]) z))%:E)); last first. + by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. +rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \sum_(r <- fset_set (range (k_ n))) + (\int[l (c, x0)]_z + (r * \1_(k_ n @^-1` [set r]) z)%:E))); last first. + apply/funext => x; rewrite -ge0_integral_sum//. + - by apply: eq_integral => y _; rewrite sumEFin. + - move=> r. + apply/EFin_measurable_fun/measurable_funrM => /=. + by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). + - by move=> m y _; rewrite muleindic_ge0. +apply emeasurable_fun_sum => r. +rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * + \int[l (c ,x)]_z (\1_(k_ n @^-1` [set r]) z)%:E)); last first. + apply/funext => x. + under eq_integral do rewrite EFinM. + rewrite (integralM_0ifneg _ _ (fun k z => (\1_(k_ n @^-1` [set r]) z)%:E))//. + - by move=> _ t _; rewrite lee_fin. + - by move=> r_lt0; apply/funext => y; rewrite preimage_nnfun0// indicE in_set0. + - apply/EFin_measurable_fun => /=. + by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). +apply: measurable_funeM. +rewrite (_ : (fun x : Y => \int[l (c, x)]_z (\1_(k_ n @^-1` [set r]) z)%:E) = + (fun x : Y => l (c, x) (k_ n @^-1` [set r]))); last first. + apply/funext => y. + by rewrite integral_indic// setIT. +have := measurable_kernel l (k_ n @^-1` [set r]) (measurable_sfunP (k_ n) r). +by move=> /measurable_fun_prod1; exact. +Qed. -End star_is_sfinite_kernel. -End STAR_IS_SFINITE_KERNEL. -HB.export STAR_IS_SFINITE_KERNEL. +Section integral_kcomp. -Lemma lemma3_indic d d' d3 (R : realType) (X : measurableType d) - (Y : measurableType d') (Z : measurableType d3) - (k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z) - (l : sfinite_kernel R X Y) x (E : set _) (mE : measurable E) : - \int[mstar k l x]_z (\1_E z)%:E = \int[l x]_y (\int[k (x, y)]_z (\1_E z)%:E). +Let integral_kcomp_indic d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) + x (E : set _) (mE : measurable E) : + \int[(l \; k) x]_z (\1_E z)%:E = \int[l x]_y (\int[k (x, y)]_z (\1_E z)%:E). Proof. -rewrite integral_indic// /mstar/= /star/=. +rewrite integral_indic//= /kcomp. by apply eq_integral => y _; rewrite integral_indic. Qed. -Lemma lemma3_nnsfun d d' d3 (R : realType) (X : measurableType d) - (Y : measurableType d') (Z : measurableType d3) - (k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z) - (l : sfinite_kernel R X Y) x (f : {nnsfun Z >-> R}) : - \int[mstar k l x]_z (f z)%:E = \int[l x]_y (\int[k (x, y)]_z (f z)%:E). +Let integral_kcomp_nnsfun d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) + x (f : {nnsfun Z >-> R}) : + \int[(l \; k) x]_z (f z)%:E = \int[l x]_y (\int[k (x, y)]_z (f z)%:E). Proof. under [in LHS]eq_integral do rewrite fimfunE -sumEFin. rewrite ge0_integral_sum//; last 2 first. @@ -887,37 +954,35 @@ under [in RHS]eq_integral. over. over. rewrite /= ge0_integral_sum//; last 2 first. - move=> r; apply: measurable_funeM. - have := @kernelP _ _ _ _ _ k (f @^-1` [set r]) (measurable_sfunP f r). - by move/measurable_fun_prod1; exact. - move=> n y _. - have := @mulem_ge0 _ _ _ (k (x, y)) n (fun n => f @^-1` [set n]). - apply. - exact: preimage_nnfun0. + - move=> r; apply: measurable_funeM. + have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). + by move=> /measurable_fun_prod1; exact. + - move=> n y _. + have := @mulem_ge0 _ _ _ (k (x, y)) n (fun n => f @^-1` [set n]). + by apply; exact: preimage_nnfun0. apply eq_bigr => r _. rewrite (@integralM_indic _ _ _ _ _ _ (fun r => f @^-1` [set r]))//; last first. exact: preimage_nnfun0. -rewrite /= lemma3_indic; last exact/measurable_sfunP. +rewrite /= integral_kcomp_indic; last exact/measurable_sfunP. rewrite (@integralM_0ifneg _ _ _ _ _ _ (fun r t => k (x, t) (f @^-1` [set r])))//; last 2 first. move=> r0. apply/funext => y. by rewrite preimage_nnfun0// measure0. - have := @kernelP _ _ _ _ _ k (f @^-1` [set r]) (measurable_sfunP f r). + have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). by move/measurable_fun_prod1; exact. -congr (_ * _). -apply eq_integral => y _. +congr (_ * _); apply eq_integral => y _. by rewrite integral_indic// setIT. Qed. -Lemma lemma3 d d' d3 (R : realType) (X : measurableType d) - (Y : measurableType d') (Z : measurableType d3) - (k : sfinite_kernel R [the measurableType _ of (X * Y)%type] Z) - (l : sfinite_kernel R X Y) x f : (forall z, 0 <= f z) -> measurable_fun setT f -> - \int[mstar k l x]_z f z = \int[l x]_y (\int[k (x, y)]_z f z). +Lemma integral_kcomp d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) + x f : (forall z, 0 <= f z) -> measurable_fun setT f -> + \int[(l \; k) x]_z f z = \int[l x]_y (\int[k (x, y)]_z f z). Proof. move=> f0 mf. have [f_ [ndf_ f_f]] := approximation measurableT mf (fun z _ => f0 z). -transitivity (\int[mstar k l x]_z (lim (EFin \o (f_^~ z)))). +transitivity (\int[(l \; k) x]_z (lim (EFin \o (f_^~ z)))). apply/eq_integral => z _. apply/esym/cvg_lim => //=. exact: f_f. @@ -926,11 +991,11 @@ rewrite monotone_convergence//; last 3 first. by move=> n z _; rewrite lee_fin. by move=> z _ a b /ndf_ /lefP ab; rewrite lee_fin. rewrite (_ : (fun _ => _) = (fun n => \int[l x]_y (\int[k (x, y)]_z (f_ n z)%:E)))//; last first. - by apply/funext => n; rewrite lemma3_nnsfun. + by apply/funext => n; rewrite integral_kcomp_nnsfun. transitivity (\int[l x]_y lim (fun n => \int[k (x, y)]_z (f_ n z)%:E)). rewrite -monotone_convergence//; last 3 first. move=> n. - apply: pollard_sfinite => //. + apply: measurable_fun_integral_sfinite_kernel_prod => //. - by move=> z; rewrite lee_fin. - by apply/EFin_measurable_fun. - move=> n y _. @@ -953,153 +1018,11 @@ apply/cvg_lim => //. exact: f_f. Qed. -Canonical unit_pointedType := PointedType unit tt. - -Section discrete_measurable_unit. - -Definition discrete_measurable_unit : set (set unit) := [set: set unit]. - -Let discrete_measurable0 : discrete_measurable_unit set0. Proof. by []. Qed. - -Let discrete_measurableC X : discrete_measurable_unit X -> discrete_measurable_unit (~` X). -Proof. by []. Qed. - -Let discrete_measurableU (F : (set unit)^nat) : - (forall i, discrete_measurable_unit (F i)) -> discrete_measurable_unit (\bigcup_i F i). -Proof. by []. Qed. - -HB.instance Definition _ := @isMeasurable.Build default_measure_display unit (Pointed.class _) - discrete_measurable_unit discrete_measurable0 discrete_measurableC - discrete_measurableU. - -End discrete_measurable_unit. - -Section discrete_measurable_bool. - -Definition discrete_measurable_bool : set (set bool) := [set: set bool]. - -Let discrete_measurable0 : discrete_measurable_bool set0. Proof. by []. Qed. - -Let discrete_measurableC X : - discrete_measurable_bool X -> discrete_measurable_bool (~` X). -Proof. by []. Qed. - -Let discrete_measurableU (F : (set bool)^nat) : - (forall i, discrete_measurable_bool (F i)) -> - discrete_measurable_bool (\bigcup_i F i). -Proof. by []. Qed. - -HB.instance Definition _ := @isMeasurable.Build default_measure_display bool (Pointed.class _) - discrete_measurable_bool discrete_measurable0 discrete_measurableC - discrete_measurableU. - -End discrete_measurable_bool. - -Section nonneg_constants. -Variable R : realType. -(* -Let twoseven_proof : (0 <= 2 / 7 :> R)%R. -Proof. by rewrite divr_ge0// ler0n. Qed. -*) - -(* Check (2%:R / 7%:R)%:nng. *) - -(* Definition twoseven : {nonneg R} := (2%:R / 7%:R)%:nng. *) -(* -Let fiveseven_proof : (0 <= 5 / 7 :> R)%R. -Proof. by rewrite divr_ge0// ler0n. Qed. - -Definition fiveseven : {nonneg R} := NngNum fiveseven_proof. - *) - -End nonneg_constants. - -Lemma measure_diract_setT_true (R : realType) : - [the measure _ _ of dirac true] [set: bool] = 1 :> \bar R. -Proof. by rewrite /= diracE in_setT. Qed. - -Lemma measure_diract_setT_false (R : realType) : - [the measure _ _ of dirac false] [set: bool] = 1 :> \bar R. -Proof. by rewrite /= diracE in_setT. Qed. - -Section bernoulli27. -Variable R : realType. - -Local Open Scope ring_scope. -Notation "'2/7'" := (2%:R / 7%:R)%:nng. -Definition twoseven : {nonneg R} := (2%:R / 7%:R)%:nng. -Definition fiveseven : {nonneg R} := (5%:R / 7%:R)%:nng. - -Definition bernoulli27 : set _ -> \bar R := - measure_add - [the measure _ _ of mscale twoseven [the measure _ _ of dirac true]] - [the measure _ _ of mscale fiveseven [the measure _ _ of dirac false]]. - -HB.instance Definition _ := Measure.on bernoulli27. - -Local Close Scope ring_scope. - -Lemma bernoulli27_setT : bernoulli27 [set: _] = 1. -Proof. -rewrite /bernoulli27/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. -rewrite /mscale/= !diracE !in_setT !mule1 -EFinD. -by rewrite -mulrDl -natrD divrr// unitfE pnatr_eq0. -Qed. - -HB.instance Definition _ := @isProbability.Build _ _ R bernoulli27 bernoulli27_setT. +End integral_kcomp. -End bernoulli27. - -Section kernel_from_mzero. -Variables (d : measure_display) (T : measurableType d) (R : realType). -Variables (d' : measure_display) (T' : measurableType d'). - -Definition kernel_from_mzero : T' -> {measure set T -> \bar R} := - fun _ : T' => [the measure _ _ of mzero]. - -Lemma kernel_from_mzeroP : forall U, measurable U -> - measurable_fun setT (kernel_from_mzero ^~ U). -Proof. by move=> U mU/=; exact: measurable_fun_cst. Qed. - -HB.instance Definition _ := - @isKernel.Build d' d R T' T kernel_from_mzero - kernel_from_mzeroP. - -Lemma kernel_from_mzero_uub : kernel_uub kernel_from_mzero. -Proof. -exists (PosNum ltr01) => /= t. -by rewrite /mzero/=. -Qed. - -HB.instance Definition _ := - @isFiniteKernel.Build d' d R _ T kernel_from_mzero - kernel_from_mzero_uub. - -End kernel_from_mzero. - -(* a finite kernel is always an s-finite kernel *) -Lemma finite_kernel_sfinite_kernelP (d : measure_display) - (R : realType) (X : measurableType d) (d' : measure_display) (T : measurableType d') - (k : finite_kernel R T X) : - exists k_ : (finite_kernel R _ _)^nat, forall x U, measurable U -> - k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. -exists (fun n => if n is O then - k - else - [the finite_kernel _ _ _ of @kernel_from_mzero _ X R _ T] - ). -move=> t U mU/=. -rewrite /mseries. -rewrite (nneseries_split 1%N)// big_ord_recl/= big_ord0 adde0. -rewrite ereal_series (@eq_nneseries _ _ (fun=> 0%E)); last first. - by case. -by rewrite nneseries0// adde0. -Qed. - -(* semantics for a sample operation? *) +(* semantics for a sample operation *) Section kernel_probability. -Variables (d : measure_display) (R : realType) (X : measurableType d). +Variables (d : _) (R : realType) (X : measurableType d). Variables (d' : _) (T' : measurableType d'). Variable m : probability X R. @@ -1115,115 +1038,69 @@ exact: measurable_fun_cst. Qed. HB.instance Definition _ := - @isKernel.Build _ d R _ X kernel_probability + @isKernel.Build _ _ _ X R kernel_probability kernel_probabilityP. -Lemma kernel_probability_uub : kernel_uub kernel_probability. +Lemma kernel_probability_uub : measure_uub kernel_probability. Proof. (*NB: shouldn't this work? exists 2%:pos. *) -exists (PosNum (addr_gt0 ltr01 ltr01)) => /= ?. +exists 2%R => /= ?. rewrite (le_lt_trans (probability_le1 m measurableT))//. by rewrite lte_fin ltr_addr. Qed. HB.instance Definition _ := - @isFiniteKernel.Build _ d R _ X kernel_probability + @isFiniteKernel.Build _ _ _ X R kernel_probability kernel_probability_uub. -Lemma kernel_probability_sfinite_kernelP : exists k_ : (finite_kernel R _ _)^nat, +Lemma sfinite_kernel_probability : exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> kernel_probability x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. exact: finite_kernel_sfinite_kernelP. Qed. +Proof. exact: sfinite_finite. Qed. HB.instance Definition _ := - @isSFiniteKernel.Build _ d R _ X kernel_probability - kernel_probability_sfinite_kernelP. + @isSFiniteKernel.Build _ _ _ X R kernel_probability + sfinite_kernel_probability. End kernel_probability. -(* semantics for return? *) -Section kernel_dirac. -Variables (R : realType) (d : _) (T : measurableType d). - -Definition kernel_dirac : T -> {measure set T -> \bar R} := - fun x => [the measure _ _ of dirac x]. - -Lemma kernel_diracP U : measurable U -> measurable_fun setT (kernel_dirac ^~ U). -Proof. -move=> mU; apply/EFin_measurable_fun. -by rewrite [X in measurable_fun _ X](_ : _ = mindic R mU). -Qed. - -HB.instance Definition _ := isKernel.Build _ _ R _ _ kernel_dirac kernel_diracP. - -Lemma kernel_dirac_uub : kernel_uub kernel_dirac. -Proof. -exists (PosNum (addr_gt0 ltr01 ltr01)) => t/=. -by rewrite diracE in_setT lte_fin ltr_addr. -Qed. - -HB.instance Definition _ := - @isFiniteKernel.Build d d R _ T kernel_dirac kernel_dirac_uub. - -Lemma kernel_dirac_sfinite_kernelP : exists k_ : (finite_kernel R _ _)^nat, - forall x U, measurable U -> - kernel_dirac x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. exact: finite_kernel_sfinite_kernelP. Qed. - -HB.instance Definition _ := - @isSFiniteKernel.Build d d R T T kernel_dirac kernel_dirac_sfinite_kernelP. - -End kernel_dirac. - -Section kernel_dirac2. -Variables (R : realType) (d d' : _) (T : measurableType d) (T' : measurableType d'). -Variable (f : T -> T'). +Section kernel_of_mfun. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (f : T -> T'). -Definition kernel_dirac2 (mf : measurable_fun setT f) : T -> {measure set T' -> \bar R} := - fun x => [the measure _ _ of dirac (f x)]. +Definition kernel_mfun (mf : measurable_fun setT f) : T -> {measure set T' -> \bar R} := + fun t => [the measure _ _ of dirac (f t)]. -Variable (mf : measurable_fun setT f). +Hypothesis mf : measurable_fun setT f. -Lemma kernel_dirac2P U : measurable U -> measurable_fun setT (kernel_dirac2 mf ^~ U). +Lemma measurable_kernel_mfun U : measurable U -> measurable_fun setT (kernel_mfun mf ^~ U). Proof. -move=> mU; apply/EFin_measurable_fun. -have mTU : measurable (f @^-1` U). - have := mf measurableT mU. - by rewrite setTI. -by rewrite [X in measurable_fun _ X](_ : _ = mindic R mTU). +move=> mU. +apply/EFin_measurable_fun. +rewrite (_ : (fun x => _) = mindic R mU \o f)//. +exact/measurable_fun_comp. Qed. -HB.instance Definition _ := - isKernel.Build _ _ R _ _ (kernel_dirac2 mf) kernel_dirac2P. +HB.instance Definition _ := isKernel.Build _ _ _ _ R (kernel_mfun mf) + measurable_kernel_mfun. -Lemma kernel_dirac2_uub : kernel_uub (kernel_dirac2 mf). -Proof. -exists (PosNum (addr_gt0 ltr01 ltr01)) => t/=. -by rewrite diracE in_setT lte_fin ltr_addr. -Qed. +Lemma kernel_mfun_uub : measure_uub (kernel_mfun mf). +Proof. by exists 2%R => t/=; rewrite diracE in_setT lte_fin ltr_addr. Qed. -HB.instance Definition _ := - @isFiniteKernel.Build _ _ R _ _ (kernel_dirac2 mf) kernel_dirac2_uub. +HB.instance Definition _ := isFiniteKernel.Build _ _ _ _ R (kernel_mfun mf) + kernel_mfun_uub. -Lemma kernel_dirac2_sfinite_kernelP : exists k_ : (finite_kernel R _ _)^nat, - forall x U, measurable U -> - kernel_dirac2 mf x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. exact: finite_kernel_sfinite_kernelP. Qed. +Lemma sfinite_kernel_mfun : exists k_ : (R.-fker _ ~> _)^nat, + forall x U, measurable U -> + kernel_mfun mf x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. exact: sfinite_finite. Qed. HB.instance Definition _ := - @isSFiniteKernel.Build _ _ R _ _ (kernel_dirac2 mf) kernel_dirac2_sfinite_kernelP. - -End kernel_dirac2. - -Definition letin (d d' d3 : measure_display) (R : realType) - (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) - (l : sfinite_kernel R X Y) - (k : sfinite_kernel R [the measurableType (d, d').-prod of (X * Y)%type] Z) - : sfinite_kernel R X Z := - [the sfinite_kernel _ _ _ of @mstar d d' d3 R X Y Z k l]. + @isSFiniteKernel.Build _ _ _ _ _ (kernel_mfun mf) sfinite_kernel_mfun. -(* semantics for score? *) +End kernel_of_mfun. +(* semantics for score *) Lemma set_unit (A : set unit) : A = set0 \/ A = setT. Proof. have [->|/set0P[[] Att]] := eqVneq A set0; [by left|right]. @@ -1231,17 +1108,19 @@ by apply/seteqP; split => [|] []. Qed. Section score_measure. -Variables (R : realType). +Variables (R : realType) (d : _) (T : measurableType d). +Variables (r : T -> R) (mr : measurable_fun setT r). -Definition mscore (r : R) (U : set unit) : \bar R := if U == set0 then 0 else `| r%:E |. +Definition mscore (t : T) (U : set unit) : \bar R := + if U == set0 then 0 else `| (r t)%:E |. -Lemma mscore0 r : mscore r (set0 : set unit) = 0 :> \bar R. +Lemma mscore0 t : mscore t (set0 : set unit) = 0 :> \bar R. Proof. by rewrite /mscore eqxx. Qed. -Lemma mscore_ge0 r U : 0 <= mscore r U. +Lemma mscore_ge0 t U : 0 <= mscore t U. Proof. by rewrite /mscore; case: ifP. Qed. -Lemma mscore_sigma_additive r : semi_sigma_additive (mscore r). +Lemma mscore_sigma_additive t : semi_sigma_additive (mscore t). Proof. move=> /= F mF tF mUF; rewrite /mscore; case: ifPn => [/eqP/bigcup0P F0|]. rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. @@ -1250,7 +1129,7 @@ move=> /= F mF tF mUF; rewrite /mscore; case: ifPn => [/eqP/bigcup0P F0|]. by rewrite big1. move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. rewrite -(cvg_shiftn k.+1)/=. -rewrite (_ : (fun _ => _) = cst `|r%:E|); first exact: cvg_cst. +rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. apply/funext => n. rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. rewrite (negbTE Fk0) big1 ?adde0// => i/= ik; rewrite ifT//. @@ -1259,36 +1138,32 @@ move/trivIsetP : tF => /(_ i k Logic.I Logic.I ik). by rewrite Fitt setTI => /eqP; rewrite (negbTE Fk0). Qed. -HB.instance Definition _ (r : R) := isMeasure.Build _ _ _ - (mscore r) (mscore0 r) (mscore_ge0 r) (@mscore_sigma_additive r). +HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ + (mscore t) (mscore0 t) (mscore_ge0 t) (@mscore_sigma_additive t). End score_measure. -(* NB: score r = observe 0 from exp r, - the density of the exponential distribution exp(r) at 0 is r = r e^(-r * 0) - more generally, score (r e^(-r * t)) = observe t from exp(r), - score (f(r)) = observe r from p where f is the density of p - -*) - Module KERNEL_SCORE. Section kernel_score. -Variable (R : realType) (d : _) (T : measurableType d). +Variables (R : realType) (d : _) (T : measurableType d). +Variables (r : T -> R). -Definition k_' (r : R) (i : nat) : T -> set unit -> \bar R := - fun _ U => - if i%:R%:E <= mscore r U < i.+1%:R%:E then - mscore r U +Definition k_' (mr : measurable_fun setT r) (i : nat) : T -> set unit -> \bar R := + fun t U => + if i%:R%:E <= mscore r t U < i.+1%:R%:E then + mscore r t U else 0. -Lemma k_'0 (r : R) i (t : T) : k_' r i t (set0 : set unit) = 0 :> \bar R. +Variable (mr : measurable_fun setT r). + +Lemma k_'0 i (t : T) : k_' mr i t (set0 : set unit) = 0 :> \bar R. Proof. by rewrite /k_' measure0; case: ifP. Qed. -Lemma k_'ge0 (r : R) i (t : T) B : 0 <= k_' r i t B. +Lemma k_'ge0 i (t : T) B : 0 <= k_' mr i t B. Proof. by rewrite /k_'; case: ifP. Qed. -Lemma k_'sigma_additive (r : R) i (t : T) : semi_sigma_additive (k_' r i t). +Lemma k_'sigma_additive i (t : T) : semi_sigma_additive (k_' mr i t). Proof. move=> /= F mF tF mUF. rewrite /k_' /=. @@ -1304,7 +1179,7 @@ move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. rewrite [in X in _ --> X]/mscore (negbTE UF0). rewrite -(cvg_shiftn k.+1)/=. case: ifPn => ir. - rewrite (_ : (fun _ => _) = cst `|r%:E|); first exact: cvg_cst. + rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. apply/funext => n. rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. rewrite [in X in X + _]/mscore (negbTE Fk0) ir big1 ?adde0// => /= j jk. @@ -1329,225 +1204,328 @@ rewrite Fj0 eqxx. by case: ifP. Qed. -HB.instance Definition _ (r : R) (i : nat) (t : T) := isMeasure.Build _ _ _ - (k_' r i t) (k_'0 r i t) (k_'ge0 r i t) (@k_'sigma_additive r i t). +HB.instance Definition _ (i : nat) (t : T) := isMeasure.Build _ _ _ + (k_' mr i t) (k_'0 i t) (k_'ge0 i t) (@k_'sigma_additive i t). + +Lemma emeasurable_itv (i : nat) : + measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set \bar R). +Proof. +rewrite -[X in measurable X]setCK. +apply: measurableC. +rewrite set_interval.setCitv /=. +apply: measurableU. +exact: emeasurable_itv_ninfty_bnd. +exact: emeasurable_itv_bnd_pinfty. +Qed. -Lemma k_kernelP (r : R) (i : nat) : forall U, measurable U -> measurable_fun setT (k_' r i ^~ U). +Lemma k_kernelP (i : nat) : forall U, measurable U -> measurable_fun setT (k_' mr i ^~ U). Proof. move=> /= U mU. -rewrite /k_'. -by case: ifPn => _; exact: measurable_fun_cst. +rewrite /k_' /=. +rewrite (_ : (fun x : T => _) = (fun x => if (i%:R)%:E <= x < (i.+1%:R)%:E then x else 0) \o (fun x => mscore r x U)) //. +apply: measurable_fun_comp; last first. + rewrite /mscore. + have [U0|U0] := eqVneq U set0. + exact: measurable_fun_cst. + apply: measurable_fun_comp => //. + by apply/EFin_measurable_fun. +rewrite /=. +pose A : _ -> \bar R := (fun x : \bar R => x * (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set (\bar R)) x)%:E). +rewrite (_ : (fun x => _) = A); last first. + apply/funext => x; rewrite /A; case: ifPn => ix. + by rewrite indicE/= mem_set ?mule1//. + rewrite indicE/= memNset ?mule0//. + rewrite /= in_itv/=. + exact/negP. +rewrite /A. +apply emeasurable_funM => /=. + exact: measurable_fun_id. +apply/EFin_measurable_fun. +have mi : measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set (\bar R)). + exact: emeasurable_itv. +by rewrite (_ : \1__ = mindic R mi)//. Qed. -Definition mk_' (r : R) i (t : T) := [the measure _ _ of k_' r i t]. +Definition mk_' i (t : T) := [the measure _ _ of k_' mr i t]. -HB.instance Definition _ (r : R) (i : nat) := - isKernel.Build _ _ R _ _ (mk_' r i) (k_kernelP r i). +HB.instance Definition _ (i : nat) := + isKernel.Build _ _ _ _ R (mk_' i) (k_kernelP i). -Lemma k_uub (r : R) (i : nat) : kernel_uub (mk_' r i). +Lemma k_uub (i : nat) : measure_uub (mk_' i). Proof. -exists (PosNum (ltr0Sn _ i)) => /= t. +exists i.+1%:R => /= t. rewrite /k_' /mscore setT_unit. rewrite (_ : [set tt] == set0 = false); last first. by apply/eqP => /seteqP[] /(_ tt) /(_ erefl). by case: ifPn => // /andP[]. Qed. -HB.instance Definition _ (r : R) (i : nat) := - @isFiniteKernel.Build _ _ R _ _ (mk_' r i) (k_uub r i). +HB.instance Definition _ (i : nat) := + @isFiniteKernel.Build _ _ _ _ R (mk_' i) (k_uub i). End kernel_score. End KERNEL_SCORE. Section kernel_score_kernel. Variables (R : realType) (d : _) (T : measurableType d). +Variables (r : T -> R). -Definition kernel_score (r : R) : T -> {measure set _ -> \bar R} := - fun _ : T => [the measure _ _ of mscore r]. +Definition kernel_score (mr : measurable_fun setT r) : T -> {measure set Datatypes_unit__canonical__measure_Measurable -> \bar R} := + fun t : T => [the measure _ _ of mscore r t]. -Lemma kernel_scoreP (r : R) : forall U, measurable U -> - measurable_fun setT (kernel_score r ^~ U). +Variable (mr : measurable_fun setT r). + +Lemma kernel_scoreP : forall U, measurable U -> + measurable_fun setT (kernel_score mr ^~ U). Proof. -move=> /= U mU; rewrite /mscore; case: ifP => U0. +move=> /= U mU. +rewrite /mscore. +have [U0|U0] := eqVneq U set0. exact: measurable_fun_cst. apply: measurable_fun_comp => //. -apply/EFin_measurable_fun. -exact: measurable_fun_cst. +by apply/EFin_measurable_fun. Qed. -HB.instance Definition _ (r : R) := - isKernel.Build _ _ R T - _ (*Datatypes_unit__canonical__measure_Measurable*) - (kernel_score r) (kernel_scoreP r). +HB.instance Definition _ := + isKernel.Build _ _ T + _ (*Datatypes_unit__canonical__measure_Measurable*) R + (kernel_score mr) (kernel_scoreP). End kernel_score_kernel. Section kernel_score_sfinite_kernel. Variables (R : realType) (d : _) (T : measurableType d). +Variables (r : T -> R) (mr : measurable_fun setT r). Import KERNEL_SCORE. -Lemma kernel_score_sfinite_kernelP (r : R) : exists k_ : (finite_kernel R T _)^nat, +Lemma kernel_score_sfinite_kernelP : exists k_ : (R.-fker T ~> _)^nat, forall x U, measurable U -> - kernel_score r x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. + kernel_score mr x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. Proof. -exists (fun i => [the finite_kernel _ _ _ of mk_' r i]) => /= r' U mU. +rewrite /=. +exists (fun i => [the finite_kernel _ _ _ of mk_' mr i]) => /= r' U mU. rewrite /mseries /mscore; case: ifPn => [/eqP U0|U0]. by apply/esym/nneseries0 => i _; rewrite U0 measure0. rewrite /mk_' /= /k_' /= /mscore (negbTE U0). apply/esym/cvg_lim => //. -rewrite -(cvg_shiftn `|floor (fine `|r%:E|)|%N.+1)/=. -rewrite (_ : (fun _ => _) = cst `|r%:E|); first exact: cvg_cst. +rewrite -(cvg_shiftn `|floor (fine `|(r r')%:E|)|%N.+1)/=. +rewrite (_ : (fun _ => _) = cst `|(r r')%:E|); first exact: cvg_cst. apply/funext => n. -pose floor_r := widen_ord (leq_addl n `|floor `|r| |.+1) (Ordinal (ltnSn `|floor `|r| |)). +pose floor_r := widen_ord (leq_addl n `|floor `|(r r')| |.+1) (Ordinal (ltnSn `|floor `|(r r')| |)). rewrite big_mkord (bigD1 floor_r)//= ifT; last first. rewrite lee_fin lte_fin; apply/andP; split. - by rewrite natr_absz (@ger0_norm _ (floor `|r|)) ?floor_ge0 ?floor_le. - by rewrite -addn1 natrD natr_absz (@ger0_norm _ (floor `|r|)) ?floor_ge0 ?lt_succ_floor. + by rewrite natr_absz (@ger0_norm _ (floor `|(r r')|)) ?floor_ge0 ?floor_le. + by rewrite -addn1 natrD natr_absz (@ger0_norm _ (floor `|(r r')|)) ?floor_ge0 ?lt_succ_floor. rewrite big1 ?adde0//= => j jk. rewrite ifF// lte_fin lee_fin. move: jk; rewrite neq_ltn/= => /orP[|] jr. -- suff : (j.+1%:R <= `|r|)%R by rewrite leNgt => /negbTE ->; rewrite andbF. +- suff : (j.+1%:R <= `|(r r')|)%R by rewrite leNgt => /negbTE ->; rewrite andbF. rewrite (_ : j.+1%:R = j.+1%:~R)// floor_ge_int. move: jr; rewrite -lez_nat => /le_trans; apply. - by rewrite -[leRHS](@ger0_norm _ (floor `|r|)) ?floor_ge0. -- suff : (`|r| < j%:R)%R by rewrite ltNge => /negbTE ->. - move: jr; rewrite -ltz_nat -(@ltr_int R) (@gez0_abs (floor `|r|)) ?floor_ge0// ltr_int. + by rewrite -[leRHS](@ger0_norm _ (floor `|(r r')|)) ?floor_ge0. +- suff : (`|(r r')| < j%:R)%R by rewrite ltNge => /negbTE ->. + move: jr; rewrite -ltz_nat -(@ltr_int R) (@gez0_abs (floor `|(r r')|)) ?floor_ge0// ltr_int. by rewrite -floor_lt_int. Qed. -HB.instance Definition _ (r : R) := @isSFiniteKernel.Build _ _ _ _ _ - (kernel_score r) (kernel_score_sfinite_kernelP r). +HB.instance Definition _ := @isSFiniteKernel.Build _ _ _ _ _ + (kernel_score mr) (kernel_score_sfinite_kernelP). End kernel_score_sfinite_kernel. -Section ite. +Section ite_true_kernel. Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables - (u1 : sfinite_kernel R - [the measurableType _ of (T * bool)%type] - [the measurableType _ of T']) - (u2 : sfinite_kernel R - [the measurableType _ of (T * bool)%type] - [the measurableType _ of T']). - -Definition ite : T * bool -> set _ -> \bar R := - fun t => if t.2 then u1 t else u2 t. +Variables (u1 : R.-ker T ~> T'). -Lemma ite0 tb : ite tb set0 = 0. -Proof. by rewrite /ite; case: ifPn => //. Qed. +Definition ite_true : T * bool -> {measure set T' -> \bar R} := + fun b => if b.2 then u1 b.1 else [the measure _ _ of mzero]. -Lemma ite_ge0 tb (U : set _) : 0 <= ite tb U. -Proof. by rewrite /ite; case: ifPn => //. Qed. - -Lemma ite_sigma_additive tb : semi_sigma_additive (ite tb). +Lemma measurable_ite_true U : measurable U -> measurable_fun setT (ite_true ^~ U). Proof. -Admitted. +move=> /= mcU. +rewrite /ite_true. +rewrite (_ : (fun x : T * bool => _) = (fun x => if x.2 then u1 x.1 U else [the {measure set T' -> \bar R} of mzero] U)); last first. + apply/funext => -[t b]/=. + by case: ifPn. +apply: (@measurable_fun_if _ _ _ _ (u1 ^~ U) (fun=> mzero U)). + exact/measurable_kernel. +exact: measurable_fun_cst. +Qed. -HB.instance Definition _ tb := isMeasure.Build _ _ _ - (ite tb) - (ite0 tb) (ite_ge0 tb) (@ite_sigma_additive tb). +HB.instance Definition _ := isKernel.Build _ _ _ _ R ite_true measurable_ite_true. +End ite_true_kernel. -Lemma ite_kernelP : forall U, measurable U -> measurable_fun setT (ite ^~ U). -Admitted. +Section ite_true_finite_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (u1 : R.-fker T ~> T'). + +Lemma ite_true_uub : measure_uub (ite_true u1). +Proof. +have /measure_uubP[M hM] := kernel_uub u1. +exists M%:num => /= -[]; rewrite /ite_true => t [|]/=. + exact: hM. +by rewrite /= /mzero. +Qed. -Definition mite tb := [the measure _ _ of ite tb]. +HB.instance Definition _ t := + isFiniteKernel.Build _ _ _ _ R (ite_true u1) ite_true_uub. +End ite_true_finite_kernel. -HB.instance Definition _ := isKernel.Build _ _ R _ _ mite ite_kernelP. +Section ite_true_sfinite_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (u1 : R.-sfker T ~> T'). -Lemma ite_sfinite_kernelP : exists k_ : (finite_kernel R _ _)^nat, - forall x U, measurable U -> - ite x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Admitted. +Lemma sfinite_ite_true : exists k_ : (R.-fker _ ~> _)^nat, + forall x U, measurable U -> + ite_true u1 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. +have [k hk /=] := sfinite u1. +rewrite /ite_true. +exists (fun n => [the finite_kernel _ _ _ of ite_true (k n)]) => b U mU. +case: ifPn => hb. + rewrite /mseries hk//= /mseries. + apply: eq_nneseries => n _. + by rewrite /ite_true hb. +rewrite /= /mseries nneseries0// => n _. +by rewrite /ite_true (negbTE hb). +Qed. -HB.instance Definition _ := - @isSFiniteKernel.Build _ _ _ _ _ mite ite_sfinite_kernelP. +HB.instance Definition _ t := + @isSFiniteKernel.Build _ _ _ _ _ (ite_true u1) sfinite_ite_true. -End ite. +End ite_true_sfinite_kernel. -Section insn. -Variables (R : realType). +Section ite_false_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (u2 : R.-ker T ~> T'). -Definition sample_bernoulli27 (d : _) (T : measurableType d) := - [the sfinite_kernel _ T _ of - kernel_probability [the probability _ _ of bernoulli27 R]] . +Definition ite_false : T * bool -> {measure set T' -> \bar R} := + fun b => if ~~ b.2 then u2 b.1 else [the measure _ _ of mzero]. -Definition Ite (d d' : _) (T : measurableType d) (T' : measurableType d') - (u1 : sfinite_kernel R [the measurableType _ of (T * bool)%type] - [the measurableType _ of T']) - (u2 : sfinite_kernel R [the measurableType _ of (T * bool)%type] - [the measurableType _ of T']) - : sfinite_kernel R [the measurableType _ of (T * bool)%type] _ := - [the sfinite_kernel R _ _ of mite u1 u2]. +Lemma measurable_ite_false U : measurable U -> measurable_fun setT (ite_false ^~ U). +Proof. +move=> /= mcU. +rewrite /ite_false. +rewrite (_ : (fun x => _) = (fun x => if x.2 then [the {measure set T' -> \bar R} of mzero] U else u2 x.1 U)); last first. + apply/funext => -[t b]/=. + rewrite if_neg/=. + by case: b. +apply: (@measurable_fun_if _ _ _ _ (fun=> mzero U) (u2 ^~ U)). + exact: measurable_fun_cst. +exact/measurable_kernel. +Qed. -Definition Return (d : _) (T : measurableType d) : sfinite_kernel R T T := - [the sfinite_kernel _ _ _ of @kernel_dirac R _ _]. +HB.instance Definition _ := isKernel.Build _ _ _ _ R ite_false measurable_ite_false. -Definition Return2 (d d' : _) (T : measurableType d) (T' : measurableType d') - (f : T -> T') (mf : measurable_fun setT f) : sfinite_kernel R T T' := - [the sfinite_kernel _ _ _ of @kernel_dirac2 R _ _ T T' f mf]. +End ite_false_kernel. -Definition Score (d : _) (T : measurableType d) (r : R) : - sfinite_kernel R T Datatypes_unit__canonical__measure_Measurable := - [the sfinite_kernel R _ _ of @kernel_score R _ _ r]. +Section ite_false_finite_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (u2 : R.-fker T ~> T'). -End insn. +Lemma ite_false_uub : measure_uub (ite_false u2). +Proof. +have /measure_uubP[M hM] := kernel_uub u2. +exists M%:num => /= -[]; rewrite /ite_false/= => t b. +case: b => //=. +by rewrite /mzero. +Qed. -Section program1. -Variables (R : realType) (d : _) (T : measurableType d). +HB.instance Definition _ := + isFiniteKernel.Build _ _ _ _ R (ite_false u2) ite_false_uub. -Lemma measurable_fun_snd : measurable_fun setT (snd : T * bool -> bool). Admitted. +End ite_false_finite_kernel. -Definition program1 : sfinite_kernel R T - _ := - letin - (sample_bernoulli27 R T) (* T -> B *) - (Return2 R measurable_fun_snd) (* T * B -> B *). +Section ite_false_sfinite_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (u2 : R.-sfker T ~> T'). -Lemma program1E (t : T) (U : _) : program1 t U = - ((twoseven R)%:num)%:E * \d_true U + - ((fiveseven R)%:num)%:E * \d_false U. +Lemma sfinite_ite_false : exists k_ : (R.-fker _ ~> _)^nat, + forall x U, measurable U -> + ite_false u2 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. Proof. -rewrite /program1/= /star/=. -rewrite ge0_integral_measure_sum// 2!big_ord_recl/= big_ord0 adde0/=. -rewrite !ge0_integral_mscale//=. -rewrite !integral_dirac//=. -by rewrite indicE in_setT mul1e indicE in_setT mul1e. +have [k hk] := sfinite u2. +rewrite /= /ite_false. +exists (fun n => [the finite_kernel _ _ _ of ite_false (k n)]) => b U mU. +case: ifPn => hb. + rewrite /mseries hk//= /mseries/=. + apply: eq_nneseries => // n _. + by rewrite /ite_false hb. +rewrite /= /mseries nneseries0// => n _. +rewrite negbK in hb. +by rewrite /ite_false hb/=. Qed. -End program1. +HB.instance Definition _ := + @isSFiniteKernel.Build _ _ _ _ _ (ite_false u2) sfinite_ite_false. -Section program2. -Variables (R : realType) (d : _) (T : measurableType d). +End ite_false_sfinite_kernel. -Definition program2 : sfinite_kernel R T Datatypes_unit__canonical__measure_Measurable := - letin - (sample_bernoulli27 R T) (* T -> B *) - (Score _ (1%:R : R)). +Section add_of_kernels. +Variables (d d' : measure_display) (R : realType). +Variables (X : measurableType d) (Y : measurableType d'). +Variables (u1 u2 : R.-ker X ~> Y). -End program2. +Definition add_of_kernels : X -> {measure set Y -> \bar R} := + fun t => [the measure _ _ of measure_add (u1 t) (u2 t)]. -Section program3. -Variables (R : realType) (d : _) (T : measurableType d). +Lemma measurable_add_of_kernels U : measurable U -> measurable_fun setT (add_of_kernels ^~ U). +Proof. +move=> mU. +rewrite /add_of_kernels. +rewrite (_ : (fun x : X => _) = (fun x => (u1 x U) + (u2 x U))); last first. + apply/funext => x. + by rewrite -measure_addE. +by apply: emeasurable_funD; exact/measurable_kernel. +Qed. -(* let x = sample (bernoulli (2/7)) in - let r = case x of {(1, _) => return (k3()), (2, _) => return (k10())} in - let _ = score (1/4! r^4 e^-r) in - return x *) +HB.instance Definition _ := + @isKernel.Build _ _ _ _ _ add_of_kernels measurable_add_of_kernels. +End add_of_kernels. -Definition k3' : T * bool -> R := cst 3%:R. -Definition k10' : T * bool -> R := cst 10%:R. +Section add_of_finite_kernels. +Variables (d d' : measure_display) (R : realType). +Variables (X : measurableType d) (Y : measurableType d'). +Variables (u1 u2 : R.-fker X ~> Y). -Lemma mk3 : measurable_fun setT k3'. -exact: measurable_fun_cst. +Lemma add_of_finite_kernels_uub : measure_uub (add_of_kernels u1 u2). +Proof. +have [k1 hk1] := kernel_uub u1. +have [k2 hk2] := kernel_uub u2. +exists (k1 + k2)%R => x. +rewrite /add_of_kernels/=. +rewrite -/(measure_add (u1 x) (u2 x)). +rewrite measure_addE. +rewrite EFinD. +exact: lte_add. Qed. -Lemma mk10 : measurable_fun setT k10'. -exact: measurable_fun_cst. -Qed. +HB.instance Definition _ t := + isFiniteKernel.Build _ _ _ _ R (add_of_kernels u1 u2) add_of_finite_kernels_uub. +End add_of_finite_kernels. + +Section add_of_sfinite_kernels. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (u1 u2 : R.-sfker X ~> Y). -Definition program10 : sfinite_kernel R T _ := - letin - (sample_bernoulli27 R T) (* T -> B *) - (Return2 R mk3). +Lemma sfinite_add_of_kernels : exists k_ : (R.-fker _ ~> _)^nat, + forall x U, measurable U -> + add_of_kernels u1 u2 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. +have [k1 hk1] := sfinite u1. +have [k2 hk2] := sfinite u2. +exists (fun n => [the finite_kernel _ _ _ of add_of_kernels (k1 n) (k2 n)]) => x U mU. +rewrite /add_of_kernels/=. +rewrite -/(measure_add (u1 x) (u2 x)). +rewrite measure_addE. +rewrite /mseries. +rewrite hk1//= hk2//= /mseries. +rewrite -nneseriesD//. +apply: eq_nneseries => n _. +rewrite -/(measure_add (k1 n x) (k2 n x)). +by rewrite measure_addE. +Qed. -End program3. +HB.instance Definition _ t := + isSFiniteKernel.Build _ _ _ _ R (add_of_kernels u1 u2) sfinite_add_of_kernels. +End add_of_sfinite_kernels. diff --git a/theories/lebesgue_integral.v b/theories/lebesgue_integral.v index 96bb978d32..959a041e32 100644 --- a/theories/lebesgue_integral.v +++ b/theories/lebesgue_integral.v @@ -4090,8 +4090,12 @@ Context d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). Implicit Types A : set (T1 * T2). Section xsection. -Variables (pt2 : T2) (m2 : {measure set T2 -> \bar R}). -Let phi A := m2 \o xsection A. +Variables (pt2 : T2) (m2 : T1 -> {measure set T2 -> \bar R}). +(* the generalization from m2 : {measure set T2 -> \bar R}t to + T1 -> {measure set T2 -> \bar R} is needed to develop the theory + of kernels; the original type was sufficient for the the development + of the theory of integration *) +Let phi A x := m2 x (xsection A x). Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. Lemma xsection_ndseq_closed : ndseq_closed B. diff --git a/theories/prob_lang.v b/theories/prob_lang.v new file mode 100644 index 0000000000..375ca61078 --- /dev/null +++ b/theories/prob_lang.v @@ -0,0 +1,357 @@ +From HB Require Import structures. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval finmap. +Require Import mathcomp_extra boolp classical_sets signed functions cardinality. +Require Import reals ereal topology normedtype sequences esum measure. +Require Import lebesgue_measure fsbigop numfun lebesgue_integral kernel. + +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 ite. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). +Variables (R : realType) (f : T -> bool) (u1 u2 : R.-sfker T ~> T'). + +Definition ite (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. + +Lemma ite0 tb : ite mf tb set0 = 0. +Proof. by rewrite /ite; case: ifPn => //. Qed. + +Lemma ite_ge0 tb (U : set _) : 0 <= ite mf tb U. +Proof. by rewrite /ite; case: ifPn => //. Qed. + +Lemma ite_sigma_additive tb : semi_sigma_additive (ite mf tb). +Proof. +rewrite /ite. +case: ifPn => ftb. + exact: measure_semi_sigma_additive. +exact: measure_semi_sigma_additive. +Qed. + +HB.instance Definition _ tb := isMeasure.Build _ _ _ (ite mf tb) + (ite0 tb) (ite_ge0 tb) (@ite_sigma_additive tb). + +Definition ite' : R.-sfker + [the measurableType _ of (T * bool)%type] ~> T' := + [the R.-sfker _ ~> _ of add_of_kernels + [the R.-sfker _ ~> T' of ite_true u1] + [the R.-sfker _ ~> T' of ite_false u2] ]. + +Definition mite := [the sfinite_kernel _ _ _ of kernel_mfun R mf] \; ite'. + +End ite. + +Section bernoulli27. +Variable R : realType. + +Local Open Scope ring_scope. +Notation "'2/7'" := (2%:R / 7%:R)%:nng. +Definition twoseven : {nonneg R} := (2%:R / 7%:R)%:nng. +Definition fiveseven : {nonneg R} := (5%:R / 7%:R)%:nng. + +Definition bernoulli27 : set _ -> \bar R := + measure_add + [the measure _ _ of mscale twoseven [the measure _ _ of dirac true]] + [the measure _ _ of mscale fiveseven [the measure _ _ of dirac false]]. + +HB.instance Definition _ := Measure.on bernoulli27. + +Local Close Scope ring_scope. + +Lemma bernoulli27_setT : bernoulli27 [set: _] = 1. +Proof. +rewrite /bernoulli27/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. +rewrite /mscale/= !diracE !in_setT !mule1 -EFinD. +by rewrite -mulrDl -natrD divrr// unitfE pnatr_eq0. +Qed. + +HB.instance Definition _ := @isProbability.Build _ _ R bernoulli27 bernoulli27_setT. + +End bernoulli27. + +Section insn. +Variables (R : realType). + +Definition letin (d d' d3 : _) + (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) + (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) + : R.-sfker X ~> Z := + [the sfinite_kernel _ _ _ of (l \; k)]. + +Definition Return (d d' : _) (T : measurableType d) (T' : measurableType d') + (f : T -> T') (mf : measurable_fun setT f) : R.-sfker T ~> T' := + [the sfinite_kernel _ _ _ of @kernel_mfun _ _ T T' R f mf]. + +Definition sample_bernoulli27 (d : _) (T : measurableType d) := + [the sfinite_kernel T _ _ of + kernel_probability [the probability _ _ of bernoulli27 R]] . + +(* NB: score r = observe 0 from exp r, + the density of the exponential distribution exp(r) at 0 is r = r e^(-r * 0) + more generally, score (r e^(-r * t)) = observe t from exp(r), + score (f(r)) = observe r from p where f is the density of p *) +Definition Score (d : _) (T : measurableType d) (r : T -> R) (mr : measurable_fun setT r) : + R.-sfker T ~> Datatypes_unit__canonical__measure_Measurable := + [the sfinite_kernel _ _ R of @kernel_score R _ _ r mr]. + +Definition Ite (d d' : _) (T : measurableType d) (T' : measurableType d') + (f : T -> bool) (mf : measurable_fun setT f) + (u1 u2 : R.-sfker T ~> T') + : R.-sfker T ~> T' := + [the R.-sfker _ ~> _ of mite u1 u2 mf]. + +Lemma IteE (d d' : _) (T : measurableType d) (T' : measurableType d') + (f : T -> bool) (mf : measurable_fun setT f) + (u1 u2 : R.-sfker T ~> T') tb U : + Ite mf u1 u2 tb U = ite u1 u2 mf tb U. +Proof. +rewrite /= /kcomp /ite. +rewrite integral_dirac//=. +rewrite indicT /cst. +rewrite mul1e. +rewrite -/(measure_add (ite_true u1 (tb, f tb)) + (ite_false u2 (tb, f tb))). +rewrite measure_addE. +rewrite /ite_true /ite_false/=. +case: (ifPn (f tb)) => /=. + by rewrite /mzero adde0. +by rewrite /mzero add0e. +Qed. + +End insn. + +(* a few laws *) + +Section letin_return. +Variables (d d' d3 : _) (R : realType) (X : measurableType d) + (Y : measurableType d') (Z : measurableType d3). + +Lemma letin_ureturn (u : R.-sfker X ~> Y) + (f : _ -> Z) (mf : measurable_fun setT f) : + forall x U, measurable U -> letin u (Return R mf) x U = u x ((fun y => f (x, y)) @^-1` U). +Proof. +move=> x U mU. +rewrite /letin/= /kcomp/= integral_indic// ?setIT//. +move/measurable_fun_prod1 : mf => /(_ x)/(_ measurableT U mU). +by rewrite setTI. +Qed. + +Lemma letin_returnu + (u : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) + (f : _ -> Y) (mf : measurable_fun setT f) : + forall x U, measurable U -> letin (Return R mf) u x U = u (x, f x) U. +Proof. +move=> x U mU. +rewrite /letin/= /kcomp/= integral_dirac//. + by rewrite indicE mem_set// mul1e. +have /measurable_fun_prod1 := measurable_kernel u _ mU. +exact. +Qed. + +End letin_return. + +Section letin_ite. +Variables (R : realType) (d d2 d3 : _) (T : measurableType d) + (T2 : measurableType d2) (T3 : measurableType d3) + (u1 u2 : R.-sfker T ~> T3) (u : R.-sfker [the measurableType _ of (T * T3)%type] ~> T2) + (f : T -> bool) (mf : measurable_fun setT f) + (t : T) (U : set T2). + +Lemma letin_ite_true : f t -> letin (Ite mf u1 u2) u t U = letin u1 u t U. +Proof. +move=> ftT. +rewrite /letin/= /kcomp. +apply eq_measure_integral => V mV _. +by rewrite IteE /ite ftT. +Qed. + +Lemma letin_ite_false : ~~ f t -> letin (Ite mf u1 u2) u t U = letin u2 u t U. +Proof. +move=> ftF. +rewrite /letin/= /kcomp. +apply eq_measure_integral => V mV _. +by rewrite IteE/= /ite (negbTE ftF). +Qed. + +End letin_ite. + +(* sample programs *) + +Require Import exp. + +Definition poisson (R : realType) (r : R) (k : nat) := (r ^+ k / k%:R^-1 * expR (- r))%R. + +Definition poisson3 (R : realType) := poisson (3%:R : R) 4. (* 0.168 *) +Definition poisson10 (R : realType) := poisson (10%:R : R) 4. (* 0.019 *) + +Lemma poisson_ge0 (R : realType) (r : R) k : (0 <= r)%R -> (0 <= poisson r k)%R. +Proof. +move=> r0; rewrite /poisson mulr_ge0//. + by rewrite mulr_ge0// exprn_ge0//. +by rewrite ltW// expR_gt0. +Qed. + +Lemma mpoisson (R : realType) k : measurable_fun setT (@poisson R ^~ k). +Proof. +apply: measurable_funM => /=. + apply: measurable_funM => //=; last exact: measurable_fun_cst. + exact/measurable_fun_exprn/measurable_fun_id. +apply: measurable_fun_comp. + apply: continuous_measurable_fun. + exact: continuous_expR. +apply: continuous_measurable_fun. +by have := (@opp_continuous R [the normedModType R of R^o]). +Qed. + +Section cst_fun. +Variables (R : realType) (d : _) (T : measurableType d). + +Definition kn (n : nat) := @measurable_fun_cst _ _ T _ setT (n%:R : R). +Definition k3 : measurable_fun _ _ := kn 3. +Definition k10 : measurable_fun _ _ := kn 10. + +End cst_fun. + +Lemma ScoreE (R : realType) (d : _) (T : measurableType d) (t : T) (U : set bool) (n : nat) (b : bool) + (f : R -> R) (f0 : forall r, (0 <= r)%R -> (0 <= f r)%R) (mf : measurable_fun setT f) : + Score (measurable_fun_comp mf (@measurable_fun_snd _ _ _ _)) + (t, b, cst n%:R (t, b)) + ((fun y : unit => (snd \o fst) (t, b, y)) @^-1` U) = + (f n%:R)%:E * \d_b U. +Proof. +rewrite /Score/= /mscore/= diracE. +have [U0|U0] := set_unit ((fun=> b) @^-1` U). +- rewrite U0 eqxx memNset ?mule0//. + move=> Ub. + move: U0. + move/seteqP => [/(_ tt)] /=. + by move/(_ Ub). +- rewrite U0 setT_unit ifF//; last first. + by apply/negbTE/negP => /eqP/seteqP[/(_ tt erefl)]. + rewrite /= mem_set//; last first. + by move: U0 => /seteqP[_]/(_ tt)/=; exact. + by rewrite mule1 ger0_norm// f0. +Qed. + +Lemma letin_sample_bernoulli27 (R : realType) (d d' : _) (T : measurableType d) + (T' : measurableType d') + (u : R.-sfker [the measurableType _ of (T * bool)%type] ~> T') x y : + letin (sample_bernoulli27 R T) u x y = + (2 / 7)%:E * u (x, true) y + (5 / 7)%:E * u (x, false) y. +Proof. +rewrite {1}/letin/= {1}/kcomp/=. +rewrite ge0_integral_measure_sum//. +rewrite 2!big_ord_recl/= big_ord0 adde0/=. +rewrite !ge0_integral_mscale//=. +rewrite !integral_dirac//=. +by rewrite indicE in_setT mul1e indicE in_setT mul1e. +Qed. + +(* *) + +Section program1. +Variables (R : realType) (d : _) (T : measurableType d). + +Definition program1 : R.-sfker T ~> _ := + letin + (sample_bernoulli27 R T) (* T -> B *) + (Return R (@measurable_fun_snd _ _ _ _)) (* T * B -> B *). + +Lemma program1E (t : T) (U : _) : program1 t U = + ((twoseven R)%:num)%:E * \d_true U + + ((fiveseven R)%:num)%:E * \d_false U. +Proof. +rewrite /program1. +by rewrite letin_sample_bernoulli27. +Qed. + +End program1. + +Section program2. +Variables (R : realType) (d : _) (T : measurableType d). + +Definition program2 : R.-sfker T ~> _ := + letin + (sample_bernoulli27 R T) (* T -> B *) + (Score (measurable_fun_cst (1%:R : R))). + +End program2. + +Section program3. +Variables (R : realType) (d : _) (T : measurableType d). + +(* let x = sample (bernoulli (2/7)) in + let r = case x of {(1, _) => return (k3()), (2, _) => return (k10())} in + return r *) + +Definition program3 : + R.-sfker T ~> [the measurableType default_measure_display of Real_sort__canonical__measure_Measurable R] := + letin + (sample_bernoulli27 R T) (* T -> B *) + (Ite (@measurable_fun_snd _ _ _ _) + (Return R (@k3 _ _ [the measurableType _ of (T * bool)%type])) + (Return R (@k10 _ _ [the measurableType _ of (T * bool)%type]))). + +Lemma program3E (t : T) (U : _) : program3 t U = + ((twoseven R)%:num)%:E * \d_(3%:R : R) U + + ((fiveseven R)%:num)%:E * \d_(10%:R : R) U. +Proof. +rewrite /program3 letin_sample_bernoulli27. +congr (_ * _ + _ * _). +by rewrite IteE. +by rewrite IteE. +Qed. + +End program3. + +Section program4. +Variables (R : realType) (d : _) (T : measurableType d). + +(* let x = sample (bernoulli (2/7)) in + let r = case x of {(1, _) => return (k3()), (2, _) => return (k10())} in + let _ = score (1/4! r^4 e^-r) in + return x *) + +Definition program4 : R.-sfker T ~> Datatypes_bool__canonical__measure_Measurable := + letin + (sample_bernoulli27 R T) (* T -> B *) + (letin + (letin (* T * B -> unit *) + (Ite (@measurable_fun_snd _ _ _ _) + (Return R (@k3 _ _ [the measurableType _ of (T * bool)%type])) + (Return R (@k10 _ _ [the measurableType _ of (T * bool)%type]))) (* T * B -> R *) + (Score (measurable_fun_comp (@mpoisson R 4) (@measurable_fun_snd _ _ _ _))) (* B * R -> unit *)) + (Return R (measurable_fun_comp (@measurable_fun_snd _ _ _ _) (@measurable_fun_fst _ _ _ _)))). + +(* 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 program4E (t : T) (U : _) : program4 t U = + ((twoseven R)%:num)%:E * (poisson 3%:R 4)%:E * \d_(true) U + + ((fiveseven R)%:num)%:E * (poisson 10%:R 4)%:E * \d_(false) U. +Proof. +rewrite /program4. +rewrite letin_sample_bernoulli27. +rewrite -!muleA. +congr (_ * _ + _ * _). + rewrite letin_ureturn //. + rewrite letin_ite_true//. + rewrite letin_returnu//. + by rewrite ScoreE// => r r0; exact: poisson_ge0. +rewrite letin_ureturn //. +rewrite letin_ite_false//. +rewrite letin_returnu//. +by rewrite ScoreE// => r r0; exact: poisson_ge0. +Qed. + +End program4. From 709da80a35f343c0157cde0ce60aca714ee28409 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Thu, 18 Aug 2022 20:57:33 +0900 Subject: [PATCH 10/54] factorization of code, normalize, cleaning --- theories/kernel.v | 800 +++++++++++++------------------------------ theories/prob_lang.v | 560 +++++++++++++++++++++++++----- 2 files changed, 720 insertions(+), 640 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 1ea424ee32..266960f527 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -14,8 +14,6 @@ Require Import lebesgue_measure fsbigop numfun lebesgue_integral. (* sum_of_kernels == *) (* l \; k == composition of kernels *) (* kernel_mfun == kernel defined by a measurable function *) -(* mscore == *) -(* ite_true/ite_false == *) (* add_of_kernels == *) (******************************************************************************) @@ -255,10 +253,11 @@ Lemma measurable_curry (T1 T2 : Type) (d : _) (T : semiRingOfSetsType d) measurable (G x) <-> measurable (curry G x.1 x.2). Proof. by case: x. Qed. -Lemma measurable_fun_if (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') : +Lemma measurable_fun_if0 (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') + (f : T -> bool) (mf : measurable_fun setT f) : measurable_fun setT x -> measurable_fun setT y -> - measurable_fun setT (fun b : T * bool => if b.2 then x b.1 else y b.1). + measurable_fun setT (fun b : T => if f b then x b else y b). Proof. move=> mx my /= _ Y mY. rewrite setTI. @@ -266,17 +265,53 @@ have := mx measurableT Y mY. rewrite setTI => xY. have := my measurableT Y mY. rewrite setTI => yY. -rewrite (_ : _ @^-1` Y = (x @^-1` Y) `*` [set true] `|` (y @^-1` Y) `*` [set false]); last first. +rewrite (_ : _ @^-1` Y = ((x @^-1` Y) `&` (f @^-1` [set true])) `|` + ((y @^-1` Y) `&` (f @^-1` [set false]))); last first. apply/seteqP; split. - move=> [t [|]]/=. + move=> t/=; case: ifPn => ft. by left. by right. - move=> [t [|]]/=. - by case=> [[]//|[]]. - by case=> [[]//|[]]. -by apply: measurableU; apply: measurableM => //. + by move=> t/=; case: ifPn => ft; case=> -[]. +apply: measurableU; apply: measurableI => //. + have := mf measurableT [set true]. + by rewrite setTI; exact. +have := mf measurableT [set false]. +by rewrite setTI; exact. +Qed. + +Lemma measurable_fun_if (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') : + measurable_fun setT x -> + measurable_fun setT y -> + measurable_fun setT (fun b : T * bool => if b.2 then x b.1 else y b.1). +Proof. +move=> mx my. +have {}mx : measurable_fun [set: T * bool] (x \o fst). + apply: measurable_fun_comp => //. + exact: measurable_fun_fst. +have {}my : measurable_fun [set: T * bool] (y \o fst). + apply: measurable_fun_comp => //. + exact: measurable_fun_fst. +rewrite /=. +apply: measurable_fun_if0 => //=. +exact: measurable_fun_snd. +Qed. + +Lemma emeasurable_itv (R : realType) (i : nat) : + measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set \bar R). +Proof. +rewrite -[X in measurable X]setCK. +apply: measurableC. +rewrite set_interval.setCitv /=. +apply: measurableU. + exact: emeasurable_itv_ninfty_bnd. +exact: emeasurable_itv_bnd_pinfty. Qed. +Lemma set_unit (A : set unit) : A = set0 \/ A = setT. +Proof. +have [->|/set0P[[] Att]] := eqVneq A set0; [by left|right]. +by apply/seteqP; split => [|] []. +Qed. (*/ PR*) Reserved Notation "R .-ker X ~> Y" (at level 42). @@ -347,13 +382,13 @@ HB.structure Definition ProbabilityKernel (R : realType) := {k of isProbabilityKernel _ _ X Y R k & isKernel _ _ X Y R k}. -Section measure_uub. +Section measure_fam_uub. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). Variables (R : numFieldType) (k : X -> {measure set Y -> \bar R}). -Definition measure_uub := exists r, forall x, k x [set: Y] < r%:E. +Definition measure_fam_uub := exists r, forall x, k x [set: Y] < r%:E. -Lemma measure_uubP : measure_uub <-> +Lemma measure_fam_uubP : measure_fam_uub <-> exists r : {posnum R}, forall x, k x [set: Y] < r%:num%:E. Proof. split => [|] [r kr]; last by exists r%:num. @@ -361,12 +396,12 @@ suff r_gt0 : (0 < r)%R by exists (PosNum r_gt0). by rewrite -lte_fin; apply: (le_lt_trans _ (kr point)). Qed. -End measure_uub. +End measure_fam_uub. HB.mixin Record isFiniteKernel d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) := - { kernel_uub : measure_uub k }. + { kernel_uub : measure_fam_uub k }. #[short(type=finite_kernel)] HB.structure Definition FiniteKernel @@ -392,11 +427,8 @@ HB.instance Definition _ := @isKernel.Build _ _ T' T R kernel_from_mzero kernel_from_mzeroP. -Lemma kernel_from_mzero_uub : measure_uub kernel_from_mzero. -Proof. -exists 1%R => /= t. -by rewrite /mzero/=. -Qed. +Lemma kernel_from_mzero_uub : measure_fam_uub kernel_from_mzero. +Proof. by exists 1%R => /= t; rewrite /mzero/=. Qed. HB.instance Definition _ := @isFiniteKernel.Build _ _ _ T R kernel_from_mzero @@ -529,42 +561,51 @@ Qed. End measurable_fun_xsection_finite_kernel. (* pollard *) -Lemma measurable_fun_integral_finite_kernel - (d d' : _) (X : measurableType d) (Y : measurableType d') - (R : realType) (l : R.-fker X ~> Y) (k : (X * Y)%type -> \bar R) - (k0 : (forall z, True -> 0 <= k z)) (mk : measurable_fun setT k) : +Section measurable_fun_integral_finite_sfinite. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d') + (R : realType). + +Lemma measurable_fun_xsection_integral + (l : X -> {measure set Y -> \bar R}) + (k : X * Y -> \bar R) + (k_ : ({nnsfun [the measurableType _ of (X * Y)%type] >-> R})^nat) + (ndk_ : nondecreasing_seq (k_ : (X * Y -> R)^nat)) + (k_k : forall z, EFin \o (k_ ^~ z) --> k z) : + (forall n r, measurable_fun setT (fun x => l x (xsection (k_ n @^-1` [set r]) x))) -> measurable_fun setT (fun x => \int[l x]_y k (x, y)). Proof. -have [k_ [ndk_ k_k]] := approximation measurableT mk k0. -rewrite (_ : (fun x => \int[l x]_y k (x, y)) = +move=> h. +rewrite (_ : (fun x => _) = (fun x => elim_sup (fun n => \int[l x]_y (k_ n (x, y))%:E))); last first. - apply/funeqP => x. + apply/funext => x. transitivity (lim (fun n => \int[l x]_y (k_ n (x, y))%:E)); last first. rewrite is_cvg_elim_supE//. apply: ereal_nondecreasing_is_cvg => m n mn. apply: ge0_le_integral => //. - - by move=> y' _; rewrite lee_fin. + - by move=> y _; rewrite lee_fin. - exact/EFin_measurable_fun/measurable_fun_prod1. - - by move=> y' _; rewrite lee_fin. + - by move=> y _; rewrite lee_fin. - exact/EFin_measurable_fun/measurable_fun_prod1. - - by move=> y' _; rewrite lee_fin; apply/lefP/ndk_. + - by move=> y _; rewrite lee_fin; exact/lefP/ndk_. rewrite -monotone_convergence//. - by apply: eq_integral => y _; apply/esym/cvg_lim => //; exact: k_k. - by move=> n; exact/EFin_measurable_fun/measurable_fun_prod1. - - by move=> n y' _; rewrite lee_fin. - - by move=> y' _ m n mn; rewrite lee_fin; apply/lefP/ndk_. + - by move=> n y _; rewrite lee_fin. + - by move=> y _ m n mn; rewrite lee_fin; exact/lefP/ndk_. apply: measurable_fun_elim_sup => n. rewrite [X in measurable_fun _ X](_ : _ = (fun x => \int[l x]_y (\sum_(r <- fset_set (range (k_ n))) r * \1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. -rewrite [X in measurable_fun _ X](_ : _ = (fun x => \sum_(r <- fset_set (range (k_ n))) - (\int[l x]_y (r * \1_(k_ n @^-1` [set r]) (x, y))%:E))); last first. +rewrite [X in measurable_fun _ X](_ : _ = (fun x => + \sum_(r <- fset_set (range (k_ n))) + (\int[l x]_y (r * \1_(k_ n @^-1` [set r]) (x, y))%:E))); last first. apply/funext => x; rewrite -ge0_integral_sum//. - by apply: eq_integral => y _; rewrite sumEFin. - move=> r. apply/EFin_measurable_fun/measurable_funrM/measurable_fun_prod1 => /=. - by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). + rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r))//. + exact/measurable_funP. - by move=> m y _; rewrite muleindic_ge0. apply emeasurable_fun_sum => r. rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * @@ -572,27 +613,53 @@ rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * apply/funext => x. under eq_integral do rewrite EFinM. rewrite (integralM_0ifneg _ _ (fun k y => (\1_(k_ n @^-1` [set r]) (x, y))%:E))//. - - by move=> _ t _; rewrite lee_fin. - - by move=> r_lt0; apply/funext => y; rewrite preimage_nnfun0// indicE in_set0. + - by move=> _ y _; rewrite lee_fin. + - by move=> r0; apply/funext => y; rewrite preimage_nnfun0// indicE in_set0. - apply/EFin_measurable_fun/measurable_fun_prod1 => /=. - by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). -apply: measurable_funeM. -rewrite (_ : (fun x => _) = (fun x => l x (xsection (k_ n @^-1` [set r]) x))); last first. - apply/funext => y. - rewrite integral_indic//; last first. - rewrite (_ : (fun x => _) = xsection (k_ n @^-1` [set r]) y); last first. - apply/seteqP; split. - by move=> y2/=; rewrite /xsection/= inE//. - by rewrite /xsection/= => y2/=; rewrite inE. + rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r))//. + exact/measurable_funP. +apply/measurable_funeM. +rewrite (_ : (fun x => _) = (fun x => l x (xsection (k_ n @^-1` [set r]) x))). + exact/h. +apply/funext => x; rewrite integral_indic//; last first. + rewrite (_ : (fun x => _) = xsection (k_ n @^-1` [set r]) x). exact: measurable_xsection. - congr (l y _). - apply/funext => y1/=. - rewrite /xsection/= inE. - by apply/propext; tauto. + by rewrite /xsection; apply/seteqP; split=> y/= /[!inE]. +congr (l x _); apply/funext => y1/=; rewrite /xsection/= inE. +by apply/propext; tauto. +Qed. + +Lemma measurable_fun_integral_finite_kernel + (l : R.-fker X ~> Y) + (k : X * Y -> \bar R) (k0 : forall z, 0 <= k z) (mk : measurable_fun setT k) : + measurable_fun setT (fun x => \int[l x]_y k (x, y)). +Proof. +have [k_ [ndk_ k_k]] := approximation measurableT mk (fun x _ => k0 x). +apply: (measurable_fun_xsection_integral ndk_ (k_k ^~ Logic.I)) => n r. have [l_ hl_] := kernel_uub l. by apply: measurable_fun_xsection_finite_kernel => // /[!inE]. Qed. +Lemma measurable_fun_integral_sfinite_kernel + (l : R.-sfker X ~> Y) + (k : X * Y -> \bar R) (k0 : forall t, 0 <= k t) (mk : measurable_fun setT k) : + measurable_fun setT (fun x => \int[l x]_y k (x, y)). +Proof. +have [k_ [ndk_ k_k]] := approximation measurableT mk (fun xy _ => k0 xy). +apply: (measurable_fun_xsection_integral ndk_ (k_k ^~ Logic.I)) => n r. +have [l_ hl_] := sfinite l. +rewrite (_ : (fun x => _) = + (fun x => mseries (l_ ^~ x) 0 (xsection (k_ n @^-1` [set r]) x))); last first. + by apply/funext => x; rewrite hl_//; exact/measurable_xsection. +apply: ge0_emeasurable_fun_sum => // m. +by apply: measurable_fun_xsection_finite_kernel => // /[!inE]. +Qed. + +End measurable_fun_integral_finite_sfinite. +Arguments measurable_fun_xsection_integral {_ _ _ _ _} l k. +Arguments measurable_fun_integral_finite_kernel {_ _ _ _ _} l k. +Arguments measurable_fun_integral_sfinite_kernel {_ _ _ _ _} l k. + Section kcomp_def. Variables (d1 d2 d3 : _) (X : measurableType d1) (Y : measurableType d2) (Z : measurableType d3) (R : realType). @@ -650,9 +717,7 @@ Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') Lemma measurable_fun_kcomp_finite U : measurable U -> measurable_fun setT ((l \; k) ^~ U). Proof. -move=> mU. -rewrite /kcomp. -apply: (@measurable_fun_integral_finite_kernel _ _ _ _ _ _ (k ^~ U)) => //=. +move=> mU; apply: (measurable_fun_integral_finite_kernel _ (k ^~ U)) => //=. exact/measurable_kernel. Qed. @@ -667,12 +732,11 @@ Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') Variable l : R.-fker X ~> Y. Variable k : R.-fker [the measurableType _ of (X * Y)%type] ~> Z. -Lemma mkcomp_finite : measure_uub (l \; k). +Lemma mkcomp_finite : measure_fam_uub (l \; k). Proof. -have /measure_uubP[r hr] := kernel_uub k. -have /measure_uubP[s hs] := kernel_uub l. -apply/measure_uubP; exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x. -rewrite /=. +have /measure_fam_uubP[r hr] := kernel_uub k. +have /measure_fam_uubP[s hs] := kernel_uub l. +apply/measure_fam_uubP; exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x /=. apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). apply: ge0_le_integral => //. - have /measurable_fun_prod1 := measurable_kernel k setT measurableT. @@ -688,82 +752,6 @@ HB.instance Definition _ := End kcomp_finite_kernel_finite. End KCOMP_FINITE_KERNEL. -(* pollard *) -Lemma measurable_fun_integral_sfinite_kernel - (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType) - (l : R.-sfker X ~> Y) - (k : (X * Y)%type -> \bar R) (k0 : (forall t, True -> 0 <= k t)) - (mk : measurable_fun setT k) : - measurable_fun [set: X] (fun x => \int[l x]_y k (x, y)). -Proof. -have [k_ [ndk_ k_k]] := approximation measurableT mk k0. -simpl in *. -rewrite (_ : (fun x => \int[l x]_y k (x, y)) = - (fun x => elim_sup (fun n => \int[l x]_y (k_ n (x, y))%:E))); last first. - apply/funeqP => x. - transitivity (lim (fun n => \int[l x]_y (k_ n (x, y))%:E)); last first. - rewrite is_cvg_elim_supE//. - apply: ereal_nondecreasing_is_cvg => m n mn. - apply: ge0_le_integral => //. - - by move=> y' _; rewrite lee_fin. - - exact/EFin_measurable_fun/measurable_fun_prod1. - - by move=> y' _; rewrite lee_fin. - - exact/EFin_measurable_fun/measurable_fun_prod1. - - by move=> y' _; rewrite lee_fin; apply/lefP/ndk_. - rewrite -monotone_convergence//. - - by apply: eq_integral => y _; apply/esym/cvg_lim => //; exact: k_k. - - by move=> n; exact/EFin_measurable_fun/measurable_fun_prod1. - - by move=> n y' _; rewrite lee_fin. - - by move=> y' _ m n mn; rewrite lee_fin; apply/lefP/ndk_. -apply: measurable_fun_elim_sup => n. -rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \int[l x0]_y - (\sum_(r <- fset_set (range (k_ n))) - r * \1_(k_ n @^-1` [set r]) (x0, y))%:E)); last first. - by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. -rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \sum_(r <- fset_set (range (k_ n))) - (\int[l x0]_y - (r * \1_(k_ n @^-1` [set r]) (x0, y))%:E))); last first. - apply/funext => x; rewrite -ge0_integral_sum//. - - by apply: eq_integral => y _; rewrite sumEFin. - - move=> r. - apply/EFin_measurable_fun/measurable_funrM/measurable_fun_prod1 => /=. - by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). - - by move=> m y _; rewrite muleindic_ge0. -apply emeasurable_fun_sum => r. -rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * - \int[l x]_y (\1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. - apply/funext => x. - under eq_integral do rewrite EFinM. - rewrite (integralM_0ifneg _ _ (fun k y => (\1_(k_ n @^-1` [set r]) (x, y))%:E))//. - - by move=> _ t _; rewrite lee_fin. - - by move=> r_lt0; apply/funext => y; rewrite preimage_nnfun0// indicE in_set0. - - apply/EFin_measurable_fun/measurable_fun_prod1 => /=. - by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). -apply: measurable_funeM. -rewrite (_ : (fun x => \int[l x]_z (\1_(k_ n @^-1` [set r]) (x, z))%:E) = - (fun x => l x (xsection (k_ n @^-1` [set r]) x))); last first. - apply/funext => y. - rewrite integral_indic//; last first. - rewrite (_ : (fun x => (k_ n @^-1` [set r]) (y, x)) = xsection (k_ n @^-1` [set r]) y); last first. - apply/seteqP; split. - by move=> y2/=; rewrite /xsection/= inE//. - by rewrite /xsection/= => y2/=; rewrite inE /preimage/=. - exact: measurable_xsection. - congr (l y _). - apply/funext => y1/=. - rewrite /xsection/= inE. - by apply/propext; tauto. -have [l_ hl_] := sfinite l. -rewrite (_ : (fun x => _) = (fun x => mseries (l_ ^~ x) 0 (xsection (k_ n @^-1` [set r]) x))); last first. - apply/funext => x. - rewrite hl_//. - exact/measurable_xsection. -rewrite /mseries/=. -apply: ge0_emeasurable_fun_sum => // k1. -apply: measurable_fun_xsection_finite_kernel => //. -by rewrite inE. -Qed. - Section kcomp_sfinite_kernel. Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType). @@ -824,10 +812,10 @@ rewrite (reindex_esum [set: nat] [set: nat * nat] f)//. by rewrite nneseries_esum// fun_true. Qed. -Lemma measurable_fun_mkcomp_sfinite U : measurable U -> measurable_fun setT ((l \; k) ^~ U). +Lemma measurable_fun_mkcomp_sfinite U : measurable U -> + measurable_fun setT ((l \; k) ^~ U). Proof. -move=> mU. -apply: (@measurable_fun_integral_sfinite_kernel _ _ _ _ _ _ (k ^~ U)) => //. +move=> mU; apply: (measurable_fun_integral_sfinite_kernel _ (k ^~ U)) => //. exact/measurable_kernel. Qed. @@ -851,62 +839,77 @@ End kcomp_sfinite_kernel. End KCOMP_SFINITE_KERNEL. HB.export KCOMP_SFINITE_KERNEL. -(* pollard *) -Lemma measurable_fun_integral_sfinite_kernel_prod +(* pollard? *) +Section measurable_fun_integral_kernel'. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d') + (R : realType). +Variables (l : X -> {measure set Y -> \bar R}) + (k : Y -> \bar R) + (k_ : ({nnsfun Y >-> R}) ^nat) + (ndk_ : nondecreasing_seq (k_ : (Y -> R)^nat)) + (k_k : forall z, setT z -> EFin \o (k_ ^~ z) --> k z). + +Let p : (X * Y -> R)^nat := fun n xy => k_ n xy.2. + +Let p_ge0 n x : (0 <= p n x)%R. Proof. by []. Qed. + +HB.instance Definition _ n := @IsNonNegFun.Build _ R (p n) (p_ge0 n). + +Let mp n : measurable_fun setT (p n). +Proof. +rewrite /p => _ /= B mB; rewrite setTI. +have mk_n : measurable_fun setT (k_ n) by []. +rewrite (_ : _ @^-1` _ = setT `*` (k_ n @^-1` B)); last first. + by apply/seteqP; split => xy /=; tauto. +apply: measurableM => //. +have := mk_n measurableT _ mB. +by rewrite setTI. +Qed. + +HB.instance Definition _ n := @IsMeasurableFun.Build _ _ R (p n) (mp n). + +Let fp n : finite_set (range (p n)). +Proof. +have := @fimfunP _ _ (k_ n). +suff : range (k_ n) = range (p n) by move=> <-. +by apply/seteqP; split => r [y ?] <-; [exists (point, y)|exists y.2]. +Qed. + +HB.instance Definition _ n := @FiniteImage.Build _ _ (p n) (fp n). + +Lemma measurable_fun_preimage_integral : + (forall n r, measurable_fun setT (fun x => l x (k_ n @^-1` [set r]))) -> + measurable_fun setT (fun x => \int[l x]_z k z). +Proof. +move=> h. +apply: (measurable_fun_xsection_integral l (fun xy => k xy.2) + (fun n => [the {nnsfun _ >-> _} of p n])) => /=. +- by rewrite /p => m n mn; apply/lefP => -[x y] /=; exact/lefP/ndk_. +- by move=> [x y]; exact: k_k. +- move=> n r _ /= B mB. + have := h n r measurableT B mB. + rewrite !setTI. + suff : ((fun x => l x (k_ n @^-1` [set r])) @^-1` B) = + ((fun x => l x (xsection (p n @^-1` [set r]) x)) @^-1` B) by move=> ->. + apply/seteqP; split => x/=. + suff : (k_ n @^-1` [set r]) = (xsection (p n @^-1` [set r]) x) by move=> ->. + by apply/seteqP; split; move=> y/=; + rewrite /xsection/= /p /preimage/= inE/=. + suff : (k_ n @^-1` [set r]) = (xsection (p n @^-1` [set r]) x) by move=> ->. + by apply/seteqP; split; move=> y/=; rewrite /xsection/= /p /preimage/= inE/=. +Qed. + +End measurable_fun_integral_kernel'. + +Lemma measurable_fun_integral_kernel (d d' d3 : _) (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType) - (l : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) c - (k : Z -> \bar R) (k0 : (forall z, True -> 0 <= k z)) (mk : measurable_fun setT k) : - measurable_fun [set: Y] (fun y => \int[l (c, y)]_z k z). + (l : R.-ker [the measurableType _ of (X * Y)%type] ~> Z) c + (k : Z -> \bar R) (k0 : forall z, True -> 0 <= k z) (mk : measurable_fun setT k) : + measurable_fun setT (fun y => \int[l (c, y)]_z k z). Proof. have [k_ [ndk_ k_k]] := approximation measurableT mk k0. -simpl in *. -rewrite (_ : (fun x0 => \int[l (c, x0)]_z k z) = - (fun x0 => elim_sup (fun n => \int[l (c, x0)]_z (k_ n z)%:E))); last first. - apply/funeqP => x. - transitivity (lim (fun n => \int[l (c, x)]_z (k_ n z)%:E)); last first. - rewrite is_cvg_elim_supE//. - apply: ereal_nondecreasing_is_cvg => m n mn. - apply: ge0_le_integral => //. - - by move=> y' _; rewrite lee_fin. - - exact/EFin_measurable_fun. - - by move=> y' _; rewrite lee_fin. - - exact/EFin_measurable_fun. - - by move=> y' _; rewrite lee_fin; apply/lefP/ndk_. - rewrite -monotone_convergence//. - - by apply: eq_integral => y _; apply/esym/cvg_lim => //; exact: k_k. - - by move=> n; exact/EFin_measurable_fun. - - by move=> n y' _; rewrite lee_fin. - - by move=> y' _ m n mn; rewrite lee_fin; apply/lefP/ndk_. -apply: measurable_fun_elim_sup => n. -rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \int[l (c, x0)]_z - ((\sum_(r <- fset_set (range (k_ n))) - r * \1_(k_ n @^-1` [set r]) z))%:E)); last first. - by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. -rewrite [X in measurable_fun _ X](_ : _ = (fun x0 => \sum_(r <- fset_set (range (k_ n))) - (\int[l (c, x0)]_z - (r * \1_(k_ n @^-1` [set r]) z)%:E))); last first. - apply/funext => x; rewrite -ge0_integral_sum//. - - by apply: eq_integral => y _; rewrite sumEFin. - - move=> r. - apply/EFin_measurable_fun/measurable_funrM => /=. - by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). - - by move=> m y _; rewrite muleindic_ge0. -apply emeasurable_fun_sum => r. -rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * - \int[l (c ,x)]_z (\1_(k_ n @^-1` [set r]) z)%:E)); last first. - apply/funext => x. - under eq_integral do rewrite EFinM. - rewrite (integralM_0ifneg _ _ (fun k z => (\1_(k_ n @^-1` [set r]) z)%:E))//. - - by move=> _ t _; rewrite lee_fin. - - by move=> r_lt0; apply/funext => y; rewrite preimage_nnfun0// indicE in_set0. - - apply/EFin_measurable_fun => /=. - by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). -apply: measurable_funeM. -rewrite (_ : (fun x : Y => \int[l (c, x)]_z (\1_(k_ n @^-1` [set r]) z)%:E) = - (fun x : Y => l (c, x) (k_ n @^-1` [set r]))); last first. - apply/funext => y. - by rewrite integral_indic// setIT. +apply: (measurable_fun_preimage_integral ndk_ k_k) => n r. have := measurable_kernel l (k_ n @^-1` [set r]) (measurable_sfunP (k_ n) r). by move=> /measurable_fun_prod1; exact. Qed. @@ -995,7 +998,7 @@ rewrite (_ : (fun _ => _) = (fun n => \int[l x]_y (\int[k (x, y)]_z (f_ n z)%:E) transitivity (\int[l x]_y lim (fun n => \int[k (x, y)]_z (f_ n z)%:E)). rewrite -monotone_convergence//; last 3 first. move=> n. - apply: measurable_fun_integral_sfinite_kernel_prod => //. + apply: measurable_fun_integral_kernel => //. - by move=> z; rewrite lee_fin. - by apply/EFin_measurable_fun. - move=> n y _. @@ -1041,7 +1044,7 @@ HB.instance Definition _ := @isKernel.Build _ _ _ X R kernel_probability kernel_probabilityP. -Lemma kernel_probability_uub : measure_uub kernel_probability. +Lemma kernel_probability_uub : measure_fam_uub kernel_probability. Proof. (*NB: shouldn't this work? exists 2%:pos. *) exists 2%R => /= ?. @@ -1084,7 +1087,7 @@ Qed. HB.instance Definition _ := isKernel.Build _ _ _ _ R (kernel_mfun mf) measurable_kernel_mfun. -Lemma kernel_mfun_uub : measure_uub (kernel_mfun mf). +Lemma kernel_mfun_uub : measure_fam_uub (kernel_mfun mf). Proof. by exists 2%R => t/=; rewrite diracE in_setT lte_fin ltr_addr. Qed. HB.instance Definition _ := isFiniteKernel.Build _ _ _ _ R (kernel_mfun mf) @@ -1100,367 +1103,6 @@ HB.instance Definition _ := End kernel_of_mfun. -(* semantics for score *) -Lemma set_unit (A : set unit) : A = set0 \/ A = setT. -Proof. -have [->|/set0P[[] Att]] := eqVneq A set0; [by left|right]. -by apply/seteqP; split => [|] []. -Qed. - -Section score_measure. -Variables (R : realType) (d : _) (T : measurableType d). -Variables (r : T -> R) (mr : measurable_fun setT r). - -Definition mscore (t : T) (U : set unit) : \bar R := - if U == set0 then 0 else `| (r t)%:E |. - -Lemma mscore0 t : mscore t (set0 : set unit) = 0 :> \bar R. -Proof. by rewrite /mscore eqxx. Qed. - -Lemma mscore_ge0 t U : 0 <= mscore t U. -Proof. by rewrite /mscore; case: ifP. Qed. - -Lemma mscore_sigma_additive t : semi_sigma_additive (mscore t). -Proof. -move=> /= F mF tF mUF; rewrite /mscore; case: ifPn => [/eqP/bigcup0P F0|]. - rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. - apply/funext => k. - under eq_bigr do rewrite F0// eqxx. - by rewrite big1. -move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. -rewrite -(cvg_shiftn k.+1)/=. -rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. -apply/funext => n. -rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. -rewrite (negbTE Fk0) big1 ?adde0// => i/= ik; rewrite ifT//. -have [/eqP//|Fitt] := set_unit (F i). -move/trivIsetP : tF => /(_ i k Logic.I Logic.I ik). -by rewrite Fitt setTI => /eqP; rewrite (negbTE Fk0). -Qed. - -HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ - (mscore t) (mscore0 t) (mscore_ge0 t) (@mscore_sigma_additive t). - -End score_measure. - -Module KERNEL_SCORE. -Section kernel_score. -Variables (R : realType) (d : _) (T : measurableType d). -Variables (r : T -> R). - -Definition k_' (mr : measurable_fun setT r) (i : nat) : T -> set unit -> \bar R := - fun t U => - if i%:R%:E <= mscore r t U < i.+1%:R%:E then - mscore r t U - else - 0. - -Variable (mr : measurable_fun setT r). - -Lemma k_'0 i (t : T) : k_' mr i t (set0 : set unit) = 0 :> \bar R. -Proof. by rewrite /k_' measure0; case: ifP. Qed. - -Lemma k_'ge0 i (t : T) B : 0 <= k_' mr i t B. -Proof. by rewrite /k_'; case: ifP. Qed. - -Lemma k_'sigma_additive i (t : T) : semi_sigma_additive (k_' mr i t). -Proof. -move=> /= F mF tF mUF. -rewrite /k_' /=. -have [F0|] := eqVneq (\bigcup_n F n) set0. - rewrite [in X in _ --> X]/mscore F0 eqxx. - rewrite (_ : (fun _ => _) = cst 0). - by case: ifPn => _; exact: cvg_cst. - apply/funext => k; rewrite big1// => n _. - move : F0 => /bigcup0P F0. - by rewrite /mscore F0// eqxx; case: ifP. -move=> UF0; move: (UF0). -move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. -rewrite [in X in _ --> X]/mscore (negbTE UF0). -rewrite -(cvg_shiftn k.+1)/=. -case: ifPn => ir. - rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. - apply/funext => n. - rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. - rewrite [in X in X + _]/mscore (negbTE Fk0) ir big1 ?adde0// => /= j jk. - rewrite /mscore. - have /eqP Fj0 : F j == set0. - have [/eqP//|Fjtt] := set_unit (F j). - move/trivIsetP : tF => /(_ j k Logic.I Logic.I jk). - by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fk0). - rewrite Fj0 eqxx. - by case: ifP. -rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. -apply/funext => n. -rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. -rewrite [in X in if X then _ else _]/mscore (negbTE Fk0) (negbTE ir) add0e. -rewrite big1//= => j jk. -rewrite /mscore. -have /eqP Fj0 : F j == set0. - have [/eqP//|Fjtt] := set_unit (F j). - move/trivIsetP : tF => /(_ j k Logic.I Logic.I jk). - by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fk0). -rewrite Fj0 eqxx. -by case: ifP. -Qed. - -HB.instance Definition _ (i : nat) (t : T) := isMeasure.Build _ _ _ - (k_' mr i t) (k_'0 i t) (k_'ge0 i t) (@k_'sigma_additive i t). - -Lemma emeasurable_itv (i : nat) : - measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set \bar R). -Proof. -rewrite -[X in measurable X]setCK. -apply: measurableC. -rewrite set_interval.setCitv /=. -apply: measurableU. -exact: emeasurable_itv_ninfty_bnd. -exact: emeasurable_itv_bnd_pinfty. -Qed. - -Lemma k_kernelP (i : nat) : forall U, measurable U -> measurable_fun setT (k_' mr i ^~ U). -Proof. -move=> /= U mU. -rewrite /k_' /=. -rewrite (_ : (fun x : T => _) = (fun x => if (i%:R)%:E <= x < (i.+1%:R)%:E then x else 0) \o (fun x => mscore r x U)) //. -apply: measurable_fun_comp; last first. - rewrite /mscore. - have [U0|U0] := eqVneq U set0. - exact: measurable_fun_cst. - apply: measurable_fun_comp => //. - by apply/EFin_measurable_fun. -rewrite /=. -pose A : _ -> \bar R := (fun x : \bar R => x * (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set (\bar R)) x)%:E). -rewrite (_ : (fun x => _) = A); last first. - apply/funext => x; rewrite /A; case: ifPn => ix. - by rewrite indicE/= mem_set ?mule1//. - rewrite indicE/= memNset ?mule0//. - rewrite /= in_itv/=. - exact/negP. -rewrite /A. -apply emeasurable_funM => /=. - exact: measurable_fun_id. -apply/EFin_measurable_fun. -have mi : measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set (\bar R)). - exact: emeasurable_itv. -by rewrite (_ : \1__ = mindic R mi)//. -Qed. - -Definition mk_' i (t : T) := [the measure _ _ of k_' mr i t]. - -HB.instance Definition _ (i : nat) := - isKernel.Build _ _ _ _ R (mk_' i) (k_kernelP i). - -Lemma k_uub (i : nat) : measure_uub (mk_' i). -Proof. -exists i.+1%:R => /= t. -rewrite /k_' /mscore setT_unit. -rewrite (_ : [set tt] == set0 = false); last first. - by apply/eqP => /seteqP[] /(_ tt) /(_ erefl). -by case: ifPn => // /andP[]. -Qed. - -HB.instance Definition _ (i : nat) := - @isFiniteKernel.Build _ _ _ _ R (mk_' i) (k_uub i). - -End kernel_score. -End KERNEL_SCORE. - -Section kernel_score_kernel. -Variables (R : realType) (d : _) (T : measurableType d). -Variables (r : T -> R). - -Definition kernel_score (mr : measurable_fun setT r) : T -> {measure set Datatypes_unit__canonical__measure_Measurable -> \bar R} := - fun t : T => [the measure _ _ of mscore r t]. - -Variable (mr : measurable_fun setT r). - -Lemma kernel_scoreP : forall U, measurable U -> - measurable_fun setT (kernel_score mr ^~ U). -Proof. -move=> /= U mU. -rewrite /mscore. -have [U0|U0] := eqVneq U set0. - exact: measurable_fun_cst. -apply: measurable_fun_comp => //. -by apply/EFin_measurable_fun. -Qed. - -HB.instance Definition _ := - isKernel.Build _ _ T - _ (*Datatypes_unit__canonical__measure_Measurable*) R - (kernel_score mr) (kernel_scoreP). -End kernel_score_kernel. - -Section kernel_score_sfinite_kernel. -Variables (R : realType) (d : _) (T : measurableType d). -Variables (r : T -> R) (mr : measurable_fun setT r). - -Import KERNEL_SCORE. - -Lemma kernel_score_sfinite_kernelP : exists k_ : (R.-fker T ~> _)^nat, - forall x U, measurable U -> - kernel_score mr x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. -rewrite /=. -exists (fun i => [the finite_kernel _ _ _ of mk_' mr i]) => /= r' U mU. -rewrite /mseries /mscore; case: ifPn => [/eqP U0|U0]. - by apply/esym/nneseries0 => i _; rewrite U0 measure0. -rewrite /mk_' /= /k_' /= /mscore (negbTE U0). -apply/esym/cvg_lim => //. -rewrite -(cvg_shiftn `|floor (fine `|(r r')%:E|)|%N.+1)/=. -rewrite (_ : (fun _ => _) = cst `|(r r')%:E|); first exact: cvg_cst. -apply/funext => n. -pose floor_r := widen_ord (leq_addl n `|floor `|(r r')| |.+1) (Ordinal (ltnSn `|floor `|(r r')| |)). -rewrite big_mkord (bigD1 floor_r)//= ifT; last first. - rewrite lee_fin lte_fin; apply/andP; split. - by rewrite natr_absz (@ger0_norm _ (floor `|(r r')|)) ?floor_ge0 ?floor_le. - by rewrite -addn1 natrD natr_absz (@ger0_norm _ (floor `|(r r')|)) ?floor_ge0 ?lt_succ_floor. -rewrite big1 ?adde0//= => j jk. -rewrite ifF// lte_fin lee_fin. -move: jk; rewrite neq_ltn/= => /orP[|] jr. -- suff : (j.+1%:R <= `|(r r')|)%R by rewrite leNgt => /negbTE ->; rewrite andbF. - rewrite (_ : j.+1%:R = j.+1%:~R)// floor_ge_int. - move: jr; rewrite -lez_nat => /le_trans; apply. - by rewrite -[leRHS](@ger0_norm _ (floor `|(r r')|)) ?floor_ge0. -- suff : (`|(r r')| < j%:R)%R by rewrite ltNge => /negbTE ->. - move: jr; rewrite -ltz_nat -(@ltr_int R) (@gez0_abs (floor `|(r r')|)) ?floor_ge0// ltr_int. - by rewrite -floor_lt_int. -Qed. - -HB.instance Definition _ := @isSFiniteKernel.Build _ _ _ _ _ - (kernel_score mr) (kernel_score_sfinite_kernelP). - -End kernel_score_sfinite_kernel. - -Section ite_true_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u1 : R.-ker T ~> T'). - -Definition ite_true : T * bool -> {measure set T' -> \bar R} := - fun b => if b.2 then u1 b.1 else [the measure _ _ of mzero]. - -Lemma measurable_ite_true U : measurable U -> measurable_fun setT (ite_true ^~ U). -Proof. -move=> /= mcU. -rewrite /ite_true. -rewrite (_ : (fun x : T * bool => _) = (fun x => if x.2 then u1 x.1 U else [the {measure set T' -> \bar R} of mzero] U)); last first. - apply/funext => -[t b]/=. - by case: ifPn. -apply: (@measurable_fun_if _ _ _ _ (u1 ^~ U) (fun=> mzero U)). - exact/measurable_kernel. -exact: measurable_fun_cst. -Qed. - -HB.instance Definition _ := isKernel.Build _ _ _ _ R ite_true measurable_ite_true. -End ite_true_kernel. - -Section ite_true_finite_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u1 : R.-fker T ~> T'). - -Lemma ite_true_uub : measure_uub (ite_true u1). -Proof. -have /measure_uubP[M hM] := kernel_uub u1. -exists M%:num => /= -[]; rewrite /ite_true => t [|]/=. - exact: hM. -by rewrite /= /mzero. -Qed. - -HB.instance Definition _ t := - isFiniteKernel.Build _ _ _ _ R (ite_true u1) ite_true_uub. -End ite_true_finite_kernel. - -Section ite_true_sfinite_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u1 : R.-sfker T ~> T'). - -Lemma sfinite_ite_true : exists k_ : (R.-fker _ ~> _)^nat, - forall x U, measurable U -> - ite_true u1 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. -have [k hk /=] := sfinite u1. -rewrite /ite_true. -exists (fun n => [the finite_kernel _ _ _ of ite_true (k n)]) => b U mU. -case: ifPn => hb. - rewrite /mseries hk//= /mseries. - apply: eq_nneseries => n _. - by rewrite /ite_true hb. -rewrite /= /mseries nneseries0// => n _. -by rewrite /ite_true (negbTE hb). -Qed. - -HB.instance Definition _ t := - @isSFiniteKernel.Build _ _ _ _ _ (ite_true u1) sfinite_ite_true. - -End ite_true_sfinite_kernel. - -Section ite_false_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u2 : R.-ker T ~> T'). - -Definition ite_false : T * bool -> {measure set T' -> \bar R} := - fun b => if ~~ b.2 then u2 b.1 else [the measure _ _ of mzero]. - -Lemma measurable_ite_false U : measurable U -> measurable_fun setT (ite_false ^~ U). -Proof. -move=> /= mcU. -rewrite /ite_false. -rewrite (_ : (fun x => _) = (fun x => if x.2 then [the {measure set T' -> \bar R} of mzero] U else u2 x.1 U)); last first. - apply/funext => -[t b]/=. - rewrite if_neg/=. - by case: b. -apply: (@measurable_fun_if _ _ _ _ (fun=> mzero U) (u2 ^~ U)). - exact: measurable_fun_cst. -exact/measurable_kernel. -Qed. - -HB.instance Definition _ := isKernel.Build _ _ _ _ R ite_false measurable_ite_false. - -End ite_false_kernel. - -Section ite_false_finite_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u2 : R.-fker T ~> T'). - -Lemma ite_false_uub : measure_uub (ite_false u2). -Proof. -have /measure_uubP[M hM] := kernel_uub u2. -exists M%:num => /= -[]; rewrite /ite_false/= => t b. -case: b => //=. -by rewrite /mzero. -Qed. - -HB.instance Definition _ := - isFiniteKernel.Build _ _ _ _ R (ite_false u2) ite_false_uub. - -End ite_false_finite_kernel. - -Section ite_false_sfinite_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u2 : R.-sfker T ~> T'). - -Lemma sfinite_ite_false : exists k_ : (R.-fker _ ~> _)^nat, - forall x U, measurable U -> - ite_false u2 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. -have [k hk] := sfinite u2. -rewrite /= /ite_false. -exists (fun n => [the finite_kernel _ _ _ of ite_false (k n)]) => b U mU. -case: ifPn => hb. - rewrite /mseries hk//= /mseries/=. - apply: eq_nneseries => // n _. - by rewrite /ite_false hb. -rewrite /= /mseries nneseries0// => n _. -rewrite negbK in hb. -by rewrite /ite_false hb/=. -Qed. - -HB.instance Definition _ := - @isSFiniteKernel.Build _ _ _ _ _ (ite_false u2) sfinite_ite_false. - -End ite_false_sfinite_kernel. - Section add_of_kernels. Variables (d d' : measure_display) (R : realType). Variables (X : measurableType d) (Y : measurableType d'). @@ -1488,7 +1130,7 @@ Variables (d d' : measure_display) (R : realType). Variables (X : measurableType d) (Y : measurableType d'). Variables (u1 u2 : R.-fker X ~> Y). -Lemma add_of_finite_kernels_uub : measure_uub (add_of_kernels u1 u2). +Lemma add_of_finite_kernels_uub : measure_fam_uub (add_of_kernels u1 u2). Proof. have [k1 hk1] := kernel_uub u1. have [k2 hk2] := kernel_uub u2. @@ -1529,3 +1171,53 @@ Qed. HB.instance Definition _ t := isSFiniteKernel.Build _ _ _ _ R (add_of_kernels u1 u2) sfinite_add_of_kernels. End add_of_sfinite_kernels. + +Section normalize_measure. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). +Variables (R : realType) (f : T -> {measure set T' -> \bar R}) (P : probability T' R). + +Definition normalize (t : T) (U : set T') := + let evidence := f t setT in + if (evidence == 0%E) || (evidence == +oo) then P U + else f t U * (fine evidence)^-1%:E. + +Lemma normalize0 t : normalize t set0 = 0. +Proof. +rewrite /normalize. +case: ifPn => // _. +by rewrite measure0 mul0e. +Qed. + +Lemma normalize_ge0 t U : 0 <= normalize t U. +Proof. +by rewrite /normalize; case: ifPn. +Qed. + +Lemma normalize_sigma_additive t : semi_sigma_additive (normalize t). +Proof. +move=> F mF tF mUF. +rewrite /normalize/=. +case: ifPn => [_|_]. + exact: measure_semi_sigma_additive. +rewrite (_ : (fun n => _) = ((fun n=> \sum_(0 <= i < n) f t (F i)) \* cst ((fine (f t [set: T']))^-1)%:E)); last first. + by apply/funext => n; rewrite -ge0_sume_distrl. +by apply: ereal_cvgMr => //; exact: measure_semi_sigma_additive. +Qed. + +HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ + (normalize t) (normalize0 t) (normalize_ge0 t) (@normalize_sigma_additive t). + +Lemma normalize1 t : normalize t setT = 1. +Proof. +rewrite /normalize; case: ifPn. + by rewrite probability_setT. +rewrite negb_or => /andP[ft0 ftoo]. +have ? : f t [set: T'] \is a fin_num. + by rewrite ge0_fin_numE// lt_neqAle ftoo/= leey. +rewrite -{1}(@fineK _ (f t setT))//. +rewrite -EFinM divrr// ?unitfE fine_eq0//. +Qed. + +HB.instance Definition _ t := isProbability.Build _ _ _ (normalize t) (normalize1 t). + +End normalize_measure. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 375ca61078..bf33aa724e 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -4,6 +4,14 @@ Require Import mathcomp_extra boolp classical_sets signed functions cardinality. Require Import reals ereal topology normedtype sequences esum measure. Require Import lebesgue_measure fsbigop numfun lebesgue_integral kernel. +(******************************************************************************) +(* Semantics of a PPL using s-finite kernels *) +(* *) +(* bernoulli == *) +(* score == *) +(* ite_true/ite_false == *) +(******************************************************************************) + Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -14,6 +22,383 @@ Local Open Scope classical_set_scope. Local Open Scope ring_scope. Local Open Scope ereal_scope. +Definition onem (R : numDomainType) (p : R) := (1 - p)%R. + +Lemma onem1 (R : numDomainType) (p : R) : (p + onem p = 1)%R. +Proof. by rewrite /onem addrCA subrr addr0. Qed. + +Lemma onem_nonneg_proof (R : numDomainType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R) : + (0 <= onem p%:num)%R. +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). + +Section bernoulli. +Variables (R : realType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R). +Local Open Scope ring_scope. + +Definition bernoulli : set _ -> \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]]. + +HB.instance Definition _ := Measure.on bernoulli. + +Local Close Scope ring_scope. + +Lemma bernoulli_setT : bernoulli [set: _] = 1. +Proof. +rewrite /bernoulli/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. +by rewrite /mscale/= !diracE !in_setT !mule1 -EFinD onem1. +Qed. + +HB.instance Definition _ := @isProbability.Build _ _ R bernoulli bernoulli_setT. + +End bernoulli. + +Section score_measure. +Variables (R : realType) (d : _) (T : measurableType d). +Variables (r : T -> R). + +Definition score (t : T) (U : set unit) : \bar R := + if U == set0 then 0 else `| (r t)%:E |. + +Let score0 t : score t (set0 : set unit) = 0 :> \bar R. +Proof. by rewrite /score eqxx. Qed. + +Let score_ge0 t U : 0 <= score t U. +Proof. by rewrite /score; case: ifP. Qed. + +Let score_sigma_additive t : semi_sigma_additive (score t). +Proof. +move=> /= F mF tF mUF; rewrite /score; case: ifPn => [/eqP/bigcup0P F0|]. + rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. + apply/funext => k. + under eq_bigr do rewrite F0// eqxx. + by rewrite big1. +move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. +rewrite -(cvg_shiftn k.+1)/=. +rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. +apply/funext => n. +rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. +rewrite (negbTE Fk0) big1 ?adde0// => i/= ik; rewrite ifT//. +have [/eqP//|Fitt] := set_unit (F i). +move/trivIsetP : tF => /(_ i k Logic.I Logic.I ik). +by rewrite Fitt setTI => /eqP; rewrite (negbTE Fk0). +Qed. + +HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ + (score t) (score0 t) (score_ge0 t) (@score_sigma_additive t). + +End score_measure. + +(* decomposition of score into finite kernels *) +Module SCORE. +Section score. +Variables (R : realType) (d : _) (T : measurableType d). +Variables (r : T -> R). + +Definition k_ (mr : measurable_fun setT r) (i : nat) : T -> set unit -> \bar R := + fun t U => + if i%:R%:E <= score r t U < i.+1%:R%:E then + score r t U + else + 0. + +Hypothesis mr : measurable_fun setT r. + +Lemma k_0 i (t : T) : k_ mr i t (set0 : set unit) = 0 :> \bar R. +Proof. by rewrite /k_ measure0; case: ifP. Qed. + +Lemma k_ge0 i (t : T) B : 0 <= k_ mr i t B. +Proof. by rewrite /k_; case: ifP. Qed. + +Lemma k_sigma_additive i (t : T) : semi_sigma_additive (k_ mr i t). +Proof. +move=> /= F mF tF mUF. +rewrite /k_ /=. +have [F0|] := eqVneq (\bigcup_n F n) set0. + rewrite [in X in _ --> X]/score F0 eqxx. + rewrite (_ : (fun _ => _) = cst 0). + by case: ifPn => _; exact: cvg_cst. + apply/funext => k; rewrite big1// => n _. + move : F0 => /bigcup0P F0. + by rewrite /score F0// eqxx; case: ifP. +move=> UF0; move: (UF0). +move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. +rewrite [in X in _ --> X]/score (negbTE UF0). +rewrite -(cvg_shiftn k.+1)/=. +case: ifPn => ir. + rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. + apply/funext => n. + rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. + rewrite [in X in X + _]/score (negbTE Fk0) ir big1 ?adde0// => /= j jk. + rewrite /score. + have /eqP Fj0 : F j == set0. + have [/eqP//|Fjtt] := set_unit (F j). + move/trivIsetP : tF => /(_ j k Logic.I Logic.I jk). + by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fk0). + rewrite Fj0 eqxx. + by case: ifP. +rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. +apply/funext => n. +rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. +rewrite [in X in if X then _ else _]/score (negbTE Fk0) (negbTE ir) add0e. +rewrite big1//= => j jk. +rewrite /score. +have /eqP Fj0 : F j == set0. + have [/eqP//|Fjtt] := set_unit (F j). + move/trivIsetP : tF => /(_ j k Logic.I Logic.I jk). + by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fk0). +rewrite Fj0 eqxx. +by case: ifP. +Qed. + +HB.instance Definition _ (i : nat) (t : T) := isMeasure.Build _ _ _ + (k_ mr i t) (k_0 i t) (k_ge0 i t) (@k_sigma_additive i t). + +Lemma measurable_fun_k_ (i : nat) U : measurable U -> measurable_fun setT (k_ mr i ^~ U). +Proof. +move=> /= mU. +rewrite /k_ /=. +rewrite (_ : (fun x : T => _) = (fun x => if (i%:R)%:E <= x < (i.+1%:R)%:E then x else 0) \o (fun x => score r x U)) //. +apply: measurable_fun_comp; last first. + rewrite /score. + have [U0|U0] := eqVneq U set0. + exact: measurable_fun_cst. + apply: measurable_fun_comp => //. + by apply/EFin_measurable_fun. +rewrite /=. +pose A : _ -> \bar R := (fun x : \bar R => x * (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set (\bar R)) x)%:E). +rewrite (_ : (fun x => _) = A); last first. + apply/funext => x; rewrite /A; case: ifPn => ix. + by rewrite indicE/= mem_set ?mule1//. + rewrite indicE/= memNset ?mule0//. + rewrite /= in_itv/=. + exact/negP. +rewrite /A. +apply emeasurable_funM => /=. + exact: measurable_fun_id. +apply/EFin_measurable_fun. +have mi : measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set (\bar R)). + exact: emeasurable_itv. +by rewrite (_ : \1__ = mindic R mi)//. +Qed. + +Definition mk_ i (t : T) := [the measure _ _ of k_ mr i t]. + +HB.instance Definition _ (i : nat) := + isKernel.Build _ _ _ _ R (mk_ i) (measurable_fun_k_ i). + +Lemma mk_uub (i : nat) : measure_fam_uub (mk_ i). +Proof. +exists i.+1%:R => /= t. +rewrite /k_ /score setT_unit. +rewrite (_ : [set tt] == set0 = false); last first. + by apply/eqP => /seteqP[] /(_ tt) /(_ erefl). +by case: ifPn => // /andP[]. +Qed. + +HB.instance Definition _ (i : nat) := + @isFiniteKernel.Build _ _ _ _ R (mk_ i) (mk_uub i). + +End score. +End SCORE. + +Section score_kernel. +Variables (R : realType) (d : _) (T : measurableType d). +Variables (r : T -> R). + +Definition kernel_score (mr : measurable_fun setT r) + : T -> {measure set Datatypes_unit__canonical__measure_Measurable -> \bar R} := + fun t => [the measure _ _ of score r t]. + +Variable (mr : measurable_fun setT r). + +Let measurable_fun_score U : measurable U -> measurable_fun setT (kernel_score mr ^~ U). +Proof. +move=> /= mU; rewrite /score. +have [U0|U0] := eqVneq U set0; first exact: measurable_fun_cst. +by apply: measurable_fun_comp => //; exact/EFin_measurable_fun. +Qed. + +HB.instance Definition _ := isKernel.Build _ _ T _ + (*Datatypes_unit__canonical__measure_Measurable*) R (kernel_score mr) measurable_fun_score. +End score_kernel. + +Section score_sfinite_kernel. +Variables (R : realType) (d : _) (T : measurableType d). +Variables (r : T -> R) (mr : measurable_fun setT r). + +Import SCORE. + +Let sfinite_score : exists k_ : (R.-fker T ~> _)^nat, + forall x U, measurable U -> + kernel_score mr x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. +rewrite /=. +exists (fun i => [the finite_kernel _ _ _ of mk_ mr i]) => /= r' U mU. +rewrite /mseries /score; case: ifPn => [/eqP U0|U0]. + by apply/esym/nneseries0 => i _; rewrite U0 measure0. +rewrite /mk_ /= /k_ /= /score (negbTE U0). +apply/esym/cvg_lim => //. +rewrite -(cvg_shiftn `|floor (fine `|(r r')%:E|)|%N.+1)/=. +rewrite (_ : (fun _ => _) = cst `|(r r')%:E|); first exact: cvg_cst. +apply/funext => n. +pose floor_r := widen_ord (leq_addl n `|floor `|(r r')| |.+1) (Ordinal (ltnSn `|floor `|(r r')| |)). +rewrite big_mkord (bigD1 floor_r)//= ifT; last first. + rewrite lee_fin lte_fin; apply/andP; split. + by rewrite natr_absz (@ger0_norm _ (floor `|(r r')|)) ?floor_ge0 ?floor_le. + by rewrite -addn1 natrD natr_absz (@ger0_norm _ (floor `|(r r')|)) ?floor_ge0 ?lt_succ_floor. +rewrite big1 ?adde0//= => j jk. +rewrite ifF// lte_fin lee_fin. +move: jk; rewrite neq_ltn/= => /orP[|] jr. +- suff : (j.+1%:R <= `|(r r')|)%R by rewrite leNgt => /negbTE ->; rewrite andbF. + rewrite (_ : j.+1%:R = j.+1%:~R)// floor_ge_int. + move: jr; rewrite -lez_nat => /le_trans; apply. + by rewrite -[leRHS](@ger0_norm _ (floor `|(r r')|)) ?floor_ge0. +- suff : (`|(r r')| < j%:R)%R by rewrite ltNge => /negbTE ->. + move: jr; rewrite -ltz_nat -(@ltr_int R) (@gez0_abs (floor `|(r r')|)) ?floor_ge0// ltr_int. + by rewrite -floor_lt_int. +Qed. + +HB.instance Definition _ := @isSFiniteKernel.Build _ _ _ _ _ + (kernel_score mr) sfinite_score. + +End score_sfinite_kernel. + +(* decomposition of if-then-else *) +Module ITE. +Section ite_true_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (u1 : R.-ker T ~> T'). + +Definition ite_true : T * bool -> {measure set T' -> \bar R} := + fun b => if b.2 then u1 b.1 else [the measure _ _ of mzero]. + +Lemma measurable_ite_true U : measurable U -> measurable_fun setT (ite_true ^~ U). +Proof. +move=> /= mcU. +rewrite /ite_true. +rewrite (_ : (fun x : T * bool => _) = (fun x => if x.2 then u1 x.1 U else [the {measure set T' -> \bar R} of mzero] U)); last first. + apply/funext => -[t b]/=. + by case: ifPn. +apply: (@measurable_fun_if _ _ _ _ (u1 ^~ U) (fun=> mzero U)). + exact/measurable_kernel. +exact: measurable_fun_cst. +Qed. + +HB.instance Definition _ := isKernel.Build _ _ _ _ R ite_true measurable_ite_true. +End ite_true_kernel. + +Section ite_true_finite_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (u1 : R.-fker T ~> T'). + +Lemma ite_true_uub : measure_fam_uub (ite_true u1). +Proof. +have /measure_fam_uubP[M hM] := kernel_uub u1. +exists M%:num => /= -[]; rewrite /ite_true => t [|]/=. + exact: hM. +by rewrite /= /mzero. +Qed. + +HB.instance Definition _ t := + isFiniteKernel.Build _ _ _ _ R (ite_true u1) ite_true_uub. +End ite_true_finite_kernel. + +Section ite_true_sfinite_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (u1 : R.-sfker T ~> T'). + +Let sfinite_ite_true : exists k_ : (R.-fker _ ~> _)^nat, + forall x U, measurable U -> + ite_true u1 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. +have [k hk /=] := sfinite u1. +rewrite /ite_true. +exists (fun n => [the _.-fker _ ~> _ of ite_true (k n)]) => b U mU. +case: ifPn => hb. + rewrite /mseries hk//= /mseries. + apply: eq_nneseries => n _. + by rewrite /ite_true hb. +rewrite /= /mseries nneseries0// => n _. +by rewrite /ite_true (negbTE hb). +Qed. + +HB.instance Definition _ t := + @isSFiniteKernel.Build _ _ _ _ _ (ite_true u1) sfinite_ite_true. + +End ite_true_sfinite_kernel. + +Section ite_false_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (u2 : R.-ker T ~> T'). + +Definition ite_false : T * bool -> {measure set T' -> \bar R} := + fun b => if ~~ b.2 then u2 b.1 else [the measure _ _ of mzero]. + +Let measurable_ite_false U : measurable U -> measurable_fun setT (ite_false ^~ U). +Proof. +move=> /= mcU. +rewrite /ite_false. +rewrite (_ : (fun x => _) = (fun x => if x.2 then [the {measure set T' -> \bar R} of mzero] U else u2 x.1 U)); last first. + apply/funext => -[t b]/=. + rewrite if_neg/=. + by case: b. +apply: (@measurable_fun_if _ _ _ _ (fun=> mzero U) (u2 ^~ U)). + exact: measurable_fun_cst. +exact/measurable_kernel. +Qed. + +HB.instance Definition _ := isKernel.Build _ _ _ _ R ite_false measurable_ite_false. + +End ite_false_kernel. + +Section ite_false_finite_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (u2 : R.-fker T ~> T'). + +Let ite_false_uub : measure_fam_uub (ite_false u2). +Proof. +have /measure_fam_uubP[M hM] := kernel_uub u2. +exists M%:num => /= -[]; rewrite /ite_false/= => t b. +case: b => //=. +by rewrite /mzero. +Qed. + +HB.instance Definition _ := + isFiniteKernel.Build _ _ _ _ R (ite_false u2) ite_false_uub. + +End ite_false_finite_kernel. + +Section ite_false_sfinite_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). +Variables (u2 : R.-sfker T ~> T'). + +Let sfinite_ite_false : exists k_ : (R.-fker _ ~> _)^nat, + forall x U, measurable U -> + ite_false u2 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. +have [k hk] := sfinite u2. +rewrite /= /ite_false. +exists (fun n => [the finite_kernel _ _ _ of ite_false (k n)]) => b U mU. +case: ifPn => hb. + rewrite /mseries hk//= /mseries/=. + apply: eq_nneseries => // n _. + by rewrite /ite_false hb. +rewrite /= /mseries nneseries0// => n _. +rewrite negbK in hb. +by rewrite /ite_false hb/=. +Qed. + +HB.instance Definition _ := + @isSFiniteKernel.Build _ _ _ _ _ (ite_false u2) sfinite_ite_false. + +End ite_false_sfinite_kernel. +End ITE. + Section ite. Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). Variables (R : realType) (f : T -> bool) (u1 u2 : R.-sfker T ~> T'). @@ -40,7 +425,9 @@ Qed. HB.instance Definition _ tb := isMeasure.Build _ _ _ (ite mf tb) (ite0 tb) (ite_ge0 tb) (@ite_sigma_additive tb). -Definition ite' : R.-sfker +Import ITE. + +Let ite' : R.-sfker [the measurableType _ of (T * bool)%type] ~> T' := [the R.-sfker _ ~> _ of add_of_kernels [the R.-sfker _ ~> T' of ite_true u1] @@ -52,29 +439,17 @@ End ite. Section bernoulli27. Variable R : realType. - Local Open Scope ring_scope. -Notation "'2/7'" := (2%:R / 7%:R)%:nng. Definition twoseven : {nonneg R} := (2%:R / 7%:R)%:nng. Definition fiveseven : {nonneg R} := (5%:R / 7%:R)%:nng. -Definition bernoulli27 : set _ -> \bar R := - measure_add - [the measure _ _ of mscale twoseven [the measure _ _ of dirac true]] - [the measure _ _ of mscale fiveseven [the measure _ _ of dirac false]]. - -HB.instance Definition _ := Measure.on bernoulli27. - -Local Close Scope ring_scope. +Lemma onem_twoseven : onem (2 / 7) = fiveseven%:num. +Proof. by apply/eqP; rewrite subr_eq/= -mulrDl -natrD divrr// unitfE. Qed. -Lemma bernoulli27_setT : bernoulli27 [set: _] = 1. -Proof. -rewrite /bernoulli27/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. -rewrite /mscale/= !diracE !in_setT !mule1 -EFinD. -by rewrite -mulrDl -natrD divrr// unitfE pnatr_eq0. -Qed. +Lemma twoseven_proof : (twoseven%:num <= 1 :> R)%R. +Proof. by rewrite /= lter_pdivr_mulr// mul1r ler_nat. Qed. -HB.instance Definition _ := @isProbability.Build _ _ R bernoulli27 bernoulli27_setT. +Definition bernoulli27 : set _ -> \bar R := bernoulli twoseven_proof. End bernoulli27. @@ -86,7 +461,7 @@ Definition letin (d d' d3 : _) (l : R.-sfker X ~> Y) (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) : R.-sfker X ~> Z := - [the sfinite_kernel _ _ _ of (l \; k)]. + [the sfinite_kernel _ _ _ of l \; k]. Definition Return (d d' : _) (T : measurableType d) (T' : measurableType d') (f : T -> T') (mf : measurable_fun setT f) : R.-sfker T ~> T' := @@ -104,6 +479,27 @@ Definition Score (d : _) (T : measurableType d) (r : T -> R) (mr : measurable_fu R.-sfker T ~> Datatypes_unit__canonical__measure_Measurable := [the sfinite_kernel _ _ R of @kernel_score R _ _ r mr]. +Lemma ScoreE (d : _) (T : measurableType d) (t : T) (U : set bool) (n : nat) (b : bool) + (f : R -> R) (f0 : forall r, (0 <= r)%R -> (0 <= f r)%R) (mf : measurable_fun setT f) : + Score (measurable_fun_comp mf (@measurable_fun_snd _ _ _ _)) + (t, b, cst n%:R (t, b)) + ((fun y : unit => (snd \o fst) (t, b, y)) @^-1` U) = + (f n%:R)%:E * \d_b U. +Proof. +rewrite /Score/= /score/= diracE. +have [U0|U0] := set_unit ((fun=> b) @^-1` U). +- rewrite U0 eqxx memNset ?mule0//. + move=> Ub. + move: U0. + move/seteqP => [/(_ tt)] /=. + by move/(_ Ub). +- rewrite U0 setT_unit ifF//; last first. + by apply/negbTE/negP => /eqP/seteqP[/(_ tt erefl)]. + rewrite /= mem_set//; last first. + by move: U0 => /seteqP[_]/(_ tt)/=; exact. + by rewrite mule1 ger0_norm// f0. +Qed. + Definition Ite (d d' : _) (T : measurableType d) (T' : measurableType d') (f : T -> bool) (mf : measurable_fun setT f) (u1 u2 : R.-sfker T ~> T') @@ -119,10 +515,10 @@ rewrite /= /kcomp /ite. rewrite integral_dirac//=. rewrite indicT /cst. rewrite mul1e. -rewrite -/(measure_add (ite_true u1 (tb, f tb)) - (ite_false u2 (tb, f tb))). +rewrite -/(measure_add (ITE.ite_true u1 (tb, f tb)) + (ITE.ite_false u2 (tb, f tb))). rewrite measure_addE. -rewrite /ite_true /ite_false/=. +rewrite /ITE.ite_true /ITE.ite_false/=. case: (ifPn (f tb)) => /=. by rewrite /mzero adde0. by rewrite /mzero add0e. @@ -222,27 +618,6 @@ Definition k10 : measurable_fun _ _ := kn 10. End cst_fun. -Lemma ScoreE (R : realType) (d : _) (T : measurableType d) (t : T) (U : set bool) (n : nat) (b : bool) - (f : R -> R) (f0 : forall r, (0 <= r)%R -> (0 <= f r)%R) (mf : measurable_fun setT f) : - Score (measurable_fun_comp mf (@measurable_fun_snd _ _ _ _)) - (t, b, cst n%:R (t, b)) - ((fun y : unit => (snd \o fst) (t, b, y)) @^-1` U) = - (f n%:R)%:E * \d_b U. -Proof. -rewrite /Score/= /mscore/= diracE. -have [U0|U0] := set_unit ((fun=> b) @^-1` U). -- rewrite U0 eqxx memNset ?mule0//. - move=> Ub. - move: U0. - move/seteqP => [/(_ tt)] /=. - by move/(_ Ub). -- rewrite U0 setT_unit ifF//; last first. - by apply/negbTE/negP => /eqP/seteqP[/(_ tt erefl)]. - rewrite /= mem_set//; last first. - by move: U0 => /seteqP[_]/(_ tt)/=; exact. - by rewrite mule1 ger0_norm// f0. -Qed. - Lemma letin_sample_bernoulli27 (R : realType) (d d' : _) (T : measurableType d) (T' : measurableType d') (u : R.-sfker [the measurableType _ of (T * bool)%type] ~> T') x y : @@ -254,47 +629,43 @@ rewrite ge0_integral_measure_sum//. rewrite 2!big_ord_recl/= big_ord0 adde0/=. rewrite !ge0_integral_mscale//=. rewrite !integral_dirac//=. -by rewrite indicE in_setT mul1e indicE in_setT mul1e. +rewrite indicE in_setT mul1e indicE in_setT mul1e. +by rewrite onem_twoseven. Qed. -(* *) - -Section program1. +Section sample_and_return. Variables (R : realType) (d : _) (T : measurableType d). -Definition program1 : R.-sfker T ~> _ := +Definition sample_and_return : R.-sfker T ~> _ := letin (sample_bernoulli27 R T) (* T -> B *) (Return R (@measurable_fun_snd _ _ _ _)) (* T * B -> B *). -Lemma program1E (t : T) (U : _) : program1 t U = - ((twoseven R)%:num)%:E * \d_true U + - ((fiveseven R)%:num)%:E * \d_false U. -Proof. -rewrite /program1. -by rewrite letin_sample_bernoulli27. -Qed. +Lemma sample_and_returnE t U : sample_and_return t U = + (twoseven R)%:num%:E * \d_true U + + (fiveseven R)%:num%:E * \d_false U. +Proof. by rewrite letin_sample_bernoulli27. Qed. -End program1. +End sample_and_return. -Section program2. +Section sample_and_score. Variables (R : realType) (d : _) (T : measurableType d). -Definition program2 : R.-sfker T ~> _ := +Definition sample_and_score : R.-sfker T ~> _ := letin (sample_bernoulli27 R T) (* T -> B *) - (Score (measurable_fun_cst (1%:R : R))). + (Score (measurable_fun_cst (1%R : R))). -End program2. +End sample_and_score. -Section program3. +Section sample_and_branch. Variables (R : realType) (d : _) (T : measurableType d). (* let x = sample (bernoulli (2/7)) in let r = case x of {(1, _) => return (k3()), (2, _) => return (k10())} in return r *) -Definition program3 : +Definition sample_and_branch : R.-sfker T ~> [the measurableType default_measure_display of Real_sort__canonical__measure_Measurable R] := letin (sample_bernoulli27 R T) (* T -> B *) @@ -302,19 +673,14 @@ Definition program3 : (Return R (@k3 _ _ [the measurableType _ of (T * bool)%type])) (Return R (@k10 _ _ [the measurableType _ of (T * bool)%type]))). -Lemma program3E (t : T) (U : _) : program3 t U = - ((twoseven R)%:num)%:E * \d_(3%:R : R) U + - ((fiveseven R)%:num)%:E * \d_(10%:R : R) U. -Proof. -rewrite /program3 letin_sample_bernoulli27. -congr (_ * _ + _ * _). -by rewrite IteE. -by rewrite IteE. -Qed. +Lemma sample_and_branchE t U : sample_and_branch t U = + (twoseven R)%:num%:E * \d_(3%R : R) U + + (fiveseven R)%:num%:E * \d_(10%R : R) U. +Proof. by rewrite /sample_and_branch letin_sample_bernoulli27 !IteE. Qed. -End program3. +End sample_and_branch. -Section program4. +Section staton_bus. Variables (R : realType) (d : _) (T : measurableType d). (* let x = sample (bernoulli (2/7)) in @@ -322,25 +688,47 @@ Variables (R : realType) (d : _) (T : measurableType d). let _ = score (1/4! r^4 e^-r) in return x *) -Definition program4 : R.-sfker T ~> Datatypes_bool__canonical__measure_Measurable := +Let mR := Real_sort__canonical__measure_Measurable R. +Let munit := Datatypes_unit__canonical__measure_Measurable. +Let mbool := Datatypes_bool__canonical__measure_Measurable. + +Notation var2_of2 := (@measurable_fun_snd _ _ _ _). +Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) (@measurable_fun_fst _ _ _ _)). +Notation var3_of3 := (@measurable_fun_snd _ _ _ _). + +Definition staton_bus' : R.-sfker T ~> mbool := letin - (sample_bernoulli27 R T) (* T -> B *) + (sample_bernoulli27 R T : _.-sfker T ~> mbool) (letin - (letin (* T * B -> unit *) - (Ite (@measurable_fun_snd _ _ _ _) - (Return R (@k3 _ _ [the measurableType _ of (T * bool)%type])) - (Return R (@k10 _ _ [the measurableType _ of (T * bool)%type]))) (* T * B -> R *) - (Score (measurable_fun_comp (@mpoisson R 4) (@measurable_fun_snd _ _ _ _))) (* B * R -> unit *)) - (Return R (measurable_fun_comp (@measurable_fun_snd _ _ _ _) (@measurable_fun_fst _ _ _ _)))). + (letin + (Ite var2_of2 + (Return R (@k3 _ _ _)) + (Return R (@k10 _ _ _)) + : _.-sfker [the measurableType _ of (T * bool)%type] ~> mR) + (Score (measurable_fun_comp (@mpoisson R 4) var3_of3) + : _.-sfker [the measurableType _ of (T * bool* mR)%type] ~> munit) + : _.-sfker [the measurableType _ of (T * bool)%type] ~> munit) + (Return R var2_of3 + : _.-sfker [the measurableType _ of (T * bool * munit)%type] ~> mbool) + : _.-sfker [the measurableType _ of (T * bool)%type] ~> mbool). + +Definition staton_bus : R.-sfker T ~> mbool := + letin (sample_bernoulli27 R T) + (letin + (letin (Ite var2_of2 + (Return R (@k3 _ _ _)) + (Return R (@k10 _ _ _))) + (Score (measurable_fun_comp (@mpoisson R 4) var3_of3))) + (Return R var2_of3)). (* 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 program4E (t : T) (U : _) : program4 t U = - ((twoseven R)%:num)%:E * (poisson 3%:R 4)%:E * \d_(true) U + - ((fiveseven R)%:num)%:E * (poisson 10%:R 4)%:E * \d_(false) U. +Lemma staton_busE t U : staton_bus t U = + (twoseven R)%:num%:E * (poisson 3%:R 4)%:E * \d_true U + + (fiveseven R)%:num%:E * (poisson 10%:R 4)%:E * \d_false U. Proof. -rewrite /program4. +rewrite /staton_bus. rewrite letin_sample_bernoulli27. rewrite -!muleA. congr (_ * _ + _ * _). @@ -354,4 +742,4 @@ rewrite letin_returnu//. by rewrite ScoreE// => r r0; exact: poisson_ge0. Qed. -End program4. +End staton_bus. From b305e8c9b3f2fd1ff42463a2f4d2bb6641576215 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Fri, 19 Aug 2022 15:13:01 +0900 Subject: [PATCH 11/54] complete normalize, finite fubini, improve hier with pker --- theories/kernel.v | 583 ++++++++++++++++++++++++++++++++++++++----- theories/prob_lang.v | 134 +++++++++- 2 files changed, 645 insertions(+), 72 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 266960f527..3bb04fa77a 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -9,8 +9,9 @@ Require Import lebesgue_measure fsbigop numfun lebesgue_integral. (* Kernels *) (* *) (* R.-ker X ~> Y == kernel *) -(* R.-fker X ~> Y == finite kernel *) (* R.-sfker X ~> Y == s-finite kernel *) +(* R.-fker X ~> Y == finite kernel *) +(* R.-pker X ~> Y == probability kernel *) (* sum_of_kernels == *) (* l \; k == composition of kernels *) (* kernel_mfun == kernel defined by a measurable function *) @@ -42,7 +43,9 @@ Variables (d : _) (T : measurableType d) (R : realType) (P : probability T R). Lemma probability_le1 (A : set T) : measurable A -> (P A <= 1)%E. Proof. -Admitted. +move=> mA; rewrite -(@probability_setT _ _ _ P). +by apply: le_measure => //; rewrite ?in_setE. +Qed. End probability_lemmas. (* /PR 516 in progress *) @@ -253,30 +256,96 @@ Lemma measurable_curry (T1 T2 : Type) (d : _) (T : semiRingOfSetsType d) measurable (G x) <-> measurable (curry G x.1 x.2). Proof. by case: x. Qed. -Lemma measurable_fun_if0 (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') +Lemma measurable_fun_if000 (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') + D (md : measurable D) (f : T -> bool) (mf : measurable_fun setT f) : + measurable_fun (D `&` [set b | f b ]) x -> + measurable_fun (D `&` [set b | ~~ f b]) y -> + measurable_fun D (fun b : T => if f b then x b else y b). +Proof. +move=> mx my /= _ Y mY. +have H1 : measurable (D `&` [set b | f b]). + apply: measurableI => //. + rewrite [X in measurable X](_ : _ = f @^-1` [set true])//. + have := mf measurableT [set true]. + rewrite setTI. + exact. +have := mx H1 Y mY. +have H0 : [set t | ~~ f t] = [set t | f t = false]. + by apply/seteqP; split => [t/= /negbTE//|t/= ->]. +have H2 : measurable (D `&` [set b | ~~ f b]). + apply: measurableI => //. + have := mf measurableT [set false]. + rewrite setTI. + rewrite /preimage/=. + by rewrite H0; exact. +have := my H2 Y mY. +move=> yY xY. +rewrite (_ : _ @^-1` Y = ([set b | f b = true] `&` (x @^-1` Y) `&` (f @^-1` [set true])) `|` + ([set b | f b = false] `&` (y @^-1` Y) `&` (f @^-1` [set false]))); last first. + apply/seteqP; split. + move=> t/=; case: ifPn => ft. + by left. + by right. + by move=> t/= [|]; case: ifPn => ft; case=> -[]. +rewrite setIUr. +apply: measurableU. + rewrite -(setIid D). + rewrite -(setIA D). + rewrite setICA. + rewrite setIA. + apply: measurableI => //. + by rewrite setIA. + + rewrite -(setIid D). + rewrite -(setIA D). + rewrite setICA. + rewrite setIA. + rewrite /preimage/=. + rewrite -H0. + apply: measurableI => //. + by rewrite setIA. +Qed. + +Lemma measurable_fun_if00 (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') (f : T -> bool) (mf : measurable_fun setT f) : - measurable_fun setT x -> - measurable_fun setT y -> + measurable_fun [set b | f b = true] x -> + measurable_fun [set b | f b = false] y -> measurable_fun setT (fun b : T => if f b then x b else y b). Proof. move=> mx my /= _ Y mY. rewrite setTI. -have := mx measurableT Y mY. -rewrite setTI => xY. -have := my measurableT Y mY. -rewrite setTI => yY. -rewrite (_ : _ @^-1` Y = ((x @^-1` Y) `&` (f @^-1` [set true])) `|` - ((y @^-1` Y) `&` (f @^-1` [set false]))); last first. +have H1 : measurable [set b | f b = true]. +rewrite [X in measurable X](_ : _ = f @^-1` [set true])//. + have := mf measurableT [set true]. + rewrite setTI. + exact. +have := mx H1 Y mY. +have H2 : measurable [set b | f b = false]. + have := mf measurableT [set false]. + rewrite setTI. + exact. +have := my H2 Y mY. +move=> yY xY. +rewrite (_ : _ @^-1` Y = ([set b | f b = true] `&` (x @^-1` Y) `&` (f @^-1` [set true])) `|` + ([set b | f b = false] `&` (y @^-1` Y) `&` (f @^-1` [set false]))); last first. apply/seteqP; split. move=> t/=; case: ifPn => ft. by left. by right. - by move=> t/=; case: ifPn => ft; case=> -[]. -apply: measurableU; apply: measurableI => //. - have := mf measurableT [set true]. - by rewrite setTI; exact. -have := mf measurableT [set false]. -by rewrite setTI; exact. + by move=> t/= [|]; case: ifPn => ft; case=> -[]. +by apply: measurableU; apply: measurableI => //. +Qed. + +Lemma measurable_fun_if0 (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') + (f : T -> bool) (mf : measurable_fun setT f) : + measurable_fun setT x -> + measurable_fun setT y -> + measurable_fun setT (fun b : T => if f b then x b else y b). +Proof. +move=> mx my. +apply: measurable_fun_if000 => //. +by apply: measurable_funS mx. +by apply: measurable_funS my. Qed. Lemma measurable_fun_if (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') : @@ -317,6 +386,7 @@ Qed. Reserved Notation "R .-ker X ~> Y" (at level 42). Reserved Notation "R .-fker X ~> Y" (at level 42). Reserved Notation "R .-sfker X ~> Y" (at level 42). +Reserved Notation "R .-pker X ~> Y" (at level 42). HB.mixin Record isKernel d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) := @@ -368,20 +438,6 @@ Proof. by move=> f0 mf; rewrite /sum_of_kernels/= ge0_integral_measure_series. Qed. -(* TODO: define using the probability type *) -HB.mixin Record isProbabilityKernel - d d' (X : measurableType d) (Y : measurableType d') - (R : realType) (k : X -> {measure set Y -> \bar R}) - of isKernel _ _ X Y R k := { - prob_kernelP : forall x, k x [set: Y] = 1 -}. - -#[short(type=probability_kernel)] -HB.structure Definition ProbabilityKernel - (d d' : _) (X : measurableType d) (Y : measurableType d') - (R : realType) := - {k of isProbabilityKernel _ _ X Y R k & isKernel _ _ X Y R k}. - Section measure_fam_uub. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). Variables (R : numFieldType) (k : X -> {measure set Y -> \bar R}). @@ -473,6 +529,70 @@ Qed. End finite_is_sfinite. +(* TODO: define using the probability type *) +HB.mixin Record isProbabilityFam + d d' (X : measurableType d) (Y : measurableType d') + (R : realType) (k : X -> {measure set Y -> \bar R}) + := { + prob_kernelP : forall x, k x [set: Y] = 1 +}. + +#[short(type=probability_kernel)] +HB.structure Definition ProbabilityKernel + (d d' : _) (X : measurableType d) (Y : measurableType d') + (R : realType) := + {k of isProbabilityFam _ _ X Y R k & isKernel _ _ X Y R k & isFiniteKernel _ _ X Y R k & isSFiniteKernel _ _ X Y R k}. +Notation "R .-pker X ~> Y" := (probability_kernel X Y R). + +HB.factory Record isProbabilityKernel + d d' (X : measurableType d) (Y : measurableType d') + (R : realType) (k : X -> {measure set Y -> \bar R}) of isKernel _ _ X Y R k := { + prob_kernelP2 : forall x, k x [set: Y] = 1 +}. + +HB.builders Context d d' (X : measurableType d) (Y : measurableType d') + (R : realType) k of isProbabilityKernel d d' X Y R k. + +Lemma is_finite_kernel : measure_fam_uub k. +Proof. +exists 2%R => /= ?. +rewrite (@le_lt_trans _ _ 1%:E)//. +rewrite prob_kernelP2//. +by rewrite lte_fin ltr1n. +Qed. + +HB.instance Definition _ := @isFiniteKernel.Build _ _ _ _ _ _ is_finite_kernel. + +Lemma is_sfinite_kernel : exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> + k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. +exact: sfinite_finite. +Qed. + +HB.instance Definition _ := @isSFiniteKernel.Build _ _ _ _ _ _ is_sfinite_kernel. + +Lemma is_probability_kernel : forall x, k x setT = 1. +Proof. +exact/prob_kernelP2. +Qed. + +HB.instance Definition _ := @isProbabilityFam.Build _ _ _ _ _ _ is_probability_kernel. + +HB.end. + +(*Section tmp. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType) + (f : R.-fker T ~> T'). + +Let tmp : exists k_ : (R.-fker _ ~> _)^nat, + forall x U, measurable U -> + f x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. exact: sfinite_finite. Qed. + +HB.instance Definition _ := + @isSFiniteKernel.Build d d' T T' R f tmp. +End tmp.*) + (* see measurable_prod_subset in lebesgue_integral.v; the differences between the two are: - m2 is a kernel instead of a measure @@ -770,6 +890,7 @@ pose L := [the kernel _ _ _ of sum_of_kernels l_]. have H1 x U : measurable U -> (l \; k) x U = (L \; K) x U. move=> mU /=. rewrite /kcomp /L /K /=. + (* TODO: lemma so that we can get away with a rewrite *) transitivity (\int[ [the measure _ _ of mseries (l_ ^~ x) 0] ]_y k (x, y) U). by apply eq_measure_integral => A mA _; rewrite hl_. @@ -1023,47 +1144,158 @@ Qed. End integral_kcomp. -(* semantics for a sample operation *) -Section kernel_probability. -Variables (d : _) (R : realType) (X : measurableType d). -Variables (d' : _) (T' : measurableType d'). -Variable m : probability X R. +Definition finite_measure d (T : measurableType d) (R : realType) (mu : set T -> \bar R) := + mu setT < +oo. -Definition kernel_probability : T' -> {measure set X -> \bar R} := - fun _ : T' => m. +Lemma finite_kernel_finite_measure d (T : measurableType d) (R : realType) + (mu : R.-fker Datatypes_unit__canonical__measure_Measurable ~> T) : + finite_measure (mu tt). +Proof. +have [M muM] := kernel_uub mu. +by rewrite /finite_measure (lt_le_trans (muM tt))// leey. +Qed. -Lemma kernel_probabilityP : forall U, measurable U -> - measurable_fun setT (kernel_probability ^~ U). +Lemma finite_measure_sigma_finite d (T : measurableType d) (R : realType) + (mu : {measure set T -> \bar R}) : + finite_measure mu -> sigma_finite setT mu. Proof. -move=> U mU. -rewrite /kernel_probability. -exact: measurable_fun_cst. +rewrite /finite_measure => muoo. +exists (fun i => if i \in [set 0%N] then setT else set0). + by rewrite -bigcup_mkcondr setTI bigcup_const//; exists 0%N. +move=> n; split; first by case: ifPn. +by case: ifPn => // _; rewrite measure0. Qed. -HB.instance Definition _ := - @isKernel.Build _ _ _ X R kernel_probability - kernel_probabilityP. +Section finite_fubini. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). +Variables (mu : {measure set X -> \bar R}) (fmu : finite_measure mu). +Variables (la : {measure set Y -> \bar R}) (fla : finite_measure la). +Variables (f : X * Y -> \bar R) (f0 : forall xy, 0 <= f xy). +Variables (mf : measurable_fun setT f). -Lemma kernel_probability_uub : measure_fam_uub kernel_probability. +Lemma finite_fubini : + \int[mu]_x \int[la]_y f (x, y) = \int[la]_y \int[mu]_x f (x, y). Proof. -(*NB: shouldn't this work? exists 2%:pos. *) -exists 2%R => /= ?. -rewrite (le_lt_trans (probability_le1 m measurableT))//. -by rewrite lte_fin ltr_addr. +rewrite -fubini_tonelli1//. + exact: finite_measure_sigma_finite. +move=> H. +rewrite fubini_tonelli2//. +exact: finite_measure_sigma_finite. +Qed. + +End finite_fubini. + +Section sfinite_fubini. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). +Variables (mu : R.-sfker Datatypes_unit__canonical__measure_Measurable ~> X). +Variables (la : R.-sfker Datatypes_unit__canonical__measure_Measurable ~> Y). +Variables (f : X * Y -> \bar R) (f0 : forall xy, 0 <= f xy). +Variable (mf : measurable_fun setT f). + +Lemma sfinite_fubini : + \int[mu tt]_x \int[la tt]_y f (x, y) = \int[la tt]_y \int[mu tt]_x f (x, y). +Proof. +have [mu_ mu_E] := sfinite mu. +have [la_ la_E] := sfinite la. +transitivity ( + \int[[the measure _ _ of mseries (fun i => mu_ i tt) 0]]_x + \int[la tt]_y f (x, y)). + apply: eq_measure_integral => U mU _. (* TODO: awkward *) + by rewrite mu_E. +transitivity ( + \int[[the measure _ _ of mseries (fun i => mu_ i tt) 0]]_x + \int[[the measure _ _ of mseries (fun i => la_ i tt) 0]]_y f (x, y)). + apply eq_integral => x _. + apply: eq_measure_integral => U mU _. (* TODO: awkward *) + by rewrite la_E. +transitivity (\sum_(n t _; exact: integral_ge0 => x _. +(* have := @measurable_fun_integral_sfinite_kernel _ _ _ Y R la. + rewrite /=.*) + rewrite /=. + rewrite [X in measurable_fun _ X](_ : _ = + fun x => \sum_(n x. + rewrite ge0_integral_measure_series//. + exact/measurable_fun_prod1. + apply: ge0_emeasurable_fun_sum => //. + move=> k x. + by apply: integral_ge0. + move=> k. + apply: measurable_fun_fubini_tonelli_F => //=. + apply: finite_measure_sigma_finite. + exact: finite_kernel_finite_measure. + apply: eq_nneseries => n _; apply eq_integral => x _. + rewrite ge0_integral_measure_series//. + exact/measurable_fun_prod1. +transitivity (\sum_(n n _. + rewrite integral_sum(*TODO: ge0_integral_sum*)//. + move=> m. + apply: measurable_fun_fubini_tonelli_F => //=. + apply: finite_measure_sigma_finite. + exact: finite_kernel_finite_measure. + by move=> m x _; exact: integral_ge0. +transitivity (\sum_(n n _; apply eq_nneseries => m _. + rewrite finite_fubini//. + exact: finite_kernel_finite_measure. + exact: finite_kernel_finite_measure. +transitivity (\sum_(n la_ i tt) 0]]_y \int[mu_ n tt]_x f (x, y)). + apply eq_nneseries => n _. + rewrite /= ge0_integral_measure_series//. + by move=> y _; exact: integral_ge0. + apply: measurable_fun_fubini_tonelli_G => //=. + apply: finite_measure_sigma_finite. + exact: finite_kernel_finite_measure. +rewrite /=. +transitivity (\int[[the measure _ _ of mseries (fun i => la_ i tt) 0]]_y \sum_(n n. + apply: measurable_fun_fubini_tonelli_G => //=. + apply: finite_measure_sigma_finite. + exact: finite_kernel_finite_measure. + by move=> n y _; exact: integral_ge0. +rewrite /=. +transitivity (\int[[the measure _ _ of mseries (fun i => la_ i tt) 0]]_y \int[[the measure _ _ of mseries (fun i => mu_ i tt) 0]]_x f (x, y)). + apply eq_integral => y _. + rewrite ge0_integral_measure_series//. + exact/measurable_fun_prod2. +rewrite /=. +transitivity ( + \int[la tt]_y \int[mseries (fun i : nat => mu_ i tt) 0]_x f (x, y) +). + apply eq_measure_integral => A mA _ /=. + by rewrite la_E. +apply eq_integral => y _. +apply eq_measure_integral => A mA _ /=. +by rewrite mu_E. Qed. +End sfinite_fubini. + +(* semantics for a sample operation *) +Section kernel_probability. +Variables (d d' : _) (R : realType) (X : measurableType d) (T' : measurableType d'). +Variable m : probability X R. + +Definition kernel_probability : T' -> {measure set X -> \bar R} := + fun _ : T' => m. + +Lemma kernel_probabilityP U : measurable U -> + measurable_fun setT (kernel_probability ^~ U). +Proof. by move=> mU; exact: measurable_fun_cst. Qed. + HB.instance Definition _ := - @isFiniteKernel.Build _ _ _ X R kernel_probability - kernel_probability_uub. + @isKernel.Build _ _ _ X R kernel_probability kernel_probabilityP. -Lemma sfinite_kernel_probability : exists k_ : (R.-fker _ ~> _)^nat, - forall x U, measurable U -> - kernel_probability x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. exact: sfinite_finite. Qed. +Lemma kernel_probability' x : kernel_probability x [set: X] = 1. +Proof. by rewrite /kernel_probability/= probability_setT. Qed. HB.instance Definition _ := - @isSFiniteKernel.Build _ _ _ X R kernel_probability - sfinite_kernel_probability. + @isProbabilityKernel.Build _ _ _ X R kernel_probability kernel_probability'. End kernel_probability. @@ -1178,25 +1410,29 @@ Variables (R : realType) (f : T -> {measure set T' -> \bar R}) (P : probability Definition normalize (t : T) (U : set T') := let evidence := f t setT in - if (evidence == 0%E) || (evidence == +oo) then P U + if evidence == 0%E then P U + else if evidence == +oo then P U else f t U * (fine evidence)^-1%:E. Lemma normalize0 t : normalize t set0 = 0. Proof. rewrite /normalize. case: ifPn => // _. +case: ifPn => // _. by rewrite measure0 mul0e. Qed. Lemma normalize_ge0 t U : 0 <= normalize t U. Proof. -by rewrite /normalize; case: ifPn. +by rewrite /normalize; case: ifPn => //; case: ifPn. Qed. Lemma normalize_sigma_additive t : semi_sigma_additive (normalize t). Proof. move=> F mF tF mUF. rewrite /normalize/=. +case: ifPn => [_|_]. + exact: measure_semi_sigma_additive. case: ifPn => [_|_]. exact: measure_semi_sigma_additive. rewrite (_ : (fun n => _) = ((fun n=> \sum_(0 <= i < n) f t (F i)) \* cst ((fine (f t [set: T']))^-1)%:E)); last first. @@ -1211,13 +1447,234 @@ Lemma normalize1 t : normalize t setT = 1. Proof. rewrite /normalize; case: ifPn. by rewrite probability_setT. -rewrite negb_or => /andP[ft0 ftoo]. +case: ifPn. + by rewrite probability_setT. +move=> ftoo ft0. have ? : f t [set: T'] \is a fin_num. by rewrite ge0_fin_numE// lt_neqAle ftoo/= leey. rewrite -{1}(@fineK _ (f t setT))//. -rewrite -EFinM divrr// ?unitfE fine_eq0//. +by rewrite -EFinM divrr// ?unitfE fine_eq0. Qed. HB.instance Definition _ t := isProbability.Build _ _ _ (normalize t) (normalize1 t). End normalize_measure. + +Section measurable_fun_comp. +Variables (d1 d2 d3 : measure_display). +Variables (T1 : measurableType d1). +Variables (T2 : measurableType d2). +Variables (T3 : measurableType d3). + +Lemma measurable_fun_comp_new F (f : T2 -> T3) E (g : T1 -> T2) : + measurable F -> + g @` E `<=` F -> + measurable_fun F f -> measurable_fun E g -> measurable_fun E (f \o g). +Proof. +move=> mF FgE mf mg /= mE A mA. +rewrite comp_preimage. +rewrite [X in measurable X](_ : _ = (E `&` g @^-1` (F `&` f @^-1` A))); last first. + apply/seteqP; split. + move=> x/= [Ex Afgx]; split => //; split => //. + by apply: FgE => //. + by move=> x/= [Ex] [Fgx Afgx]. +apply/mg => //. +by apply: mf => //. +Qed. + +End measurable_fun_comp. + +Lemma open_continuousP (S T : topologicalType) (f : S -> T) (D : set S) : + open D -> + {in D, continuous f} <-> (forall A, open A -> open (D `&` f @^-1` A)). +Proof. +move=> oD; split=> [fcont|fcont s /[!inE] sD A]. + rewrite !openE => A Aop s [Ds] /Aop /fcont; rewrite inE => /(_ Ds) fsA. + by rewrite interiorI; split => //; move: oD; rewrite openE; exact. +rewrite nbhs_simpl /= !nbhsE => - [B [[oB Bfs] BA]]. +by exists (D `&` f @^-1` B); split=> [|t [Dt] /BA//]; split => //; exact/fcont. +Qed. + +Lemma open_continuous_measurable_fun (R : realType) (f : R -> R) D : + open D -> {in D, continuous f} -> measurable_fun D f. +Proof. +move=> oD /(open_continuousP _ oD) cf. +apply: (measurability (RGenOpens.measurableE R)) => _ [_ [a [b ->] <-]]. +by apply: open_measurable; exact/cf/interval_open. +Qed. + +Lemma set_boolE (B : set bool) : [\/ B == [set true], B == [set false], B == set0 | B == setT]. +Proof. +have [Bt|Bt] := boolP (true \in B). + have [Bf|Bf] := boolP (false \in B). + have -> : B = setT. + by apply/seteqP; split => // -[] _; [rewrite inE in Bt| rewrite inE in Bf]. + apply/or4P. + by rewrite eqxx/= !orbT. + have -> : B = [set true]. + apply/seteqP; split => -[]//=. + by rewrite notin_set in Bf. + by rewrite inE in Bt. + apply/or4P. + by rewrite eqxx/=. +have [Bf|Bf] := boolP (false \in B). + have -> : B = [set false]. + apply/seteqP; split => -[]//=. + by rewrite notin_set in Bt. + by rewrite inE in Bf. + apply/or4P. + by rewrite eqxx/= orbT. +have -> : B = set0. + apply/seteqP; split => -[]//=. + by rewrite notin_set in Bt. + by rewrite notin_set in Bf. +apply/or4P. +by rewrite eqxx/= !orbT. +Qed. + +Lemma measurable_eq_cst (d d' : _) (T : measurableType d) (T' : measurableType d') + (R : realType) (f : R.-ker T ~> T') k : + measurable [set t | f t setT == k]. +Proof. +rewrite [X in measurable X](_ : _ = (f ^~ setT) @^-1` [set k]); last first. + by apply/seteqP; split => t/= /eqP. +rewrite /=. +have := measurable_kernel f setT measurableT. +rewrite /=. +move/(_ measurableT [set k]). +rewrite setTI. +exact. +Qed. + +Lemma measurable_neq_cst (d d' : _) (T : measurableType d) (T' : measurableType d') + (R : realType) (f : R.-ker T ~> T') k : measurable [set t | f t setT != k]. +Proof. +rewrite [X in measurable X](_ : _ = (f ^~ setT) @^-1` (setT `\` [set k])); last first. + apply/seteqP; split => t/=. + by move/eqP; tauto. + by move=> []? /eqP; tauto. +rewrite /=. +have := measurable_kernel f setT measurableT. +rewrite /=. +move/(_ measurableT (setT `\` [set k])). +rewrite setTI. +apply => //. +exact: measurableD. +Qed. + +Lemma measurable_fun_eq_cst (d d' : _) (T : measurableType d) (T' : measurableType d') + (R : realType) (f : R.-ker T ~> T') k : measurable_fun [set: T] (fun b : T => f b setT == k). +Proof. +move=> _ /= B mB. +rewrite setTI. +have [/eqP->|/eqP->|/eqP->|/eqP->] := set_boolE B. +- exact: measurable_eq_cst. +- rewrite (_ : _ @^-1` _ = [set b | f b setT != k]); last first. + apply/seteqP; split => t/=. + by move/negbT. + by move/negbTE. + exact: measurable_neq_cst. +- by rewrite preimage_set0. +- by rewrite preimage_setT. +Qed. + +(* TODO: PR *) +Lemma measurable_fun_fine (R : realType) : measurable_fun [set: \bar R] fine. +Proof. +move=> _ /= B mB. +rewrite setTI [X in measurable X](_ : _ @^-1` _ = + if 0%R \in B then (EFin @` B) `|` [set -oo; +oo] else EFin @` B); last first. + apply/seteqP; split=> [[r Br|B0|B0]|]. + case: ifPn => //= B0. + by left; exists r. + by exists r. + by rewrite mem_set//=; tauto. + by rewrite mem_set//=; tauto. + move=> [r| |]//=; case: ifPn => B0 /=. + case; last first. + by case. + by move=> [r' Br' [<-]]. + by move=> [r' Br' [<-]]. + by rewrite inE in B0. + by case => //. + case=> //. + by case=> //. + by rewrite inE in B0. + by case=> //. +case: ifPn => B0. + apply: measurableU. + by apply: measurable_EFin. + by apply: measurableU. +by apply: measurable_EFin. +Qed. + +Section normalize_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). +Variables (R : realType) (f : R.-ker T ~> T'). + +Definition normalize_kernel (P : probability T' R) := + fun t => [the measure _ _ of normalize f P t]. + +Variable P : probability T' R. + +Lemma measurable_fun_normalize U : measurable U -> measurable_fun setT (normalize_kernel P ^~ U). +Proof. +move=> mU. +rewrite /normalize_kernel/= /normalize /=. +apply: measurable_fun_if000 => //. +- exact: measurable_fun_eq_cst. +- exact: measurable_fun_cst. +- apply: measurable_fun_if000 => //. + + rewrite setTI. + exact: measurable_neq_cst. + + exact: measurable_fun_eq_cst. + + exact: measurable_fun_cst. + + apply: emeasurable_funM. + have := (measurable_kernel f U mU). + by apply: measurable_funS => //. + apply/EFin_measurable_fun. + rewrite /=. + apply: (measurable_fun_comp_new (F := [set r : R | r != 0%R])) => //. + exact: open_measurable. + move=> /= r [t] [] [_ H1] H2 H3. + apply/eqP => H4; subst r. + move/eqP : H4. + rewrite fine_eq0 ?(negbTE H1)//. + rewrite ge0_fin_numE//. + by rewrite lt_neqAle leey H2. + apply: open_continuous_measurable_fun => //. + apply/in_setP => x /= x0. + by apply: inv_continuous. + apply: measurable_fun_comp => /=. + exact: measurable_fun_fine. + have := (measurable_kernel f setT measurableT). + by apply: measurable_funS => //. +Qed. + +HB.instance Definition _ := isKernel.Build _ _ _ _ R (normalize_kernel P) + measurable_fun_normalize. + +End normalize_kernel. + +Section normalize_prob_kernel. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). +Variables (R : realType) (f : R.-ker T ~> T') (P : probability T' R). + +Lemma normalize_prob_kernelP x : normalize_kernel f P x [set: T'] = 1. +Proof. +rewrite /normalize_kernel/= /normalize. +case: ifPn => [_|fx0]. + by rewrite probability_setT. +case: ifPn => [_|fxoo]. + by rewrite probability_setT. +have ? : f x [set: _] \is a fin_num. + by rewrite ge0_fin_numE// lt_neqAle fxoo/= leey. +rewrite -{1}(@fineK _ (f x setT))//=. +by rewrite -EFinM divrr// ?lte_fin ?ltr1n// ?unitfE fine_eq0. +Qed. + +HB.instance Definition _ := + @isProbabilityKernel.Build _ _ _ _ _ (normalize_kernel f P) + normalize_prob_kernelP. + +End normalize_prob_kernel. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index bf33aa724e..b23d89b09a 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -437,6 +437,19 @@ Definition mite := [the sfinite_kernel _ _ _ of kernel_mfun R mf] \; ite'. End ite. +Section normalize. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d') + (R : realType) (f : R.-sfker T ~> T') (Pdef : probability T' R). + +Definition Normalize := [the R.-pker T ~> T' of normalize_kernel f Pdef]. + +Lemma NormalizeE x U : Normalize x U = normalize_kernel f Pdef x U. +Proof. +by []. +Qed. + +End normalize. + Section bernoulli27. Variable R : realType. Local Open Scope ring_scope. @@ -463,6 +476,15 @@ Definition letin (d d' d3 : _) : R.-sfker X ~> Z := [the sfinite_kernel _ _ _ of l \; k]. +Lemma letinE (d d' d3 : _) + (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) + (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) + : forall x U, letin l k x U = \int[l x]_y k (x, y) U. +Proof. +by []. +Qed. + Definition Return (d d' : _) (T : measurableType d) (T' : measurableType d') (f : T -> T') (mf : measurable_fun setT f) : R.-sfker T ~> T' := [the sfinite_kernel _ _ _ of @kernel_mfun _ _ T T' R f mf]. @@ -597,6 +619,13 @@ move=> r0; rewrite /poisson mulr_ge0//. by rewrite ltW// expR_gt0. Qed. +Lemma poisson_gt0 (R : realType) (r : R) k : (0 < r)%R -> (0 < poisson r k.+1)%R. +Proof. +move=> r0; rewrite /poisson mulr_gt0//. + by rewrite mulr_gt0// exprn_gt0. +by rewrite expR_gt0. +Qed. + Lemma mpoisson (R : realType) k : measurable_fun setT (@poisson R ^~ k). Proof. apply: measurable_funM => /=. @@ -693,11 +722,14 @@ Let munit := Datatypes_unit__canonical__measure_Measurable. Let mbool := Datatypes_bool__canonical__measure_Measurable. Notation var2_of2 := (@measurable_fun_snd _ _ _ _). -Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) (@measurable_fun_fst _ _ _ _)). +Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) + (@measurable_fun_fst _ _ _ _)). Notation var3_of3 := (@measurable_fun_snd _ _ _ _). -Definition staton_bus' : R.-sfker T ~> mbool := - letin +Variable Pdef : probability mbool R. + +Definition staton_bus_measure' : R.-sfker T ~> mbool := + (letin (sample_bernoulli27 R T : _.-sfker T ~> mbool) (letin (letin @@ -710,25 +742,25 @@ Definition staton_bus' : R.-sfker T ~> mbool := : _.-sfker [the measurableType _ of (T * bool)%type] ~> munit) (Return R var2_of3 : _.-sfker [the measurableType _ of (T * bool * munit)%type] ~> mbool) - : _.-sfker [the measurableType _ of (T * bool)%type] ~> mbool). + : _.-sfker [the measurableType _ of (T * bool)%type] ~> mbool)). -Definition staton_bus : R.-sfker T ~> mbool := - letin (sample_bernoulli27 R T) +Definition staton_bus_measure : R.-sfker T ~> mbool := + (letin (sample_bernoulli27 R T) (letin (letin (Ite var2_of2 (Return R (@k3 _ _ _)) (Return R (@k10 _ _ _))) (Score (measurable_fun_comp (@mpoisson R 4) var3_of3))) - (Return R var2_of3)). + (Return R var2_of3))). (* 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_busE t U : staton_bus t U = +Lemma staton_bus_measureE t U : staton_bus_measure t U = (twoseven R)%:num%:E * (poisson 3%:R 4)%:E * \d_true U + (fiveseven R)%:num%:E * (poisson 10%:R 4)%:E * \d_false U. Proof. -rewrite /staton_bus. +rewrite /staton_bus_measure. rewrite letin_sample_bernoulli27. rewrite -!muleA. congr (_ * _ + _ * _). @@ -742,4 +774,88 @@ rewrite letin_returnu//. by rewrite ScoreE// => r r0; exact: poisson_ge0. Qed. +Definition staton_bus : R.-pker T ~> mbool := + Normalize staton_bus_measure Pdef. + +Lemma staton_busE t U : + let N := (fine (((twoseven R)%:num)%:E * (poisson 3 4)%:E + ((fiveseven R)%:num)%:E * (poisson 10 4)%:E)) in + staton_bus t U = + ((twoseven R)%:num%:E * (poisson 3%:R 4)%:E * \d_true U + + (fiveseven R)%:num%:E * (poisson 10%:R 4)%:E * \d_false U) * N^-1%:E. +Proof. +rewrite /staton_bus. +rewrite NormalizeE /=. +rewrite /normalize. +rewrite !staton_bus_measureE. +rewrite diracE mem_set// mule1. +rewrite diracE mem_set// mule1. +rewrite ifF //. +apply/negbTE. +by rewrite gt_eqF// lte_fin addr_gt0// mulr_gt0//= poisson_gt0. +Qed. + End staton_bus. + +(* wip *) + +Definition swap (T1 T2 : Type) (x : T1 * T2) := (x.2, x.1). + +Section letinC_example. + +Variables (d d' d3 d4 : _) (R : realType) (X : measurableType d) + (Y : measurableType d') (Z : measurableType d3) (U : measurableType d4). +Let f (xyz : unit * X * X) := (xyz.1.2, xyz.2). +Lemma mf : measurable_fun setT f. +Proof. +rewrite /=. +apply/prod_measurable_funP => /=; split. + rewrite /f. + rewrite (_ : _ \o _ = (fun xyz : unit * X * X => xyz.1.2))//. + apply: measurable_fun_comp => /=. + exact: measurable_fun_snd. + exact: measurable_fun_fst. +rewrite (_ : _ \o _ = (fun xyz : unit * X * X => xyz.2))//. +apply: measurable_fun_comp => /=. + exact: measurable_fun_snd. +exact: measurable_fun_id. +Qed. + +Let measurable_fun_swap : measurable_fun [set: X * X] (swap (T2:=X)). +Proof. +apply/prod_measurable_funP => /=; split. + exact: measurable_fun_snd. +exact: measurable_fun_fst. +Qed. + +Let f' := @swap _ _ \o f. +Lemma mf' : measurable_fun setT f'. +Proof. +rewrite /=. +apply: measurable_fun_comp => /=. + exact: measurable_fun_swap. +exact: mf. +Qed. + +Variables (t : R.-sfker Datatypes_unit__canonical__measure_Measurable ~> X) + (t' : R.-sfker [the measurableType _ of (unit * X)%type] ~> X) + (u : R.-sfker Datatypes_unit__canonical__measure_Measurable ~> X) + (u' : R.-sfker [the measurableType _ of (unit * X)%type] ~> X) + (H1 : forall y, u tt = u' (tt, y)) + (H2 : forall y, t tt = t' (tt, y)). +Lemma letinC x A : measurable A -> + letin t (letin u' (Return R mf)) x A = letin u (letin t' (Return R mf')) x A. +Proof. +move=> mA. +rewrite /letin /= /kcomp /= /kcomp /=. +destruct x. +rewrite /f/=. +under eq_integral do rewrite -H1. +rewrite (@sfinite_fubini _ _ X X R t u (fun x => (\d_(x.1, x.2) A)))//=. +apply eq_integral => x _. + by rewrite -H2. +apply/EFin_measurable_fun => /=. +rewrite (_ : (fun x => _) = mindic R mA)//. +by apply/funext => -[a b] /=. +Qed. + +End letinC_example. From 271d0253eefc913d556250d458bb9b8a1b7790f5 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 24 Aug 2022 22:09:28 +0900 Subject: [PATCH 12/54] more uniform naming, kdirac is pker, etc. --- theories/kernel.v | 582 +++++++++++++----------------- theories/prob_lang.v | 838 ++++++++++++++++++++++--------------------- 2 files changed, 679 insertions(+), 741 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 3bb04fa77a..6decb7a906 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -14,8 +14,8 @@ Require Import lebesgue_measure fsbigop numfun lebesgue_integral. (* R.-pker X ~> Y == probability kernel *) (* sum_of_kernels == *) (* l \; k == composition of kernels *) -(* kernel_mfun == kernel defined by a measurable function *) -(* add_of_kernels == *) +(* kdirac mf == kernel defined by a measurable function *) +(* kadd k1 k2 == *) (******************************************************************************) Set Implicit Arguments. @@ -232,6 +232,24 @@ HB.instance Definition _ := @isMeasurable.Build default_measure_display bool (Po End discrete_measurable_bool. +(* NB: PR in progress *) +Lemma measurable_fun_fine (R : realType) (D : set (\bar R)) : measurable D -> + measurable_fun D fine. +Proof. +move=> mD _ /= B mB; rewrite [X in measurable X](_ : _ `&` _ = if 0%R \in B then + D `&` ((EFin @` B) `|` [set -oo; +oo]) else D `&` EFin @` B); last first. + apply/seteqP; split=> [[r [Dr Br]|[Doo B0]|[Doo B0]]|[r| |]]. + - by case: ifPn => _; split => //; left; exists r. + - by rewrite mem_set//; split => //; right; right. + - by rewrite mem_set//; split => //; right; left. + - by case: ifPn => [_ [Dr [[s + [sr]]|[]//]]|_ [Dr [s + [sr]]]]; rewrite sr. + - by case: ifPn => [/[!inE] B0 [Doo [[]//|]] [//|_]|B0 [Doo//] []]. + - by case: ifPn => [/[!inE] B0 [Doo [[]//|]] [//|_]|B0 [Doo//] []]. +case: ifPn => B0; apply/measurableI => //; last exact: measurable_EFin. +by apply: measurableU; [exact: measurable_EFin|exact: measurableU]. +Qed. + +(* TODO: PR *) Lemma measurable_fun_fst (d1 d2 : _) (T1 : measurableType d1) (T2 : measurableType d2) : measurable_fun setT (@fst T1 T2). Proof. @@ -246,16 +264,83 @@ have := @measurable_fun_id _ [the measurableType _ of (T1 * T2)%type] setT. by move=> /prod_measurable_funP[]. Qed. -Lemma measurable_uncurry (T1 T2 : Type) (d : _) (T : semiRingOfSetsType d) - (G : T1 -> T2 -> set T) (x : T1 * T2) : - measurable (G x.1 x.2) <-> measurable (uncurry G x). -Proof. by case: x. Qed. - Lemma measurable_curry (T1 T2 : Type) (d : _) (T : semiRingOfSetsType d) (G : T1 * T2 -> set T) (x : T1 * T2) : measurable (G x) <-> measurable (curry G x.1 x.2). Proof. by case: x. Qed. +Section measurable_fun_comp. +Variables (d1 d2 d3 : measure_display). +Variables (T1 : measurableType d1). +Variables (T2 : measurableType d2). +Variables (T3 : measurableType d3). + +Lemma measurable_fun_comp_new F (f : T2 -> T3) E (g : T1 -> T2) : + measurable F -> + g @` E `<=` F -> + measurable_fun F f -> measurable_fun E g -> measurable_fun E (f \o g). +Proof. +move=> mF FgE mf mg /= mE A mA. +rewrite comp_preimage. +rewrite [X in measurable X](_ : _ = (E `&` g @^-1` (F `&` f @^-1` A))); last first. + apply/seteqP; split. + move=> x/= [Ex Afgx]; split => //; split => //. + by apply: FgE => //. + by move=> x/= [Ex] [Fgx Afgx]. +apply/mg => //. +by apply: mf => //. +Qed. + +End measurable_fun_comp. + +Lemma open_continuousP (S T : topologicalType) (f : S -> T) (D : set S) : + open D -> + {in D, continuous f} <-> (forall A, open A -> open (D `&` f @^-1` A)). +Proof. +move=> oD; split=> [fcont|fcont s /[!inE] sD A]. + rewrite !openE => A Aop s [Ds] /Aop /fcont; rewrite inE => /(_ Ds) fsA. + by rewrite interiorI; split => //; move: oD; rewrite openE; exact. +rewrite nbhs_simpl /= !nbhsE => - [B [[oB Bfs] BA]]. +by exists (D `&` f @^-1` B); split=> [|t [Dt] /BA//]; split => //; exact/fcont. +Qed. + +Lemma open_continuous_measurable_fun (R : realType) (f : R -> R) D : + open D -> {in D, continuous f} -> measurable_fun D f. +Proof. +move=> oD /(open_continuousP _ oD) cf. +apply: (measurability (RGenOpens.measurableE R)) => _ [_ [a [b ->] <-]]. +by apply: open_measurable; exact/cf/interval_open. +Qed. + +Lemma set_boolE (B : set bool) : [\/ B == [set true], B == [set false], B == set0 | B == setT]. +Proof. +have [Bt|Bt] := boolP (true \in B). + have [Bf|Bf] := boolP (false \in B). + have -> : B = setT. + by apply/seteqP; split => // -[] _; [rewrite inE in Bt| rewrite inE in Bf]. + apply/or4P. + by rewrite eqxx/= !orbT. + have -> : B = [set true]. + apply/seteqP; split => -[]//=. + by rewrite notin_set in Bf. + by rewrite inE in Bt. + apply/or4P. + by rewrite eqxx/=. +have [Bf|Bf] := boolP (false \in B). + have -> : B = [set false]. + apply/seteqP; split => -[]//=. + by rewrite notin_set in Bt. + by rewrite inE in Bf. + apply/or4P. + by rewrite eqxx/= orbT. +have -> : B = set0. + apply/seteqP; split => -[]//=. + by rewrite notin_set in Bt. + by rewrite notin_set in Bf. +apply/or4P. +by rewrite eqxx/= !orbT. +Qed. + Lemma measurable_fun_if000 (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') D (md : measurable D) (f : T -> bool) (mf : measurable_fun setT f) : measurable_fun (D `&` [set b | f b ]) x -> @@ -306,36 +391,6 @@ apply: measurableU. by rewrite setIA. Qed. -Lemma measurable_fun_if00 (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') - (f : T -> bool) (mf : measurable_fun setT f) : - measurable_fun [set b | f b = true] x -> - measurable_fun [set b | f b = false] y -> - measurable_fun setT (fun b : T => if f b then x b else y b). -Proof. -move=> mx my /= _ Y mY. -rewrite setTI. -have H1 : measurable [set b | f b = true]. -rewrite [X in measurable X](_ : _ = f @^-1` [set true])//. - have := mf measurableT [set true]. - rewrite setTI. - exact. -have := mx H1 Y mY. -have H2 : measurable [set b | f b = false]. - have := mf measurableT [set false]. - rewrite setTI. - exact. -have := my H2 Y mY. -move=> yY xY. -rewrite (_ : _ @^-1` Y = ([set b | f b = true] `&` (x @^-1` Y) `&` (f @^-1` [set true])) `|` - ([set b | f b = false] `&` (y @^-1` Y) `&` (f @^-1` [set false]))); last first. - apply/seteqP; split. - move=> t/=; case: ifPn => ft. - by left. - by right. - by move=> t/= [|]; case: ifPn => ft; case=> -[]. -by apply: measurableU; apply: measurableI => //. -Qed. - Lemma measurable_fun_if0 (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') (f : T -> bool) (mf : measurable_fun setT f) : measurable_fun setT x -> @@ -454,19 +509,19 @@ Qed. End measure_fam_uub. -HB.mixin Record isFiniteKernel +HB.mixin Record isFiniteFam d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) := - { kernel_uub : measure_fam_uub k }. + { measure_uub : measure_fam_uub k }. #[short(type=finite_kernel)] HB.structure Definition FiniteKernel d d' (X : measurableType d) (Y : measurableType d') (R : realType) := - {k of isFiniteKernel _ _ X Y R k & isKernel _ _ X Y R k}. + {k of isFiniteFam _ _ X Y R k & isKernel _ _ X Y R k}. Notation "R .-fker X ~> Y" := (finite_kernel X Y R). -Arguments kernel_uub {_ _ _ _ _} _. +Arguments measure_uub {_ _ _ _ _} _. Section kernel_from_mzero. Variables (d : _) (T : measurableType d) (R : realType). @@ -483,16 +538,16 @@ HB.instance Definition _ := @isKernel.Build _ _ T' T R kernel_from_mzero kernel_from_mzeroP. -Lemma kernel_from_mzero_uub : measure_fam_uub kernel_from_mzero. +Let kernel_from_mzero_uub : measure_fam_uub kernel_from_mzero. Proof. by exists 1%R => /= t; rewrite /mzero/=. Qed. HB.instance Definition _ := - @isFiniteKernel.Build _ _ _ T R kernel_from_mzero + @isFiniteFam.Build _ _ _ T R kernel_from_mzero kernel_from_mzero_uub. End kernel_from_mzero. -HB.mixin Record isSFiniteKernel +HB.mixin Record isSFinite d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) := { sfinite : exists s : (R.-fker X ~> Y)^nat, @@ -503,8 +558,7 @@ HB.mixin Record isSFiniteKernel HB.structure Definition SFiniteKernel d d' (X : measurableType d) (Y : measurableType d') (R : realType) := - {k of isSFiniteKernel _ _ X Y R k & - isKernel _ _ X Y _ k}. + {k of isSFinite _ _ X Y R k & isKernel _ _ X Y _ k}. Notation "R .-sfker X ~> Y" := (sfinite_kernel X Y R). Arguments sfinite {_ _ _ _ _} _. @@ -529,52 +583,43 @@ Qed. End finite_is_sfinite. -(* TODO: define using the probability type *) HB.mixin Record isProbabilityFam d d' (X : measurableType d) (Y : measurableType d') - (R : realType) (k : X -> {measure set Y -> \bar R}) - := { - prob_kernelP : forall x, k x [set: Y] = 1 -}. + (R : realType) (k : X -> {measure set Y -> \bar R}) := + { prob_kernel : forall x, k x [set: Y] = 1}. #[short(type=probability_kernel)] HB.structure Definition ProbabilityKernel (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType) := - {k of isProbabilityFam _ _ X Y R k & isKernel _ _ X Y R k & isFiniteKernel _ _ X Y R k & isSFiniteKernel _ _ X Y R k}. + {k of isProbabilityFam _ _ X Y R k & isKernel _ _ X Y R k & + isFiniteFam _ _ X Y R k & isSFinite _ _ X Y R k}. Notation "R .-pker X ~> Y" := (probability_kernel X Y R). HB.factory Record isProbabilityKernel d d' (X : measurableType d) (Y : measurableType d') - (R : realType) (k : X -> {measure set Y -> \bar R}) of isKernel _ _ X Y R k := { - prob_kernelP2 : forall x, k x [set: Y] = 1 -}. + (R : realType) (k : X -> {measure set Y -> \bar R}) of isKernel _ _ X Y R k := + { prob_kernel' : forall x, k x setT = 1 }. HB.builders Context d d' (X : measurableType d) (Y : measurableType d') (R : realType) k of isProbabilityKernel d d' X Y R k. -Lemma is_finite_kernel : measure_fam_uub k. +Let is_finite_kernel : measure_fam_uub k. Proof. exists 2%R => /= ?. -rewrite (@le_lt_trans _ _ 1%:E)//. -rewrite prob_kernelP2//. -by rewrite lte_fin ltr1n. +by rewrite (@le_lt_trans _ _ 1%:E) ?lte_fin ?ltr1n// prob_kernel'. Qed. -HB.instance Definition _ := @isFiniteKernel.Build _ _ _ _ _ _ is_finite_kernel. +HB.instance Definition _ := @isFiniteFam.Build _ _ _ _ _ _ is_finite_kernel. -Lemma is_sfinite_kernel : exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> - k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. -exact: sfinite_finite. -Qed. +Lemma is_sfinite_kernel : exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> + k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. exact: sfinite_finite. Qed. -HB.instance Definition _ := @isSFiniteKernel.Build _ _ _ _ _ _ is_sfinite_kernel. +HB.instance Definition _ := @isSFinite.Build _ _ _ _ _ _ is_sfinite_kernel. Lemma is_probability_kernel : forall x, k x setT = 1. -Proof. -exact/prob_kernelP2. -Qed. + exact/prob_kernel'. Qed. HB.instance Definition _ := @isProbabilityFam.Build _ _ _ _ _ _ is_probability_kernel. @@ -671,7 +716,7 @@ rewrite -(_ : (fun x => mrestr (m2 x) measurableT (xsection X x)) = by apply/funext => x//=; rewrite /mrestr setIT. apply measurable_prod_subset_xsection_kernel => //. move=> x. -have [r hr] := kernel_uub m2. +have [r hr] := measure_uub m2. exists r => Y mY. apply: (le_lt_trans _ (hr x)) => //. rewrite /mrestr. @@ -756,7 +801,7 @@ Lemma measurable_fun_integral_finite_kernel Proof. have [k_ [ndk_ k_k]] := approximation measurableT mk (fun x _ => k0 x). apply: (measurable_fun_xsection_integral ndk_ (k_k ^~ Logic.I)) => n r. -have [l_ hl_] := kernel_uub l. +have [l_ hl_] := measure_uub l. by apply: measurable_fun_xsection_finite_kernel => // /[!inE]. Qed. @@ -852,10 +897,10 @@ Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') Variable l : R.-fker X ~> Y. Variable k : R.-fker [the measurableType _ of (X * Y)%type] ~> Z. -Lemma mkcomp_finite : measure_fam_uub (l \; k). +Let mkcomp_finite : measure_fam_uub (l \; k). Proof. -have /measure_fam_uubP[r hr] := kernel_uub k. -have /measure_fam_uubP[s hs] := kernel_uub l. +have /measure_fam_uubP[r hr] := measure_uub k. +have /measure_fam_uubP[s hs] := measure_uub l. apply/measure_fam_uubP; exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x /=. apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). apply: ge0_le_integral => //. @@ -867,7 +912,7 @@ by rewrite integral_cst//= EFinM lte_pmul2l. Qed. HB.instance Definition _ := - isFiniteKernel.Build _ _ X Z R (l \; k) mkcomp_finite. + isFiniteFam.Build _ _ X Z R (l \; k) mkcomp_finite. End kcomp_finite_kernel_finite. End KCOMP_FINITE_KERNEL. @@ -923,7 +968,7 @@ suff: exists k_0 : (R.-fker X ~> Z) ^nat, forall x U, rewrite /= H1// H2 H3// H4// H5// /mseries -hkl_/=. rewrite (_ : setT = setT `*`` (fun=> setT)); last by apply/seteqP; split. rewrite -(@esum_esum _ _ _ _ _ (fun i j => (l_ j \; k_ i) x U))//. - rewrite nneseries_esum; last by move=> n _; exact: nneseries_lim_ge0. + rewrite nneseries_esum; last by move=> n _; exact: nneseries_ge0. by rewrite fun_true; apply: eq_esum => /= i _; rewrite nneseries_esum// fun_true. rewrite /=. have /ppcard_eqP[f] : ([set: nat] #= [set: nat * nat])%card. @@ -954,7 +999,7 @@ HB.instance Definition _ := #[export] HB.instance Definition _ := - isSFiniteKernel.Build _ _ X Z R (l \; k) (mkcomp_sfinite l k). + isSFinite.Build _ _ X Z R (l \; k) (mkcomp_sfinite l k). End kcomp_sfinite_kernel. End KCOMP_SFINITE_KERNEL. @@ -1151,7 +1196,7 @@ Lemma finite_kernel_finite_measure d (T : measurableType d) (R : realType) (mu : R.-fker Datatypes_unit__canonical__measure_Measurable ~> T) : finite_measure (mu tt). Proof. -have [M muM] := kernel_uub mu. +have [M muM] := measure_uub mu. by rewrite /finite_measure (lt_le_trans (muM tt))// leey. Qed. @@ -1276,261 +1321,113 @@ Qed. End sfinite_fubini. -(* semantics for a sample operation *) -Section kernel_probability. -Variables (d d' : _) (R : realType) (X : measurableType d) (T' : measurableType d'). -Variable m : probability X R. +Section kprobability. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (m : probability Y R). -Definition kernel_probability : T' -> {measure set X -> \bar R} := - fun _ : T' => m. +Definition kprobability : X -> {measure set Y -> \bar R} := fun _ : X => m. -Lemma kernel_probabilityP U : measurable U -> - measurable_fun setT (kernel_probability ^~ U). +Let measurable_fun_kprobability U : measurable U -> + measurable_fun setT (kprobability ^~ U). Proof. by move=> mU; exact: measurable_fun_cst. Qed. HB.instance Definition _ := - @isKernel.Build _ _ _ X R kernel_probability kernel_probabilityP. + @isKernel.Build _ _ X Y R kprobability measurable_fun_kprobability. -Lemma kernel_probability' x : kernel_probability x [set: X] = 1. -Proof. by rewrite /kernel_probability/= probability_setT. Qed. +Let kprobability_prob x : kprobability x setT = 1. +Proof. by rewrite /kprobability/= probability_setT. Qed. HB.instance Definition _ := - @isProbabilityKernel.Build _ _ _ X R kernel_probability kernel_probability'. + @isProbabilityKernel.Build _ _ X Y R kprobability kprobability_prob. -End kernel_probability. +End kprobability. -Section kernel_of_mfun. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (f : T -> T'). +Section kdirac. +Variables (d d' : _) (T : measurableType d) (Y : measurableType d'). +Variables (R : realType) (f : T -> Y). -Definition kernel_mfun (mf : measurable_fun setT f) : T -> {measure set T' -> \bar R} := +Definition kdirac (mf : measurable_fun setT f) : T -> {measure set Y -> \bar R} := fun t => [the measure _ _ of dirac (f t)]. Hypothesis mf : measurable_fun setT f. -Lemma measurable_kernel_mfun U : measurable U -> measurable_fun setT (kernel_mfun mf ^~ U). +Let measurable_fun_kdirac U : measurable U -> measurable_fun setT (kdirac mf ^~ U). Proof. -move=> mU. -apply/EFin_measurable_fun. +move=> mU; apply/EFin_measurable_fun. rewrite (_ : (fun x => _) = mindic R mU \o f)//. exact/measurable_fun_comp. Qed. -HB.instance Definition _ := isKernel.Build _ _ _ _ R (kernel_mfun mf) - measurable_kernel_mfun. +HB.instance Definition _ := isKernel.Build _ _ _ _ R (kdirac mf) + measurable_fun_kdirac. -Lemma kernel_mfun_uub : measure_fam_uub (kernel_mfun mf). -Proof. by exists 2%R => t/=; rewrite diracE in_setT lte_fin ltr_addr. Qed. - -HB.instance Definition _ := isFiniteKernel.Build _ _ _ _ R (kernel_mfun mf) - kernel_mfun_uub. - -Lemma sfinite_kernel_mfun : exists k_ : (R.-fker _ ~> _)^nat, - forall x U, measurable U -> - kernel_mfun mf x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. exact: sfinite_finite. Qed. +Let kdirac_prob x : kdirac mf x setT = 1. +Proof. by rewrite /kdirac/= diracE in_setT. Qed. HB.instance Definition _ := - @isSFiniteKernel.Build _ _ _ _ _ (kernel_mfun mf) sfinite_kernel_mfun. + @isProbabilityKernel.Build _ _ _ _ _ (kdirac mf) kdirac_prob. -End kernel_of_mfun. +End kdirac. +Arguments kdirac {d d' T Y R f}. -Section add_of_kernels. -Variables (d d' : measure_display) (R : realType). -Variables (X : measurableType d) (Y : measurableType d'). -Variables (u1 u2 : R.-ker X ~> Y). +Section kadd. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k1 k2 : R.-ker X ~> Y). -Definition add_of_kernels : X -> {measure set Y -> \bar R} := - fun t => [the measure _ _ of measure_add (u1 t) (u2 t)]. +Definition kadd : X -> {measure set Y -> \bar R} := + fun t => [the measure _ _ of measure_add (k1 t) (k2 t)]. -Lemma measurable_add_of_kernels U : measurable U -> measurable_fun setT (add_of_kernels ^~ U). +Let measurable_fun_kadd U : measurable U -> measurable_fun setT (kadd ^~ U). Proof. -move=> mU. -rewrite /add_of_kernels. -rewrite (_ : (fun x : X => _) = (fun x => (u1 x U) + (u2 x U))); last first. - apply/funext => x. - by rewrite -measure_addE. +move=> mU; rewrite /kadd. +rewrite (_ : (fun _ => _) = (fun x => k1 x U + k2 x U)); last first. + by apply/funext => x; rewrite -measure_addE. by apply: emeasurable_funD; exact/measurable_kernel. Qed. HB.instance Definition _ := - @isKernel.Build _ _ _ _ _ add_of_kernels measurable_add_of_kernels. -End add_of_kernels. + @isKernel.Build _ _ _ _ _ kadd measurable_fun_kadd. +End kadd. -Section add_of_finite_kernels. -Variables (d d' : measure_display) (R : realType). -Variables (X : measurableType d) (Y : measurableType d'). -Variables (u1 u2 : R.-fker X ~> Y). +Section fkadd. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k1 k2 : R.-fker X ~> Y). -Lemma add_of_finite_kernels_uub : measure_fam_uub (add_of_kernels u1 u2). +Let kadd_finite_uub : measure_fam_uub (kadd k1 k2). Proof. -have [k1 hk1] := kernel_uub u1. -have [k2 hk2] := kernel_uub u2. -exists (k1 + k2)%R => x. -rewrite /add_of_kernels/=. -rewrite -/(measure_add (u1 x) (u2 x)). -rewrite measure_addE. -rewrite EFinD. -exact: lte_add. +have [f1 hk1] := measure_uub k1; have [f2 hk2] := measure_uub k2. +exists (f1 + f2)%R => x; rewrite /kadd /=. +rewrite -/(measure_add (k1 x) (k2 x)). +by rewrite measure_addE EFinD; exact: lte_add. Qed. HB.instance Definition _ t := - isFiniteKernel.Build _ _ _ _ R (add_of_kernels u1 u2) add_of_finite_kernels_uub. -End add_of_finite_kernels. + isFiniteFam.Build _ _ _ _ R (kadd k1 k2) kadd_finite_uub. +End fkadd. -Section add_of_sfinite_kernels. +Section sfkadd. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (u1 u2 : R.-sfker X ~> Y). +Variables (R : realType) (k1 k2 : R.-sfker X ~> Y). -Lemma sfinite_add_of_kernels : exists k_ : (R.-fker _ ~> _)^nat, +Let sfinite_kadd : exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> - add_of_kernels u1 u2 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. + kadd k1 k2 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. Proof. -have [k1 hk1] := sfinite u1. -have [k2 hk2] := sfinite u2. -exists (fun n => [the finite_kernel _ _ _ of add_of_kernels (k1 n) (k2 n)]) => x U mU. -rewrite /add_of_kernels/=. -rewrite -/(measure_add (u1 x) (u2 x)). -rewrite measure_addE. +have [f1 hk1] := sfinite k1. +have [f2 hk2] := sfinite k2. +exists (fun n => [the finite_kernel _ _ _ of kadd (f1 n) (f2 n)]) => x U mU. +rewrite /kadd/=. +rewrite -/(measure_add (k1 x) (k2 x)) measure_addE. rewrite /mseries. rewrite hk1//= hk2//= /mseries. rewrite -nneseriesD//. apply: eq_nneseries => n _. -rewrite -/(measure_add (k1 n x) (k2 n x)). -by rewrite measure_addE. +by rewrite -/(measure_add (f1 n x) (f2 n x)) measure_addE. Qed. HB.instance Definition _ t := - isSFiniteKernel.Build _ _ _ _ R (add_of_kernels u1 u2) sfinite_add_of_kernels. -End add_of_sfinite_kernels. - -Section normalize_measure. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). -Variables (R : realType) (f : T -> {measure set T' -> \bar R}) (P : probability T' R). - -Definition normalize (t : T) (U : set T') := - let evidence := f t setT in - if evidence == 0%E then P U - else if evidence == +oo then P U - else f t U * (fine evidence)^-1%:E. - -Lemma normalize0 t : normalize t set0 = 0. -Proof. -rewrite /normalize. -case: ifPn => // _. -case: ifPn => // _. -by rewrite measure0 mul0e. -Qed. - -Lemma normalize_ge0 t U : 0 <= normalize t U. -Proof. -by rewrite /normalize; case: ifPn => //; case: ifPn. -Qed. - -Lemma normalize_sigma_additive t : semi_sigma_additive (normalize t). -Proof. -move=> F mF tF mUF. -rewrite /normalize/=. -case: ifPn => [_|_]. - exact: measure_semi_sigma_additive. -case: ifPn => [_|_]. - exact: measure_semi_sigma_additive. -rewrite (_ : (fun n => _) = ((fun n=> \sum_(0 <= i < n) f t (F i)) \* cst ((fine (f t [set: T']))^-1)%:E)); last first. - by apply/funext => n; rewrite -ge0_sume_distrl. -by apply: ereal_cvgMr => //; exact: measure_semi_sigma_additive. -Qed. - -HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ - (normalize t) (normalize0 t) (normalize_ge0 t) (@normalize_sigma_additive t). - -Lemma normalize1 t : normalize t setT = 1. -Proof. -rewrite /normalize; case: ifPn. - by rewrite probability_setT. -case: ifPn. - by rewrite probability_setT. -move=> ftoo ft0. -have ? : f t [set: T'] \is a fin_num. - by rewrite ge0_fin_numE// lt_neqAle ftoo/= leey. -rewrite -{1}(@fineK _ (f t setT))//. -by rewrite -EFinM divrr// ?unitfE fine_eq0. -Qed. - -HB.instance Definition _ t := isProbability.Build _ _ _ (normalize t) (normalize1 t). - -End normalize_measure. - -Section measurable_fun_comp. -Variables (d1 d2 d3 : measure_display). -Variables (T1 : measurableType d1). -Variables (T2 : measurableType d2). -Variables (T3 : measurableType d3). - -Lemma measurable_fun_comp_new F (f : T2 -> T3) E (g : T1 -> T2) : - measurable F -> - g @` E `<=` F -> - measurable_fun F f -> measurable_fun E g -> measurable_fun E (f \o g). -Proof. -move=> mF FgE mf mg /= mE A mA. -rewrite comp_preimage. -rewrite [X in measurable X](_ : _ = (E `&` g @^-1` (F `&` f @^-1` A))); last first. - apply/seteqP; split. - move=> x/= [Ex Afgx]; split => //; split => //. - by apply: FgE => //. - by move=> x/= [Ex] [Fgx Afgx]. -apply/mg => //. -by apply: mf => //. -Qed. - -End measurable_fun_comp. - -Lemma open_continuousP (S T : topologicalType) (f : S -> T) (D : set S) : - open D -> - {in D, continuous f} <-> (forall A, open A -> open (D `&` f @^-1` A)). -Proof. -move=> oD; split=> [fcont|fcont s /[!inE] sD A]. - rewrite !openE => A Aop s [Ds] /Aop /fcont; rewrite inE => /(_ Ds) fsA. - by rewrite interiorI; split => //; move: oD; rewrite openE; exact. -rewrite nbhs_simpl /= !nbhsE => - [B [[oB Bfs] BA]]. -by exists (D `&` f @^-1` B); split=> [|t [Dt] /BA//]; split => //; exact/fcont. -Qed. - -Lemma open_continuous_measurable_fun (R : realType) (f : R -> R) D : - open D -> {in D, continuous f} -> measurable_fun D f. -Proof. -move=> oD /(open_continuousP _ oD) cf. -apply: (measurability (RGenOpens.measurableE R)) => _ [_ [a [b ->] <-]]. -by apply: open_measurable; exact/cf/interval_open. -Qed. - -Lemma set_boolE (B : set bool) : [\/ B == [set true], B == [set false], B == set0 | B == setT]. -Proof. -have [Bt|Bt] := boolP (true \in B). - have [Bf|Bf] := boolP (false \in B). - have -> : B = setT. - by apply/seteqP; split => // -[] _; [rewrite inE in Bt| rewrite inE in Bf]. - apply/or4P. - by rewrite eqxx/= !orbT. - have -> : B = [set true]. - apply/seteqP; split => -[]//=. - by rewrite notin_set in Bf. - by rewrite inE in Bt. - apply/or4P. - by rewrite eqxx/=. -have [Bf|Bf] := boolP (false \in B). - have -> : B = [set false]. - apply/seteqP; split => -[]//=. - by rewrite notin_set in Bt. - by rewrite inE in Bf. - apply/or4P. - by rewrite eqxx/= orbT. -have -> : B = set0. - apply/seteqP; split => -[]//=. - by rewrite notin_set in Bt. - by rewrite notin_set in Bf. -apply/or4P. -by rewrite eqxx/= !orbT. -Qed. + isSFinite.Build _ _ _ _ R (kadd k1 k2) sfinite_kadd. +End sfkadd. Lemma measurable_eq_cst (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType) (f : R.-ker T ~> T') k : @@ -1578,49 +1475,73 @@ have [/eqP->|/eqP->|/eqP->|/eqP->] := set_boolE B. - by rewrite preimage_setT. Qed. -(* TODO: PR *) -Lemma measurable_fun_fine (R : realType) : measurable_fun [set: \bar R] fine. +Section mnormalize. +Variables (d d' : _) (T : measurableType d) (Y : measurableType d'). +Variables (R : realType) (f : T -> {measure set Y -> \bar R}) (P : probability Y R). + +Definition mnormalize t U := + let evidence := f t setT in + if (evidence == 0) || (evidence == +oo) then P U + else f t U * (fine evidence)^-1%:E. + +Let mnormalize0 t : mnormalize t set0 = 0. Proof. -move=> _ /= B mB. -rewrite setTI [X in measurable X](_ : _ @^-1` _ = - if 0%R \in B then (EFin @` B) `|` [set -oo; +oo] else EFin @` B); last first. - apply/seteqP; split=> [[r Br|B0|B0]|]. - case: ifPn => //= B0. - by left; exists r. - by exists r. - by rewrite mem_set//=; tauto. - by rewrite mem_set//=; tauto. - move=> [r| |]//=; case: ifPn => B0 /=. - case; last first. - by case. - by move=> [r' Br' [<-]]. - by move=> [r' Br' [<-]]. - by rewrite inE in B0. - by case => //. - case=> //. - by case=> //. - by rewrite inE in B0. - by case=> //. -case: ifPn => B0. - apply: measurableU. - by apply: measurable_EFin. - by apply: measurableU. -by apply: measurable_EFin. +rewrite /mnormalize; case: ifPn => // _. +by rewrite measure0 mul0e. Qed. -Section normalize_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). -Variables (R : realType) (f : R.-ker T ~> T'). +Let mnormalize_ge0 t U : 0 <= mnormalize t U. +Proof. by rewrite /mnormalize; case: ifPn => //; case: ifPn. Qed. -Definition normalize_kernel (P : probability T' R) := - fun t => [the measure _ _ of normalize f P t]. +Lemma mnormalize_sigma_additive t : semi_sigma_additive (mnormalize t). +Proof. +move=> F mF tF mUF; rewrite /mnormalize/=. +case: ifPn => [_|_]. + exact: measure_semi_sigma_additive. +rewrite (_ : (fun n => _) = ((fun n=> \sum_(0 <= i < n) f t (F i)) \* + cst ((fine (f t setT))^-1)%:E)); last first. + by apply/funext => n; rewrite -ge0_sume_distrl. +by apply: ereal_cvgMr => //; exact: measure_semi_sigma_additive. +Qed. -Variable P : probability T' R. +HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ + (mnormalize t) (mnormalize0 t) (mnormalize_ge0 t) (@mnormalize_sigma_additive t). -Lemma measurable_fun_normalize U : measurable U -> measurable_fun setT (normalize_kernel P ^~ U). +Lemma mnormalize1 t : mnormalize t setT = 1. +Proof. +rewrite /mnormalize; case: ifPn; first by rewrite probability_setT. +rewrite negb_or => /andP[ft0 ftoo]. +have ? : f t setT \is a fin_num. + by rewrite ge0_fin_numE// lt_neqAle ftoo/= leey. +rewrite -{1}(@fineK _ (f t setT))//. +by rewrite -EFinM divrr// ?unitfE fine_eq0. +Qed. + +HB.instance Definition _ t := + isProbability.Build _ _ _ (mnormalize t) (mnormalize1 t). + +End mnormalize. + +Section knormalize. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (f : R.-ker X ~> Y). + +Definition knormalize (P : probability Y R) := + fun t => [the measure _ _ of mnormalize f P t]. + +Variable P : probability Y R. + +Let measurable_fun_knormalize U : + measurable U -> measurable_fun setT (knormalize P ^~ U). Proof. move=> mU. -rewrite /normalize_kernel/= /normalize /=. +rewrite /knormalize/= /mnormalize /=. +rewrite (_ : (fun _ => _) = (fun x => + if f x [set: Y] == 0 then P U else if f x [set: Y] == +oo then P U + else f x U * ((fine (f x [set: Y]))^-1)%:E)); last first. + apply/funext => x; case: ifPn => [/orP[->//|->]|]. + by case: ifPn. + by rewrite negb_or=> /andP[/negbTE -> /negbTE ->]. apply: measurable_fun_if000 => //. - exact: measurable_fun_eq_cst. - exact: measurable_fun_cst. @@ -1651,22 +1572,14 @@ apply: measurable_fun_if000 => //. by apply: measurable_funS => //. Qed. -HB.instance Definition _ := isKernel.Build _ _ _ _ R (normalize_kernel P) - measurable_fun_normalize. - -End normalize_kernel. - -Section normalize_prob_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). -Variables (R : realType) (f : R.-ker T ~> T') (P : probability T' R). +HB.instance Definition _ := isKernel.Build _ _ _ _ R (knormalize P) + measurable_fun_knormalize. -Lemma normalize_prob_kernelP x : normalize_kernel f P x [set: T'] = 1. +Let knormalize1 x : knormalize P x setT = 1. Proof. -rewrite /normalize_kernel/= /normalize. -case: ifPn => [_|fx0]. - by rewrite probability_setT. -case: ifPn => [_|fxoo]. - by rewrite probability_setT. +rewrite /knormalize/= /mnormalize. +case: ifPn => [_|]; first by rewrite probability_setT. +rewrite negb_or => /andP[fx0 fxoo]. have ? : f x [set: _] \is a fin_num. by rewrite ge0_fin_numE// lt_neqAle fxoo/= leey. rewrite -{1}(@fineK _ (f x setT))//=. @@ -1674,7 +1587,6 @@ by rewrite -EFinM divrr// ?lte_fin ?ltr1n// ?unitfE fine_eq0. Qed. HB.instance Definition _ := - @isProbabilityKernel.Build _ _ _ _ _ (normalize_kernel f P) - normalize_prob_kernelP. + @isProbabilityKernel.Build _ _ _ _ _ (knormalize P) knormalize1. -End normalize_prob_kernel. +End knormalize. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index b23d89b09a..e644a49fd2 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -5,11 +5,21 @@ Require Import reals ereal topology normedtype sequences esum measure. Require Import lebesgue_measure fsbigop numfun lebesgue_integral kernel. (******************************************************************************) -(* Semantics of a PPL using s-finite kernels *) +(* Semantics of a programming language PPL using s-finite kernels *) (* *) -(* bernoulli == *) -(* score == *) -(* ite_true/ite_false == *) +(* bernoulli r1 == Bernoulli probability *) +(* *) +(* sample 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 *) (******************************************************************************) Set Implicit Arguments. @@ -22,13 +32,21 @@ Local Open Scope classical_set_scope. Local Open Scope ring_scope. Local Open Scope ereal_scope. -Definition onem (R : numDomainType) (p : R) := (1 - p)%R. +(* TODO: PR *) +Definition swap (T1 T2 : Type) (x : T1 * T2) := (x.2, x.1). -Lemma onem1 (R : numDomainType) (p : R) : (p + onem p = 1)%R. +Lemma measurable_fun_swap d (X : measurableType d) : measurable_fun [set: X * X] (swap (T2:=X)). +Proof. +apply/prod_measurable_funP => /=; split. + exact: measurable_fun_snd. +exact: measurable_fun_fst. +Qed. + +Lemma onem1 (R : numDomainType) (p : R) : (p + `1- p = 1)%R. Proof. by rewrite /onem addrCA subrr addr0. Qed. Lemma onem_nonneg_proof (R : numDomainType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R) : - (0 <= onem p%:num)%R. + (0 <= `1-(p%:num))%R. Proof. by rewrite /onem/= subr_ge0. Qed. Definition onem_nonneg (R : numDomainType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R) := @@ -38,48 +56,50 @@ Section bernoulli. Variables (R : realType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R). Local Open Scope ring_scope. -Definition bernoulli : set _ -> \bar R := +Definition mbernoulli : set _ -> \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]]. -HB.instance Definition _ := Measure.on bernoulli. +HB.instance Definition _ := Measure.on mbernoulli. Local Close Scope ring_scope. -Lemma bernoulli_setT : bernoulli [set: _] = 1. +Let mbernoulli_setT : mbernoulli [set: _] = 1. Proof. -rewrite /bernoulli/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. +rewrite /mbernoulli/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. by rewrite /mscale/= !diracE !in_setT !mule1 -EFinD onem1. Qed. -HB.instance Definition _ := @isProbability.Build _ _ R bernoulli bernoulli_setT. +HB.instance Definition _ := @isProbability.Build _ _ R mbernoulli mbernoulli_setT. + +Definition bernoulli := [the probability _ _ of mbernoulli]. End bernoulli. -Section score_measure. -Variables (R : realType) (d : _) (T : measurableType d). -Variables (r : T -> R). +Section mscore. +Variables (d : _) (T : measurableType d). +Variables (R : realType) (f : T -> R). -Definition score (t : T) (U : set unit) : \bar R := - if U == set0 then 0 else `| (r t)%:E |. +Definition mscore t (U : set unit) : \bar R := + if U == set0 then 0 else `| (f t)%:E |. -Let score0 t : score t (set0 : set unit) = 0 :> \bar R. -Proof. by rewrite /score eqxx. Qed. +Let mscore0 t : mscore t (set0 : set unit) = 0 :> \bar R. +Proof. by rewrite /mscore eqxx. Qed. -Let score_ge0 t U : 0 <= score t U. -Proof. by rewrite /score; case: ifP. Qed. +Let mscore_ge0 t U : 0 <= mscore t U. +Proof. by rewrite /mscore; case: ifP. Qed. -Let score_sigma_additive t : semi_sigma_additive (score t). +Let mscore_sigma_additive t : semi_sigma_additive (mscore t). Proof. -move=> /= F mF tF mUF; rewrite /score; case: ifPn => [/eqP/bigcup0P F0|]. +move=> /= F mF tF mUF; rewrite /mscore; case: ifPn => [/eqP/bigcup0P F0|]. rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. apply/funext => k. under eq_bigr do rewrite F0// eqxx. by rewrite big1. move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. rewrite -(cvg_shiftn k.+1)/=. -rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. +rewrite (_ : (fun _ => _) = cst `|(f t)%:E|); first exact: cvg_cst. apply/funext => n. rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. rewrite (negbTE Fk0) big1 ?adde0// => i/= ik; rewrite ifT//. @@ -89,9 +109,9 @@ by rewrite Fitt setTI => /eqP; rewrite (negbTE Fk0). Qed. HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ - (score t) (score0 t) (score_ge0 t) (@score_sigma_additive t). + (mscore t) (mscore0 t) (mscore_ge0 t) (@mscore_sigma_additive t). -End score_measure. +End mscore. (* decomposition of score into finite kernels *) Module SCORE. @@ -99,454 +119,421 @@ Section score. Variables (R : realType) (d : _) (T : measurableType d). Variables (r : T -> R). -Definition k_ (mr : measurable_fun setT r) (i : nat) : T -> set unit -> \bar R := +Definition k (mr : measurable_fun setT r) (i : nat) : T -> set unit -> \bar R := fun t U => - if i%:R%:E <= score r t U < i.+1%:R%:E then - score r t U + if i%:R%:E <= mscore r t U < i.+1%:R%:E then + mscore r t U else 0. Hypothesis mr : measurable_fun setT r. -Lemma k_0 i (t : T) : k_ mr i t (set0 : set unit) = 0 :> \bar R. -Proof. by rewrite /k_ measure0; case: ifP. Qed. +Lemma k0 i t : k mr i t (set0 : set unit) = 0 :> \bar R. +Proof. by rewrite /k measure0; case: ifP. Qed. -Lemma k_ge0 i (t : T) B : 0 <= k_ mr i t B. -Proof. by rewrite /k_; case: ifP. Qed. +Lemma k_ge0 i t B : 0 <= k mr i t B. +Proof. by rewrite /k; case: ifP. Qed. -Lemma k_sigma_additive i (t : T) : semi_sigma_additive (k_ mr i t). +Lemma k_sigma_additive i t : semi_sigma_additive (k mr i t). Proof. -move=> /= F mF tF mUF. -rewrite /k_ /=. +move=> /= F mF tF mUF; rewrite /k /=. have [F0|] := eqVneq (\bigcup_n F n) set0. - rewrite [in X in _ --> X]/score F0 eqxx. + rewrite [in X in _ --> X]/mscore F0 eqxx. rewrite (_ : (fun _ => _) = cst 0). by case: ifPn => _; exact: cvg_cst. apply/funext => k; rewrite big1// => n _. move : F0 => /bigcup0P F0. - by rewrite /score F0// eqxx; case: ifP. + by rewrite /mscore F0// eqxx; case: ifP. move=> UF0; move: (UF0). -move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. -rewrite [in X in _ --> X]/score (negbTE UF0). -rewrite -(cvg_shiftn k.+1)/=. +move=> /eqP/bigcup0P/existsNP[m /not_implyP[_ /eqP Fm0]]. +rewrite [in X in _ --> X]/mscore (negbTE UF0). +rewrite -(cvg_shiftn m.+1)/=. case: ifPn => ir. rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. apply/funext => n. - rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. - rewrite [in X in X + _]/score (negbTE Fk0) ir big1 ?adde0// => /= j jk. - rewrite /score. + rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn m))))//=. + rewrite [in X in X + _]/mscore (negbTE Fm0) ir big1 ?adde0// => /= j jk. + rewrite /mscore. have /eqP Fj0 : F j == set0. have [/eqP//|Fjtt] := set_unit (F j). - move/trivIsetP : tF => /(_ j k Logic.I Logic.I jk). - by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fk0). + move/trivIsetP : tF => /(_ j m Logic.I Logic.I jk). + by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fm0). rewrite Fj0 eqxx. by case: ifP. rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. apply/funext => n. -rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. -rewrite [in X in if X then _ else _]/score (negbTE Fk0) (negbTE ir) add0e. -rewrite big1//= => j jk. -rewrite /score. +rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn m))))//=. +rewrite [in X in if X then _ else _]/mscore (negbTE Fm0) (negbTE ir) add0e. +rewrite big1//= => j jm. +rewrite /mscore. have /eqP Fj0 : F j == set0. have [/eqP//|Fjtt] := set_unit (F j). - move/trivIsetP : tF => /(_ j k Logic.I Logic.I jk). - by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fk0). -rewrite Fj0 eqxx. -by case: ifP. -Qed. - -HB.instance Definition _ (i : nat) (t : T) := isMeasure.Build _ _ _ - (k_ mr i t) (k_0 i t) (k_ge0 i t) (@k_sigma_additive i t). - -Lemma measurable_fun_k_ (i : nat) U : measurable U -> measurable_fun setT (k_ mr i ^~ U). -Proof. -move=> /= mU. -rewrite /k_ /=. -rewrite (_ : (fun x : T => _) = (fun x => if (i%:R)%:E <= x < (i.+1%:R)%:E then x else 0) \o (fun x => score r x U)) //. -apply: measurable_fun_comp; last first. - rewrite /score. - have [U0|U0] := eqVneq U set0. - exact: measurable_fun_cst. - apply: measurable_fun_comp => //. - by apply/EFin_measurable_fun. -rewrite /=. -pose A : _ -> \bar R := (fun x : \bar R => x * (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set (\bar R)) x)%:E). + move/trivIsetP : tF => /(_ j m Logic.I Logic.I jm). + by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fm0). +by rewrite Fj0 eqxx; case: ifP. +Qed. + +HB.instance Definition _ i t := isMeasure.Build _ _ _ + (k mr i t) (k0 i t) (k_ge0 i t) (@k_sigma_additive i t). + +Lemma measurable_fun_k i U : measurable U -> measurable_fun setT (k mr i ^~ U). +Proof. +move=> /= mU; rewrite /k /=. +rewrite (_ : (fun x : T => _) = (fun x => if (i%:R)%:E <= x < (i.+1%:R)%:E then x else 0) \o + (mscore r ^~ U)) //. +apply: measurable_fun_comp => /=; last first. + rewrite /mscore. + have [U0|U0] := eqVneq U set0; first exact: measurable_fun_cst. + by apply: measurable_fun_comp => //; exact/EFin_measurable_fun. +pose A : _ -> \bar R := (fun x => x * (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set (\bar R)) x)%:E). rewrite (_ : (fun x => _) = A); last first. apply/funext => x; rewrite /A; case: ifPn => ix. by rewrite indicE/= mem_set ?mule1//. rewrite indicE/= memNset ?mule0//. - rewrite /= in_itv/=. - exact/negP. -rewrite /A. -apply emeasurable_funM => /=. - exact: measurable_fun_id. + by rewrite /= in_itv/=; exact/negP. +rewrite {}/A. +apply emeasurable_funM => /=; first exact: measurable_fun_id. apply/EFin_measurable_fun. have mi : measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set (\bar R)). exact: emeasurable_itv. -by rewrite (_ : \1__ = mindic R mi)//. +by rewrite (_ : \1__ = mindic R mi). Qed. -Definition mk_ i (t : T) := [the measure _ _ of k_ mr i t]. +Definition mk i t := [the measure _ _ of k mr i t]. -HB.instance Definition _ (i : nat) := - isKernel.Build _ _ _ _ R (mk_ i) (measurable_fun_k_ i). +HB.instance Definition _ i := + isKernel.Build _ _ _ _ R (mk i) (measurable_fun_k i). -Lemma mk_uub (i : nat) : measure_fam_uub (mk_ i). +Lemma mk_uub (i : nat) : measure_fam_uub (mk i). Proof. exists i.+1%:R => /= t. -rewrite /k_ /score setT_unit. +rewrite /k /mscore setT_unit. rewrite (_ : [set tt] == set0 = false); last first. by apply/eqP => /seteqP[] /(_ tt) /(_ erefl). by case: ifPn => // /andP[]. Qed. -HB.instance Definition _ (i : nat) := - @isFiniteKernel.Build _ _ _ _ R (mk_ i) (mk_uub i). +HB.instance Definition _ i := @isFiniteFam.Build _ _ _ _ R (mk i) (mk_uub i). End score. End SCORE. -Section score_kernel. -Variables (R : realType) (d : _) (T : measurableType d). -Variables (r : T -> R). +Section kscore. +Variables (R : realType) (d : _) (T : measurableType d) (r : T -> R). -Definition kernel_score (mr : measurable_fun setT r) - : T -> {measure set Datatypes_unit__canonical__measure_Measurable -> \bar R} := - fun t => [the measure _ _ of score r t]. +Definition kscore (mr : measurable_fun setT r) + : T -> {measure set _ -> \bar R} := + fun t => [the measure _ _ of mscore r t]. Variable (mr : measurable_fun setT r). -Let measurable_fun_score U : measurable U -> measurable_fun setT (kernel_score mr ^~ U). +Let measurable_fun_kscore U : measurable U -> measurable_fun setT (kscore mr ^~ U). Proof. -move=> /= mU; rewrite /score. +move=> /= mU; rewrite /mscore. have [U0|U0] := eqVneq U set0; first exact: measurable_fun_cst. by apply: measurable_fun_comp => //; exact/EFin_measurable_fun. Qed. HB.instance Definition _ := isKernel.Build _ _ T _ - (*Datatypes_unit__canonical__measure_Measurable*) R (kernel_score mr) measurable_fun_score. -End score_kernel. - -Section score_sfinite_kernel. -Variables (R : realType) (d : _) (T : measurableType d). -Variables (r : T -> R) (mr : measurable_fun setT r). + (*Datatypes_unit__canonical__measure_Measurable*) R (kscore mr) measurable_fun_kscore. Import SCORE. -Let sfinite_score : exists k_ : (R.-fker T ~> _)^nat, +Let sfinite_kscore : exists k : (R.-fker T ~> _)^nat, forall x U, measurable U -> - kernel_score mr x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. + kscore mr x U = [the measure _ _ of mseries (k ^~ x) 0] U. Proof. rewrite /=. -exists (fun i => [the finite_kernel _ _ _ of mk_ mr i]) => /= r' U mU. -rewrite /mseries /score; case: ifPn => [/eqP U0|U0]. +exists (fun i => [the R.-fker _ ~> _ of mk mr i]) => /= t U mU. +rewrite /mseries /mscore; case: ifPn => [/eqP U0|U0]. by apply/esym/nneseries0 => i _; rewrite U0 measure0. -rewrite /mk_ /= /k_ /= /score (negbTE U0). +rewrite /mk /= /k /= /mscore (negbTE U0). apply/esym/cvg_lim => //. -rewrite -(cvg_shiftn `|floor (fine `|(r r')%:E|)|%N.+1)/=. -rewrite (_ : (fun _ => _) = cst `|(r r')%:E|); first exact: cvg_cst. +rewrite -(cvg_shiftn `|floor (fine `|(r t)%:E|)|%N.+1)/=. +rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. apply/funext => n. -pose floor_r := widen_ord (leq_addl n `|floor `|(r r')| |.+1) (Ordinal (ltnSn `|floor `|(r r')| |)). +pose floor_r := widen_ord (leq_addl n `|floor `|r t| |.+1) (Ordinal (ltnSn `|floor `|r t| |)). rewrite big_mkord (bigD1 floor_r)//= ifT; last first. rewrite lee_fin lte_fin; apply/andP; split. - by rewrite natr_absz (@ger0_norm _ (floor `|(r r')|)) ?floor_ge0 ?floor_le. - by rewrite -addn1 natrD natr_absz (@ger0_norm _ (floor `|(r r')|)) ?floor_ge0 ?lt_succ_floor. + by rewrite natr_absz (@ger0_norm _ (floor `|r t|)) ?floor_ge0 ?floor_le. + by rewrite -addn1 natrD natr_absz (@ger0_norm _ (floor `|r t|)) ?floor_ge0 ?lt_succ_floor. rewrite big1 ?adde0//= => j jk. rewrite ifF// lte_fin lee_fin. move: jk; rewrite neq_ltn/= => /orP[|] jr. -- suff : (j.+1%:R <= `|(r r')|)%R by rewrite leNgt => /negbTE ->; rewrite andbF. +- suff : (j.+1%:R <= `|r t|)%R by rewrite leNgt => /negbTE ->; rewrite andbF. rewrite (_ : j.+1%:R = j.+1%:~R)// floor_ge_int. move: jr; rewrite -lez_nat => /le_trans; apply. - by rewrite -[leRHS](@ger0_norm _ (floor `|(r r')|)) ?floor_ge0. -- suff : (`|(r r')| < j%:R)%R by rewrite ltNge => /negbTE ->. - move: jr; rewrite -ltz_nat -(@ltr_int R) (@gez0_abs (floor `|(r r')|)) ?floor_ge0// ltr_int. + by rewrite -[leRHS](@ger0_norm _ (floor `|r t|)) ?floor_ge0. +- suff : (`|r t| < j%:R)%R by rewrite ltNge => /negbTE ->. + move: jr; rewrite -ltz_nat -(@ltr_int R) (@gez0_abs (floor `|r t|)) ?floor_ge0// ltr_int. by rewrite -floor_lt_int. Qed. -HB.instance Definition _ := @isSFiniteKernel.Build _ _ _ _ _ - (kernel_score mr) sfinite_score. +HB.instance Definition _ := @isSFinite.Build _ _ _ _ _ (kscore mr) sfinite_kscore. -End score_sfinite_kernel. +End kscore. -(* decomposition of if-then-else *) +(* decomposition of ite into s-finite kernels *) Module ITE. -Section ite_true_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u1 : R.-ker T ~> T'). +Section kiteT. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k : R.-ker X ~> Y). -Definition ite_true : T * bool -> {measure set T' -> \bar R} := - fun b => if b.2 then u1 b.1 else [the measure _ _ of mzero]. +Definition kiteT : X * bool -> {measure set Y -> \bar R} := + fun xb => if xb.2 then k xb.1 else [the measure _ _ of mzero]. -Lemma measurable_ite_true U : measurable U -> measurable_fun setT (ite_true ^~ U). +Let measurable_fun_kiteT U : measurable U -> measurable_fun setT (kiteT ^~ U). Proof. -move=> /= mcU. -rewrite /ite_true. -rewrite (_ : (fun x : T * bool => _) = (fun x => if x.2 then u1 x.1 U else [the {measure set T' -> \bar R} of mzero] U)); last first. - apply/funext => -[t b]/=. - by case: ifPn. -apply: (@measurable_fun_if _ _ _ _ (u1 ^~ U) (fun=> mzero U)). +move=> /= mcU; rewrite /kiteT. +rewrite (_ : (fun _ => _) = (fun x => if x.2 then k x.1 U + else [the {measure set Y -> \bar R} of mzero] U)); last first. + by apply/funext => -[t b]/=; case: ifPn. +apply: (@measurable_fun_if _ _ _ _ (k ^~ U) (fun=> mzero U)). exact/measurable_kernel. exact: measurable_fun_cst. Qed. -HB.instance Definition _ := isKernel.Build _ _ _ _ R ite_true measurable_ite_true. -End ite_true_kernel. +HB.instance Definition _ := isKernel.Build _ _ _ _ R kiteT measurable_fun_kiteT. +End kiteT. -Section ite_true_finite_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u1 : R.-fker T ~> T'). +Section fkiteT. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k : R.-fker X ~> Y). -Lemma ite_true_uub : measure_fam_uub (ite_true u1). +Let kiteT_uub : measure_fam_uub (kiteT k). Proof. -have /measure_fam_uubP[M hM] := kernel_uub u1. -exists M%:num => /= -[]; rewrite /ite_true => t [|]/=. - exact: hM. +have /measure_fam_uubP[M hM] := measure_uub k. +exists M%:num => /= -[]; rewrite /kiteT => t [|]/=; first exact: hM. by rewrite /= /mzero. Qed. -HB.instance Definition _ t := - isFiniteKernel.Build _ _ _ _ R (ite_true u1) ite_true_uub. -End ite_true_finite_kernel. +HB.instance Definition _ t := isFiniteFam.Build _ _ _ _ R (kiteT k) kiteT_uub. +End fkiteT. -Section ite_true_sfinite_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u1 : R.-sfker T ~> T'). +Section sfkiteT. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k : R.-sfker X ~> Y). -Let sfinite_ite_true : exists k_ : (R.-fker _ ~> _)^nat, +Let sfinite_kiteT : exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> - ite_true u1 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. + kiteT k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. Proof. -have [k hk /=] := sfinite u1. -rewrite /ite_true. -exists (fun n => [the _.-fker _ ~> _ of ite_true (k n)]) => b U mU. -case: ifPn => hb. +have [k_ hk /=] := sfinite k. +exists (fun n => [the _.-fker _ ~> _ of kiteT (k_ n)]) => b U mU. +rewrite /kiteT; case: ifPn => hb. rewrite /mseries hk//= /mseries. apply: eq_nneseries => n _. - by rewrite /ite_true hb. + by rewrite /kiteT hb. rewrite /= /mseries nneseries0// => n _. -by rewrite /ite_true (negbTE hb). +by rewrite /kiteT (negbTE hb). Qed. -HB.instance Definition _ t := - @isSFiniteKernel.Build _ _ _ _ _ (ite_true u1) sfinite_ite_true. +HB.instance Definition _ t := @isSFinite.Build _ _ _ _ _ (kiteT k) sfinite_kiteT. -End ite_true_sfinite_kernel. +End sfkiteT. -Section ite_false_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u2 : R.-ker T ~> T'). +Section kiteF. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k : R.-ker X ~> Y). -Definition ite_false : T * bool -> {measure set T' -> \bar R} := - fun b => if ~~ b.2 then u2 b.1 else [the measure _ _ of mzero]. +Definition kiteF : X * bool -> {measure set Y -> \bar R} := + fun xb => if ~~ xb.2 then k xb.1 else [the measure _ _ of mzero]. -Let measurable_ite_false U : measurable U -> measurable_fun setT (ite_false ^~ U). +Let measurable_fun_kiteF U : measurable U -> measurable_fun setT (kiteF ^~ U). Proof. -move=> /= mcU. -rewrite /ite_false. -rewrite (_ : (fun x => _) = (fun x => if x.2 then [the {measure set T' -> \bar R} of mzero] U else u2 x.1 U)); last first. +move=> /= mcU; rewrite /kiteF. +rewrite (_ : (fun x => _) = (fun x => if x.2 then [the measure _ _ of mzero] U else k x.1 U)); last first. apply/funext => -[t b]/=. - rewrite if_neg/=. - by case: b. -apply: (@measurable_fun_if _ _ _ _ (fun=> mzero U) (u2 ^~ U)). + by rewrite if_neg//; case: ifPn. +apply: (@measurable_fun_if _ _ _ _ (fun=> mzero U) (k ^~ U)). exact: measurable_fun_cst. exact/measurable_kernel. Qed. -HB.instance Definition _ := isKernel.Build _ _ _ _ R ite_false measurable_ite_false. +HB.instance Definition _ := isKernel.Build _ _ _ _ R kiteF measurable_fun_kiteF. -End ite_false_kernel. +End kiteF. -Section ite_false_finite_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u2 : R.-fker T ~> T'). +Section fkiteF. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k : R.-fker X ~> Y). -Let ite_false_uub : measure_fam_uub (ite_false u2). +Let kiteF_uub : measure_fam_uub (kiteF k). Proof. -have /measure_fam_uubP[M hM] := kernel_uub u2. -exists M%:num => /= -[]; rewrite /ite_false/= => t b. -case: b => //=. -by rewrite /mzero. +have /measure_fam_uubP[M hM] := measure_uub k. +exists M%:num => /= -[]; rewrite /kiteF/= => t. +by case => //=; rewrite /mzero. Qed. -HB.instance Definition _ := - isFiniteKernel.Build _ _ _ _ R (ite_false u2) ite_false_uub. +HB.instance Definition _ := isFiniteFam.Build _ _ _ _ R (kiteF k) kiteF_uub. -End ite_false_finite_kernel. +End fkiteF. -Section ite_false_sfinite_kernel. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType). -Variables (u2 : R.-sfker T ~> T'). +Section sfkiteF. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k : R.-sfker X ~> Y). -Let sfinite_ite_false : exists k_ : (R.-fker _ ~> _)^nat, +Let sfinite_kiteF : exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> - ite_false u2 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. -have [k hk] := sfinite u2. -rewrite /= /ite_false. -exists (fun n => [the finite_kernel _ _ _ of ite_false (k n)]) => b U mU. -case: ifPn => hb. - rewrite /mseries hk//= /mseries/=. - apply: eq_nneseries => // n _. - by rewrite /ite_false hb. -rewrite /= /mseries nneseries0// => n _. -rewrite negbK in hb. -by rewrite /ite_false hb/=. + kiteF k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. +have [k_ hk] := sfinite k. +exists (fun n => [the finite_kernel _ _ _ of kiteF (k_ n)]) => b U mU. +rewrite /= /kiteF /=; case: ifPn => hb. + by rewrite /mseries hk//= /mseries/=. +by rewrite /= /mseries nneseries0. Qed. -HB.instance Definition _ := - @isSFiniteKernel.Build _ _ _ _ _ (ite_false u2) sfinite_ite_false. +HB.instance Definition _ := @isSFinite.Build _ _ _ _ _ (kiteF k) sfinite_kiteF. -End ite_false_sfinite_kernel. +End sfkiteF. End ITE. Section ite. Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). Variables (R : realType) (f : T -> bool) (u1 u2 : R.-sfker T ~> T'). -Definition ite (mf : measurable_fun setT f) : T -> set T' -> \bar R := +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. -Lemma ite0 tb : ite mf tb set0 = 0. -Proof. by rewrite /ite; case: ifPn => //. Qed. +Let mite0 tb : mite mf tb set0 = 0. +Proof. by rewrite /mite; case: ifPn => //. Qed. -Lemma ite_ge0 tb (U : set _) : 0 <= ite mf tb U. -Proof. by rewrite /ite; case: ifPn => //. Qed. +Let mite_ge0 tb (U : set _) : 0 <= mite mf tb U. +Proof. by rewrite /mite; case: ifPn => //. Qed. -Lemma ite_sigma_additive tb : semi_sigma_additive (ite mf tb). +Let mite_sigma_additive tb : semi_sigma_additive (mite mf tb). Proof. -rewrite /ite. -case: ifPn => ftb. - exact: measure_semi_sigma_additive. -exact: measure_semi_sigma_additive. +by rewrite /mite; case: ifPn => ftb; exact: measure_semi_sigma_additive. Qed. -HB.instance Definition _ tb := isMeasure.Build _ _ _ (ite mf tb) - (ite0 tb) (ite_ge0 tb) (@ite_sigma_additive tb). +HB.instance Definition _ tb := isMeasure.Build _ _ _ (mite mf tb) + (mite0 tb) (mite_ge0 tb) (@mite_sigma_additive tb). Import ITE. -Let ite' : R.-sfker - [the measurableType _ of (T * bool)%type] ~> T' := - [the R.-sfker _ ~> _ of add_of_kernels - [the R.-sfker _ ~> T' of ite_true u1] - [the R.-sfker _ ~> T' of ite_false u2] ]. - -Definition mite := [the sfinite_kernel _ _ _ of kernel_mfun R mf] \; ite'. +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] ]. End ite. -Section normalize. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') - (R : realType) (f : R.-sfker T ~> T') (Pdef : probability T' R). +Section insn1. +Variables (R : realType) (d : _) (X : measurableType d). + +Definition score (f : X -> R) (mf : measurable_fun setT f) := + [the R.-sfker X ~> _ of kscore mf]. -Definition Normalize := [the R.-pker T ~> T' of normalize_kernel f Pdef]. +End insn1. -Lemma NormalizeE x U : Normalize x U = normalize_kernel f Pdef x U. +Section insn1_lemmas. +Variables (R : realType) (d : _) (T : measurableType d). + +Lemma scoreE (t : T) (U : set bool) (n : nat) (b : bool) + (f : R -> R) + (f0 : forall r, (0 <= r)%R -> (0 <= f r)%R) + (mf : measurable_fun setT f) : + score (measurable_fun_comp mf (@measurable_fun_snd _ _ _ _)) + (t, b, n%:R) ((fun _ => (snd \o fst) (t, b, tt)) @^-1` U) = + (f n%:R)%:E * \d_b U. Proof. -by []. +rewrite /score/= /mscore/= diracE. +have [U0|U0] := set_unit ((fun=> b) @^-1` U). +- rewrite U0 eqxx memNset ?mule0// => Ub. + by move: U0 => /seteqP[/(_ tt)] /(_ Ub). +- rewrite U0 setT_unit ifF//; last first. + by apply/negbTE/negP => /eqP/seteqP[/(_ tt erefl)]. + rewrite /= mem_set//; last first. + by move: U0 => /seteqP[_]/(_ tt)/=; exact. + by rewrite mule1 ger0_norm// f0. Qed. -End normalize. +End insn1_lemmas. -Section bernoulli27. +Section insn2. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). Variable R : realType. -Local Open Scope ring_scope. -Definition twoseven : {nonneg R} := (2%:R / 7%:R)%:nng. -Definition fiveseven : {nonneg R} := (5%:R / 7%:R)%:nng. -Lemma onem_twoseven : onem (2 / 7) = fiveseven%:num. -Proof. by apply/eqP; rewrite subr_eq/= -mulrDl -natrD divrr// unitfE. Qed. +Definition ret (f : X -> Y) (mf : measurable_fun setT f) := + locked [the R.-sfker X ~> Y of kdirac mf]. -Lemma twoseven_proof : (twoseven%:num <= 1 :> R)%R. -Proof. by rewrite /= lter_pdivr_mulr// mul1r ler_nat. Qed. +Definition sample (P : probability Y R) := + locked [the R.-sfker X ~> Y of kprobability P] . -Definition bernoulli27 : set _ -> \bar R := bernoulli twoseven_proof. +Definition normalize (k : R.-sfker X ~> Y) P := + locked [the R.-pker X ~> Y of knormalize k P]. -End bernoulli27. +Definition ite (f : X -> bool) (mf : measurable_fun setT f) + (k1 k2 : R.-sfker X ~> Y):= + locked [the R.-sfker X ~> Y of kite k1 k2 mf]. -Section insn. -Variables (R : realType). +End insn2. +Arguments sample {d d' X Y R}. -Definition letin (d d' d3 : _) - (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) - (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) - : R.-sfker X ~> Z := - [the sfinite_kernel _ _ _ of l \; k]. - -Lemma letinE (d d' d3 : _) - (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) - (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) - : forall x U, letin l k x U = \int[l x]_y k (x, y) U. -Proof. -by []. -Qed. - -Definition Return (d d' : _) (T : measurableType d) (T' : measurableType d') - (f : T -> T') (mf : measurable_fun setT f) : R.-sfker T ~> T' := - [the sfinite_kernel _ _ _ of @kernel_mfun _ _ T T' R f mf]. - -Definition sample_bernoulli27 (d : _) (T : measurableType d) := - [the sfinite_kernel T _ _ of - kernel_probability [the probability _ _ of bernoulli27 R]] . - -(* NB: score r = observe 0 from exp r, - the density of the exponential distribution exp(r) at 0 is r = r e^(-r * 0) - more generally, score (r e^(-r * t)) = observe t from exp(r), - score (f(r)) = observe r from p where f is the density of p *) -Definition Score (d : _) (T : measurableType d) (r : T -> R) (mr : measurable_fun setT r) : - R.-sfker T ~> Datatypes_unit__canonical__measure_Measurable := - [the sfinite_kernel _ _ R of @kernel_score R _ _ r mr]. - -Lemma ScoreE (d : _) (T : measurableType d) (t : T) (U : set bool) (n : nat) (b : bool) - (f : R -> R) (f0 : forall r, (0 <= r)%R -> (0 <= f r)%R) (mf : measurable_fun setT f) : - Score (measurable_fun_comp mf (@measurable_fun_snd _ _ _ _)) - (t, b, cst n%:R (t, b)) - ((fun y : unit => (snd \o fst) (t, b, y)) @^-1` U) = - (f n%:R)%:E * \d_b U. +Section insn2_lemmas. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variable R : realType. + +Lemma retE (f : X -> Y) (mf : measurable_fun setT f) x : + ret R mf x = \d_(f x) :> (_ -> _). +Proof. by rewrite [in LHS]/ret; unlock. Qed. + +Lemma sampleE (P : probability Y R) (x : X) : sample P x = P. +Proof. by rewrite [in LHS]/sample; unlock. Qed. + +Lemma normalizeE (f : R.-sfker X ~> Y) P x U : + normalize f P x U = + if (f x [set: Y] == 0) || (f x [set: Y] == +oo) then P U + else f x U * ((fine (f x [set: Y]))^-1)%:E. Proof. -rewrite /Score/= /score/= diracE. -have [U0|U0] := set_unit ((fun=> b) @^-1` U). -- rewrite U0 eqxx memNset ?mule0//. - move=> Ub. - move: U0. - move/seteqP => [/(_ tt)] /=. - by move/(_ Ub). -- rewrite U0 setT_unit ifF//; last first. - by apply/negbTE/negP => /eqP/seteqP[/(_ tt erefl)]. - rewrite /= mem_set//; last first. - by move: U0 => /seteqP[_]/(_ tt)/=; exact. - by rewrite mule1 ger0_norm// f0. +by rewrite /normalize; unlock => /=; rewrite /mnormalize; case: ifPn. Qed. -Definition Ite (d d' : _) (T : measurableType d) (T' : measurableType d') - (f : T -> bool) (mf : measurable_fun setT f) - (u1 u2 : R.-sfker T ~> T') - : R.-sfker T ~> T' := - [the R.-sfker _ ~> _ of mite u1 u2 mf]. - -Lemma IteE (d d' : _) (T : measurableType d) (T' : measurableType d') - (f : T -> bool) (mf : measurable_fun setT f) - (u1 u2 : R.-sfker T ~> T') tb U : - Ite mf u1 u2 tb U = ite u1 u2 mf tb U. +Lemma iteE (f : X -> bool) (mf : measurable_fun setT f) + (k1 k2 : R.-sfker X ~> Y) x : + ite mf k1 k2 x = if f x then k1 x else k2 x. Proof. -rewrite /= /kcomp /ite. +apply/eq_measure/funext => U. +rewrite /ite; unlock => /=. +rewrite /kcomp/=. rewrite integral_dirac//=. -rewrite indicT /cst. +rewrite indicT. rewrite mul1e. -rewrite -/(measure_add (ITE.ite_true u1 (tb, f tb)) - (ITE.ite_false u2 (tb, f tb))). +rewrite -/(measure_add (ITE.kiteT k1 (x, f x)) + (ITE.kiteF k2 (x, f x))). rewrite measure_addE. -rewrite /ITE.ite_true /ITE.ite_false/=. -case: (ifPn (f tb)) => /=. - by rewrite /mzero adde0. -by rewrite /mzero add0e. +rewrite /ITE.kiteT /ITE.kiteF/=. +by case: ifPn => fx /=; rewrite /mzero ?(adde0,add0e). Qed. -End insn. +End insn2_lemmas. + +Section insn3. +Variables (R : realType). +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3). + +Definition letin (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) := + locked [the R.-sfker X ~> Z of l \; k]. + +End insn3. + +Section insn3_lemmas. +Variables (R : realType). +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3). + +Lemma letinE (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) x U : + letin l k x U = \int[l x]_y k (x, y) U. +Proof. by rewrite /letin; unlock. Qed. + +End insn3_lemmas. (* a few laws *) @@ -554,25 +541,27 @@ Section letin_return. Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') (Z : measurableType d3). -Lemma letin_ureturn (u : R.-sfker X ~> Y) - (f : _ -> Z) (mf : measurable_fun setT f) : - forall x U, measurable U -> letin u (Return R mf) x U = u x ((fun y => f (x, y)) @^-1` U). +Lemma letin_kret (k : R.-sfker X ~> Y) + (f : _ -> Z) (mf : measurable_fun setT f) x U : + measurable U -> + letin k (ret R mf) x U = k x (curry f x @^-1` U). Proof. -move=> x U mU. -rewrite /letin/= /kcomp/= integral_indic// ?setIT//. +move=> mU. +rewrite letinE. +under eq_integral do rewrite retE. +rewrite integral_indic ?setIT//. move/measurable_fun_prod1 : mf => /(_ x)/(_ measurableT U mU). by rewrite setTI. Qed. -Lemma letin_returnu - (u : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) +Lemma letin_retk (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) (f : _ -> Y) (mf : measurable_fun setT f) : - forall x U, measurable U -> letin (Return R mf) u x U = u (x, f x) U. + forall x U, measurable U -> letin (ret R mf) k x U = k (x, f x) U. Proof. move=> x U mU. -rewrite /letin/= /kcomp/= integral_dirac//. +rewrite letinE retE integral_dirac//. by rewrite indicE mem_set// mul1e. -have /measurable_fun_prod1 := measurable_kernel u _ mU. +have /measurable_fun_prod1 := measurable_kernel k _ mU. exact. Qed. @@ -580,31 +569,44 @@ End letin_return. Section letin_ite. Variables (R : realType) (d d2 d3 : _) (T : measurableType d) - (T2 : measurableType d2) (T3 : measurableType d3) - (u1 u2 : R.-sfker T ~> T3) (u : R.-sfker [the measurableType _ of (T * T3)%type] ~> T2) + (T2 : measurableType d2) (Z : measurableType d3) + (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_ite_true : f t -> letin (Ite mf u1 u2) u t U = letin u1 u t U. +Lemma letin_iteT : f t -> letin (ite mf k1 k2) u t U = letin k1 u t U. Proof. move=> ftT. -rewrite /letin/= /kcomp. +rewrite !letinE/=. apply eq_measure_integral => V mV _. -by rewrite IteE /ite ftT. +by rewrite iteE ftT. Qed. -Lemma letin_ite_false : ~~ f t -> letin (Ite mf u1 u2) u t U = letin u2 u t U. +Lemma letin_iteF : ~~ f t -> letin (ite mf k1 k2) u t U = letin k2 u t U. Proof. move=> ftF. -rewrite /letin/= /kcomp. +rewrite !letinE/=. apply eq_measure_integral => V mV _. -by rewrite IteE/= /ite (negbTE ftF). +by rewrite iteE (negbTE ftF). Qed. End letin_ite. (* sample programs *) +Section constants. +Variable R : realType. +Local Open Scope ring_scope. + +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. + +Lemma p27 : (2 / 7%:R)%:nng%:num <= 1 :> R. +Proof. by rewrite /= lter_pdivr_mulr// mul1r ler_nat. Qed. + +End constants. +Arguments p27 {R}. + Require Import exp. Definition poisson (R : realType) (r : R) (k : nat) := (r ^+ k / k%:R^-1 * expR (- r))%R. @@ -646,34 +648,53 @@ Definition k3 : measurable_fun _ _ := kn 3. Definition k10 : measurable_fun _ _ := kn 10. End cst_fun. +Arguments k3 {R d T}. +Arguments k10 {R d T}. -Lemma letin_sample_bernoulli27 (R : realType) (d d' : _) (T : measurableType d) - (T' : measurableType d') +Module Notations. + +Notation var1_of2 := (@measurable_fun_fst _ _ _ _). +Notation var2_of2 := (@measurable_fun_snd _ _ _ _). +Notation var1_of3 := (measurable_fun_comp (@measurable_fun_fst _ _ _ _) + (@measurable_fun_fst _ _ _ _)). +Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) + (@measurable_fun_fst _ _ _ _)). +Notation var3_of3 := (@measurable_fun_snd _ _ _ _). + +End Notations. + +Lemma letin_sample_bernoulli (R : realType) (d d' : _) (T : measurableType d) + (T' : measurableType d') (r : {nonneg R}) (r1 : (r%:num <= 1)%R) (u : R.-sfker [the measurableType _ of (T * bool)%type] ~> T') x y : - letin (sample_bernoulli27 R T) u x y = - (2 / 7)%:E * u (x, true) y + (5 / 7)%:E * u (x, false) y. + letin (sample (bernoulli r1)) u x y = + r%:num%:E * u (x, true) y + (`1- (r%:num : R))%:E * u (x, false) y. Proof. -rewrite {1}/letin/= {1}/kcomp/=. +rewrite letinE/= sampleE. rewrite ge0_integral_measure_sum//. rewrite 2!big_ord_recl/= big_ord0 adde0/=. rewrite !ge0_integral_mscale//=. rewrite !integral_dirac//=. -rewrite indicE in_setT mul1e indicE in_setT mul1e. -by rewrite onem_twoseven. +by rewrite indicE in_setT mul1e indicE in_setT mul1e. Qed. Section sample_and_return. Variables (R : realType) (d : _) (T : measurableType d). +Import Notations. + Definition sample_and_return : R.-sfker T ~> _ := letin - (sample_bernoulli27 R T) (* T -> B *) - (Return R (@measurable_fun_snd _ _ _ _)) (* T * B -> B *). + (sample (bernoulli p27)) (* T -> B *) + (ret R var2_of2) (* T * B -> B *). Lemma sample_and_returnE t U : sample_and_return t U = - (twoseven R)%:num%:E * \d_true U + - (fiveseven R)%:num%:E * \d_false U. -Proof. by rewrite letin_sample_bernoulli27. Qed. + (2 / 7%:R)%:E * \d_true U + (5%:R / 7%:R)%:E * \d_false U. +Proof. +rewrite /sample_and_return. +rewrite letin_sample_bernoulli/=. +rewrite !retE. +by rewrite onem27. +Qed. End sample_and_return. @@ -682,8 +703,8 @@ Variables (R : realType) (d : _) (T : measurableType d). Definition sample_and_score : R.-sfker T ~> _ := letin - (sample_bernoulli27 R T) (* T -> B *) - (Score (measurable_fun_cst (1%R : R))). + (sample (bernoulli p27)) (* T -> B *) + (score (measurable_fun_cst (1%R : R))). End sample_and_score. @@ -694,18 +715,26 @@ Variables (R : realType) (d : _) (T : measurableType d). let r = case x of {(1, _) => return (k3()), (2, _) => return (k10())} in return r *) +Let mR := Real_sort__canonical__measure_Measurable R. + +Import Notations. + Definition sample_and_branch : - R.-sfker T ~> [the measurableType default_measure_display of Real_sort__canonical__measure_Measurable R] := + R.-sfker T ~> [the measurableType default_measure_display of mR] := letin - (sample_bernoulli27 R T) (* T -> B *) - (Ite (@measurable_fun_snd _ _ _ _) - (Return R (@k3 _ _ [the measurableType _ of (T * bool)%type])) - (Return R (@k10 _ _ [the measurableType _ of (T * bool)%type]))). + (sample (bernoulli p27)) (* T -> B *) + (ite var2_of2 + (ret R k3) + (ret R k10)). Lemma sample_and_branchE t U : sample_and_branch t U = - (twoseven R)%:num%:E * \d_(3%R : R) U + - (fiveseven R)%:num%:E * \d_(10%R : R) U. -Proof. by rewrite /sample_and_branch letin_sample_bernoulli27 !IteE. Qed. + (2 / 7%:R)%:E * \d_(3%:R : R) U + + (5%:R / 7%:R)%:E * \d_(10%:R : R) U. +Proof. +rewrite /sample_and_branch letin_sample_bernoulli/=. +rewrite !iteE/= !retE. +by rewrite onem27. +Qed. End sample_and_branch. @@ -721,72 +750,68 @@ Let mR := Real_sort__canonical__measure_Measurable R. Let munit := Datatypes_unit__canonical__measure_Measurable. Let mbool := Datatypes_bool__canonical__measure_Measurable. -Notation var2_of2 := (@measurable_fun_snd _ _ _ _). -Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) - (@measurable_fun_fst _ _ _ _)). -Notation var3_of3 := (@measurable_fun_snd _ _ _ _). +Variable P : probability mbool R. -Variable Pdef : probability mbool R. +Import Notations. -Definition staton_bus_measure' : R.-sfker T ~> mbool := - (letin - (sample_bernoulli27 R T : _.-sfker T ~> mbool) +Definition staton_bus_annotated : R.-sfker T ~> mbool := + normalize (letin + (sample (bernoulli p27) : _.-sfker T ~> mbool) (letin (letin - (Ite var2_of2 - (Return R (@k3 _ _ _)) - (Return R (@k10 _ _ _)) + (ite var2_of2 + (ret R k3) + (ret R k10) : _.-sfker [the measurableType _ of (T * bool)%type] ~> mR) - (Score (measurable_fun_comp (@mpoisson R 4) var3_of3) + (score (measurable_fun_comp (@mpoisson R 4) var3_of3) : _.-sfker [the measurableType _ of (T * bool* mR)%type] ~> munit) : _.-sfker [the measurableType _ of (T * bool)%type] ~> munit) - (Return R var2_of3 + (ret R var2_of3 : _.-sfker [the measurableType _ of (T * bool * munit)%type] ~> mbool) - : _.-sfker [the measurableType _ of (T * bool)%type] ~> mbool)). + : _.-sfker [the measurableType _ of (T * bool)%type] ~> mbool)) P. -Definition staton_bus_measure : R.-sfker T ~> mbool := - (letin (sample_bernoulli27 R T) +Let staton_bus' : R.-sfker T ~> _ := + (letin (sample (bernoulli p27)) (letin - (letin (Ite var2_of2 - (Return R (@k3 _ _ _)) - (Return R (@k10 _ _ _))) - (Score (measurable_fun_comp (@mpoisson R 4) var3_of3))) - (Return R var2_of3))). + (letin (ite var2_of2 + (ret R k3) + (ret R k10)) + (score (measurable_fun_comp (@mpoisson R 4) var3_of3))) + (ret R var2_of3))). (* 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_measureE t U : staton_bus_measure t U = - (twoseven R)%:num%:E * (poisson 3%:R 4)%:E * \d_true U + - (fiveseven R)%:num%:E * (poisson 10%:R 4)%:E * \d_false U. +Let staton_bus'E t U : staton_bus' t U = + (2 / 7%:R)%:E * (poisson 3%:R 4)%:E * \d_true U + + (5%:R / 7%:R)%:E * (poisson 10%:R 4)%:E * \d_false U. Proof. -rewrite /staton_bus_measure. -rewrite letin_sample_bernoulli27. -rewrite -!muleA. -congr (_ * _ + _ * _). - rewrite letin_ureturn //. - rewrite letin_ite_true//. - rewrite letin_returnu//. - by rewrite ScoreE// => r r0; exact: poisson_ge0. -rewrite letin_ureturn //. -rewrite letin_ite_false//. -rewrite letin_returnu//. -by rewrite ScoreE// => r r0; exact: poisson_ge0. +rewrite /staton_bus'. +rewrite letin_sample_bernoulli. +rewrite -!muleA; congr (_ * _ + _ * _). +- rewrite letin_kret//. + rewrite letin_iteT//. + rewrite letin_retk//. + by rewrite scoreE// => r r0; exact: poisson_ge0. +- by rewrite onem27. + rewrite letin_kret//. + rewrite letin_iteF//. + rewrite letin_retk//. + by rewrite scoreE// => r r0; exact: poisson_ge0. Qed. -Definition staton_bus : R.-pker T ~> mbool := - Normalize staton_bus_measure Pdef. +Definition staton_bus : R.-pker T ~> mbool := normalize staton_bus' P. Lemma staton_busE t U : - let N := (fine (((twoseven R)%:num)%:E * (poisson 3 4)%:E + ((fiveseven R)%:num)%:E * (poisson 10 4)%:E)) in + let N := ((2 / 7%:R) * poisson 3%:R 4 + + (5%:R / 7%:R) * poisson 10%:R 4)%R in staton_bus t U = - ((twoseven R)%:num%:E * (poisson 3%:R 4)%:E * \d_true U + - (fiveseven R)%:num%:E * (poisson 10%:R 4)%:E * \d_false U) * N^-1%:E. + ((2 / 7%:R)%:E * (poisson 3%:R 4)%:E * \d_true U + + (5%:R / 7%:R)%:E * (poisson 10%:R 4)%:E * \d_false U) * N^-1%:E. Proof. rewrite /staton_bus. -rewrite NormalizeE /=. -rewrite /normalize. -rewrite !staton_bus_measureE. +rewrite normalizeE /=. +rewrite !staton_bus'E. rewrite diracE mem_set// mule1. rewrite diracE mem_set// mule1. rewrite ifF //. @@ -798,9 +823,7 @@ End staton_bus. (* wip *) -Definition swap (T1 T2 : Type) (x : T1 * T2) := (x.2, x.1). - -Section letinC_example. +Section letinC. Variables (d d' d3 d4 : _) (R : realType) (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (U : measurableType d4). @@ -820,13 +843,6 @@ apply: measurable_fun_comp => /=. exact: measurable_fun_id. Qed. -Let measurable_fun_swap : measurable_fun [set: X * X] (swap (T2:=X)). -Proof. -apply/prod_measurable_funP => /=; split. - exact: measurable_fun_snd. -exact: measurable_fun_fst. -Qed. - Let f' := @swap _ _ \o f. Lemma mf' : measurable_fun setT f'. Proof. @@ -842,20 +858,30 @@ Variables (t : R.-sfker Datatypes_unit__canonical__measure_Measurable ~> X) (u' : R.-sfker [the measurableType _ of (unit * X)%type] ~> X) (H1 : forall y, u tt = u' (tt, y)) (H2 : forall y, t tt = t' (tt, y)). + Lemma letinC x A : measurable A -> - letin t (letin u' (Return R mf)) x A = letin u (letin t' (Return R mf')) x A. + letin t (letin u' (ret R mf)) x A = letin u (letin t' (ret R mf')) x A. Proof. move=> mA. -rewrite /letin /= /kcomp /= /kcomp /=. +rewrite !letinE. destruct x. rewrite /f/=. -under eq_integral do rewrite -H1. -rewrite (@sfinite_fubini _ _ X X R t u (fun x => (\d_(x.1, x.2) A)))//=. +under eq_integral. + move=> x _. + rewrite letinE/=. + rewrite -H1. + under eq_integral do rewrite retE /=. + over. +rewrite /=. +rewrite (@sfinite_fubini _ _ X X R t u (fun x => \d_(x.1, x.2) A ))//=. apply eq_integral => x _. - by rewrite -H2. + rewrite letinE/=. + rewrite -H2. + apply eq_integral => // x' _. + by rewrite retE. apply/EFin_measurable_fun => /=. rewrite (_ : (fun x => _) = mindic R mA)//. by apply/funext => -[a b] /=. Qed. -End letinC_example. +End letinC. From dbdd7c870ef6a28f2ade92502622409854aa34d4 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Thu, 1 Sep 2022 20:31:03 +0900 Subject: [PATCH 13/54] mscore using mscale and dirac --- theories/kernel.v | 159 ++----------------------------------------- theories/prob_lang.v | 95 ++++++++++---------------- 2 files changed, 41 insertions(+), 213 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 6decb7a906..5f0d7c2e9f 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -74,121 +74,6 @@ Qed. End integralM_0ifneg. Arguments integralM_0ifneg {d T R} m {D} mD f. -Section integralM_indic. -Local Open Scope ereal_scope. -Variables (d : measure_display) (T : measurableType d) (R : realType). -Variables (m : {measure set T -> \bar R}) (D : set T) (mD : measurable D). - -Let integralM_indic (f : R -> set T) (k : R) : - ((k < 0)%R -> f k = set0) -> measurable (f k) -> - \int[m]_(x in D) (k * \1_(f k) x)%:E = k%:E * \int[m]_(x in D) (\1_(f k) x)%:E. -Proof. -move=> fk0 mfk. -under eq_integral do rewrite EFinM. -apply: (integralM_0ifneg _ _ (fun k x => (\1_(f k) x)%:E)) => //=. -- by move=> r t Dt; rewrite lee_fin. -- by move/fk0 => -> /=; apply/funext => x; rewrite indicE in_set0. -- apply/EFin_measurable_fun. - by rewrite (_ : \1_(f k) = mindic R mfk). -Qed. - -End integralM_indic. -Arguments integralM_indic {d T R} m {D} mD f. - -(* NB: PR in progress *) -Section integral_mscale. -Variables (R : realType) (k : {nonneg R}). -Variables (d : measure_display) (T : measurableType d). -Variable (m : {measure set T -> \bar R}) (D : set T) (f : T -> \bar R). -Hypotheses (mD : measurable D). - -Let integral_mscale_indic (E : set T) (mE : measurable E) : - \int[mscale k m]_(x in D) (\1_E x)%:E = - k%:num%:E * \int[m]_(x in D) (\1_E x)%:E. -Proof. by rewrite !integral_indic. Qed. - -Let integral_mscale_nnsfun (h : {nnsfun T >-> R}) : - \int[mscale k m]_(x in D) (h x)%:E = k%:num%:E * \int[m]_(x in D) (h x)%:E. -Proof. -rewrite -ge0_integralM//; last 2 first. -apply/EFin_measurable_fun. - exact: measurable_funS (@measurable_funP _ _ _ h). - by move=> x _; rewrite lee_fin. -under eq_integral do rewrite fimfunE -sumEFin. -under [LHS]eq_integral do rewrite fimfunE -sumEFin. -rewrite /=. -rewrite ge0_integral_sum//; last 2 first. - move=> r. - apply/EFin_measurable_fun/measurable_funrM. - apply: (@measurable_funS _ _ _ _ setT) => //. - have fr : measurable (h @^-1` [set r]) by exact/measurable_sfunP. - by rewrite (_ : \1__ = mindic R fr). - by move=> n x Dx; rewrite EFinM muleindic_ge0. -under eq_integral. - move=> x xD. - rewrite ge0_sume_distrr//; last first. - by move=> r _; rewrite EFinM muleindic_ge0. - over. -rewrite /=. -rewrite ge0_integral_sum//; last 2 first. - move=> r. - apply/EFin_measurable_fun/measurable_funrM/measurable_funrM. - apply: (@measurable_funS _ _ _ _ setT) => //. - have fr : measurable (h @^-1` [set r]) by exact/measurable_sfunP. - by rewrite (_ : \1__ = mindic R fr). - move=> n x Dx. - by rewrite EFinM mule_ge0// muleindic_ge0. -apply eq_bigr => r _. -rewrite ge0_integralM//; last 2 first. - apply/EFin_measurable_fun/measurable_funrM. - apply: (@measurable_funS _ _ _ _ setT) => //. - have fr : measurable (h @^-1` [set r]) by exact/measurable_sfunP. - by rewrite (_ : \1__ = mindic R fr). - by move=> t Dt; rewrite muleindic_ge0. -by rewrite !integralM_indic_nnsfun//= integral_mscale_indic// muleCA. -Qed. - -Lemma ge0_integral_mscale (mf : measurable_fun D f) : - (forall x, D x -> 0 <= f x) -> - \int[mscale k m]_(x in D) f x = k%:num%:E * \int[m]_(x in D) f x. -Proof. -move=> f0; have [f_ [ndf_ f_f]] := approximation mD mf f0. -transitivity (lim (fun n => \int[mscale k m]_(x in D) (f_ n x)%:E)). - rewrite -monotone_convergence//=; last 3 first. - move=> n; apply/EFin_measurable_fun. - by apply: (@measurable_funS _ _ _ _ setT). - by move=> n x Dx; rewrite lee_fin. - by move=> x Dx a b /ndf_ /lefP; rewrite lee_fin. - apply eq_integral => x /[!inE] xD; apply/esym/cvg_lim => //=. - exact: f_f. -rewrite (_ : \int[m]_(x in D) _ = lim (fun n => \int[m]_(x in D) (f_ n x)%:E)); last first. - rewrite -monotone_convergence//. - apply: eq_integral => x /[!inE] xD. - apply/esym/cvg_lim => //. - exact: f_f. - move=> n. - apply/EFin_measurable_fun. - by apply: (@measurable_funS _ _ _ _ setT). - by move=> n x Dx; rewrite lee_fin. - by move=> x Dx a b /ndf_ /lefP; rewrite lee_fin. -rewrite -ereal_limrM//; last first. - apply/ereal_nondecreasing_is_cvg => a b ab. - apply ge0_le_integral => //. - by move=> x Dx; rewrite lee_fin. - apply/EFin_measurable_fun. - by apply: (@measurable_funS _ _ _ _ setT). - by move=> x Dx; rewrite lee_fin. - apply/EFin_measurable_fun. - by apply: (@measurable_funS _ _ _ _ setT). - move=> x Dx. - rewrite lee_fin. - by move/ndf_ : ab => /lefP. -congr (lim _); apply/funext => n /=. -by rewrite integral_mscale_nnsfun. -Qed. - -End integral_mscale. - (* TODO: PR *) Canonical unit_pointedType := PointedType unit tt. @@ -232,23 +117,6 @@ HB.instance Definition _ := @isMeasurable.Build default_measure_display bool (Po End discrete_measurable_bool. -(* NB: PR in progress *) -Lemma measurable_fun_fine (R : realType) (D : set (\bar R)) : measurable D -> - measurable_fun D fine. -Proof. -move=> mD _ /= B mB; rewrite [X in measurable X](_ : _ `&` _ = if 0%R \in B then - D `&` ((EFin @` B) `|` [set -oo; +oo]) else D `&` EFin @` B); last first. - apply/seteqP; split=> [[r [Dr Br]|[Doo B0]|[Doo B0]]|[r| |]]. - - by case: ifPn => _; split => //; left; exists r. - - by rewrite mem_set//; split => //; right; right. - - by rewrite mem_set//; split => //; right; left. - - by case: ifPn => [_ [Dr [[s + [sr]]|[]//]]|_ [Dr [s + [sr]]]]; rewrite sr. - - by case: ifPn => [/[!inE] B0 [Doo [[]//|]] [//|_]|B0 [Doo//] []]. - - by case: ifPn => [/[!inE] B0 [Doo [[]//|]] [//|_]|B0 [Doo//] []]. -case: ifPn => B0; apply/measurableI => //; last exact: measurable_EFin. -by apply: measurableU; [exact: measurable_EFin|exact: measurableU]. -Qed. - (* TODO: PR *) Lemma measurable_fun_fst (d1 d2 : _) (T1 : measurableType d1) (T2 : measurableType d2) : measurable_fun setT (@fst T1 T2). @@ -293,25 +161,6 @@ Qed. End measurable_fun_comp. -Lemma open_continuousP (S T : topologicalType) (f : S -> T) (D : set S) : - open D -> - {in D, continuous f} <-> (forall A, open A -> open (D `&` f @^-1` A)). -Proof. -move=> oD; split=> [fcont|fcont s /[!inE] sD A]. - rewrite !openE => A Aop s [Ds] /Aop /fcont; rewrite inE => /(_ Ds) fsA. - by rewrite interiorI; split => //; move: oD; rewrite openE; exact. -rewrite nbhs_simpl /= !nbhsE => - [B [[oB Bfs] BA]]. -by exists (D `&` f @^-1` B); split=> [|t [Dt] /BA//]; split => //; exact/fcont. -Qed. - -Lemma open_continuous_measurable_fun (R : realType) (f : R -> R) D : - open D -> {in D, continuous f} -> measurable_fun D f. -Proof. -move=> oD /(open_continuousP _ oD) cf. -apply: (measurability (RGenOpens.measurableE R)) => _ [_ [a [b ->] <-]]. -by apply: open_measurable; exact/cf/interval_open. -Qed. - Lemma set_boolE (B : set bool) : [\/ B == [set true], B == [set false], B == set0 | B == setT]. Proof. have [Bt|Bt] := boolP (true \in B). @@ -771,7 +620,7 @@ rewrite [X in measurable_fun _ X](_ : _ = (fun x => apply/EFin_measurable_fun/measurable_funrM/measurable_fun_prod1 => /=. rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r))//. exact/measurable_funP. - - by move=> m y _; rewrite muleindic_ge0. + - by move=> m y _; rewrite nnfun_muleindic_ge0. apply emeasurable_fun_sum => r. rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * \int[l x]_y (\1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. @@ -1103,7 +952,7 @@ rewrite ge0_integral_sum//; last 2 first. move=> r; apply/EFin_measurable_fun/measurable_funrM. have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. by rewrite (_ : \1__ = mindic R fr). - by move=> r z _; rewrite EFinM muleindic_ge0. + by move=> r z _; rewrite EFinM nnfun_muleindic_ge0. under [in RHS]eq_integral. move=> y _. under eq_integral. @@ -1114,7 +963,7 @@ under [in RHS]eq_integral. move=> r; apply/EFin_measurable_fun/measurable_funrM. have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. by rewrite (_ : \1__ = mindic R fr). - by move=> r z _; rewrite EFinM muleindic_ge0. + by move=> r z _; rewrite EFinM nnfun_muleindic_ge0. under eq_bigr. move=> r _. rewrite (@integralM_indic _ _ _ _ _ _ (fun r => f @^-1` [set r]))//; last first. @@ -1127,7 +976,7 @@ rewrite /= ge0_integral_sum//; last 2 first. have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). by move=> /measurable_fun_prod1; exact. - move=> n y _. - have := @mulem_ge0 _ _ _ (k (x, y)) n (fun n => f @^-1` [set n]). + have := @mulemu_ge0 _ _ _ (k (x, y)) n (fun n => f @^-1` [set n]). by apply; exact: preimage_nnfun0. apply eq_bigr => r _. rewrite (@integralM_indic _ _ _ _ _ _ (fun r => f @^-1` [set r]))//; last first. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index e644a49fd2..12a615e58a 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -42,7 +42,7 @@ apply/prod_measurable_funP => /=; split. exact: measurable_fun_fst. Qed. -Lemma onem1 (R : numDomainType) (p : R) : (p + `1- p = 1)%R. +Lemma onem1' (R : numDomainType) (p : R) : (p + `1- p = 1)%R. Proof. by rewrite /onem addrCA subrr addr0. Qed. Lemma onem_nonneg_proof (R : numDomainType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R) : @@ -68,7 +68,7 @@ Local Close Scope ring_scope. Let mbernoulli_setT : mbernoulli [set: _] = 1. Proof. rewrite /mbernoulli/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. -by rewrite /mscale/= !diracE !in_setT !mule1 -EFinD onem1. +by rewrite /mscale/= !diracE !in_setT !mule1 -EFinD onem1'. Qed. HB.instance Definition _ := @isProbability.Build _ _ R mbernoulli mbernoulli_setT. @@ -81,35 +81,25 @@ Section mscore. Variables (d : _) (T : measurableType d). Variables (R : realType) (f : T -> R). -Definition mscore t (U : set unit) : \bar R := - if U == set0 then 0 else `| (f t)%:E |. +Definition mscore t : {measure set _ -> \bar R} := + let p := NngNum (@normr_ge0 _ _ (`| f t |)%R) in + [the measure _ _ of mscale p [the measure _ _ of dirac tt]]. -Let mscore0 t : mscore t (set0 : set unit) = 0 :> \bar R. -Proof. by rewrite /mscore eqxx. Qed. - -Let mscore_ge0 t U : 0 <= mscore t U. -Proof. by rewrite /mscore; case: ifP. Qed. - -Let mscore_sigma_additive t : semi_sigma_additive (mscore t). +Lemma mscoreE t U : mscore t U = if U == set0 then 0 else `| (f t)%:E |. Proof. -move=> /= F mF tF mUF; rewrite /mscore; case: ifPn => [/eqP/bigcup0P F0|]. - rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. - apply/funext => k. - under eq_bigr do rewrite F0// eqxx. - by rewrite big1. -move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. -rewrite -(cvg_shiftn k.+1)/=. -rewrite (_ : (fun _ => _) = cst `|(f t)%:E|); first exact: cvg_cst. -apply/funext => n. -rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. -rewrite (negbTE Fk0) big1 ?adde0// => i/= ik; rewrite ifT//. -have [/eqP//|Fitt] := set_unit (F i). -move/trivIsetP : tF => /(_ i k Logic.I Logic.I ik). -by rewrite Fitt setTI => /eqP; rewrite (negbTE Fk0). +rewrite /mscore/= /mscale/=; have [->|->] := set_unit U. + by rewrite eqxx diracE in_set0 mule0. +rewrite diracE in_setT mule1 ifF// ?normr_id//. +by apply/negbTE/set0P; exists tt. Qed. -HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ - (mscore t) (mscore0 t) (mscore_ge0 t) (@mscore_sigma_additive t). +Lemma measurable_fun_mscore U : measurable_fun setT f -> + measurable_fun setT (mscore ^~ U). +Proof. +move=> mr; under eq_fun do rewrite mscoreE/=. +have [U0|U0] := eqVneq U set0; first exact: measurable_fun_cst. +by apply: measurable_fun_comp => //; exact: measurable_fun_comp. +Qed. End mscore. @@ -138,39 +128,34 @@ Lemma k_sigma_additive i t : semi_sigma_additive (k mr i t). Proof. move=> /= F mF tF mUF; rewrite /k /=. have [F0|] := eqVneq (\bigcup_n F n) set0. - rewrite [in X in _ --> X]/mscore F0 eqxx. - rewrite (_ : (fun _ => _) = cst 0). + rewrite F0 measure0 (_ : (fun _ => _) = cst 0). by case: ifPn => _; exact: cvg_cst. apply/funext => k; rewrite big1// => n _. - move : F0 => /bigcup0P F0. - by rewrite /mscore F0// eqxx; case: ifP. + by move: F0 => /bigcup0P -> //; rewrite measure0; case: ifPn. move=> UF0; move: (UF0). move=> /eqP/bigcup0P/existsNP[m /not_implyP[_ /eqP Fm0]]. -rewrite [in X in _ --> X]/mscore (negbTE UF0). +rewrite [in X in _ --> X]mscoreE (negbTE UF0). rewrite -(cvg_shiftn m.+1)/=. case: ifPn => ir. rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. apply/funext => n. rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn m))))//=. - rewrite [in X in X + _]/mscore (negbTE Fm0) ir big1 ?adde0// => /= j jk. - rewrite /mscore. - have /eqP Fj0 : F j == set0. + rewrite [in X in X + _]mscoreE (negbTE Fm0) ir big1 ?adde0// => /= j jk. + rewrite mscoreE; have /eqP -> : F j == set0. have [/eqP//|Fjtt] := set_unit (F j). move/trivIsetP : tF => /(_ j m Logic.I Logic.I jk). by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fm0). - rewrite Fj0 eqxx. - by case: ifP. + by rewrite eqxx; case: ifP. rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. apply/funext => n. rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn m))))//=. -rewrite [in X in if X then _ else _]/mscore (negbTE Fm0) (negbTE ir) add0e. +rewrite [in X in if X then _ else _]mscoreE (negbTE Fm0) (negbTE ir) add0e. rewrite big1//= => j jm. -rewrite /mscore. -have /eqP Fj0 : F j == set0. +rewrite mscoreE; have /eqP -> : F j == set0. have [/eqP//|Fjtt] := set_unit (F j). move/trivIsetP : tF => /(_ j m Logic.I Logic.I jm). by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fm0). -by rewrite Fj0 eqxx; case: ifP. +by rewrite eqxx; case: ifP. Qed. HB.instance Definition _ i t := isMeasure.Build _ _ _ @@ -181,16 +166,12 @@ Proof. move=> /= mU; rewrite /k /=. rewrite (_ : (fun x : T => _) = (fun x => if (i%:R)%:E <= x < (i.+1%:R)%:E then x else 0) \o (mscore r ^~ U)) //. -apply: measurable_fun_comp => /=; last first. - rewrite /mscore. - have [U0|U0] := eqVneq U set0; first exact: measurable_fun_cst. - by apply: measurable_fun_comp => //; exact/EFin_measurable_fun. +apply: measurable_fun_comp => /=; last exact/measurable_fun_mscore. pose A : _ -> \bar R := (fun x => x * (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set (\bar R)) x)%:E). rewrite (_ : (fun x => _) = A); last first. apply/funext => x; rewrite /A; case: ifPn => ix. by rewrite indicE/= mem_set ?mule1//. - rewrite indicE/= memNset ?mule0//. - by rewrite /= in_itv/=; exact/negP. + by rewrite indicE/= memNset ?mule0// /= in_itv/=; exact/negP. rewrite {}/A. apply emeasurable_funM => /=; first exact: measurable_fun_id. apply/EFin_measurable_fun. @@ -206,8 +187,7 @@ HB.instance Definition _ i := Lemma mk_uub (i : nat) : measure_fam_uub (mk i). Proof. -exists i.+1%:R => /= t. -rewrite /k /mscore setT_unit. +exists i.+1%:R => /= t; rewrite /k mscoreE setT_unit. rewrite (_ : [set tt] == set0 = false); last first. by apply/eqP => /seteqP[] /(_ tt) /(_ erefl). by case: ifPn => // /andP[]. @@ -228,11 +208,7 @@ Definition kscore (mr : measurable_fun setT r) Variable (mr : measurable_fun setT r). Let measurable_fun_kscore U : measurable U -> measurable_fun setT (kscore mr ^~ U). -Proof. -move=> /= mU; rewrite /mscore. -have [U0|U0] := eqVneq U set0; first exact: measurable_fun_cst. -by apply: measurable_fun_comp => //; exact/EFin_measurable_fun. -Qed. +Proof. by move=> /= _; exact: measurable_fun_mscore. Qed. HB.instance Definition _ := isKernel.Build _ _ T _ (*Datatypes_unit__canonical__measure_Measurable*) R (kscore mr) measurable_fun_kscore. @@ -245,9 +221,9 @@ Let sfinite_kscore : exists k : (R.-fker T ~> _)^nat, Proof. rewrite /=. exists (fun i => [the R.-fker _ ~> _ of mk mr i]) => /= t U mU. -rewrite /mseries /mscore; case: ifPn => [/eqP U0|U0]. +rewrite /mseries /kscore/= mscoreE; case: ifPn => [/eqP U0|U0]. by apply/esym/nneseries0 => i _; rewrite U0 measure0. -rewrite /mk /= /k /= /mscore (negbTE U0). +rewrite /mk /= /k /= mscoreE (negbTE U0). apply/esym/cvg_lim => //. rewrite -(cvg_shiftn `|floor (fine `|(r t)%:E|)|%N.+1)/=. rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. @@ -438,10 +414,11 @@ Lemma scoreE (t : T) (U : set bool) (n : nat) (b : bool) (f0 : forall r, (0 <= r)%R -> (0 <= f r)%R) (mf : measurable_fun setT f) : score (measurable_fun_comp mf (@measurable_fun_snd _ _ _ _)) - (t, b, n%:R) ((fun _ => (snd \o fst) (t, b, tt)) @^-1` U) = + (t, b, n%:R) (curry (snd \o fst) (t, b) @^-1` U) = (f n%:R)%:E * \d_b U. Proof. -rewrite /score/= /mscore/= diracE. +set x := score _. +rewrite /score/= /kscore/= mscoreE diracE. have [U0|U0] := set_unit ((fun=> b) @^-1` U). - rewrite U0 eqxx memNset ?mule0// => Ub. by move: U0 => /seteqP[/(_ tt)] /(_ Ub). @@ -827,7 +804,9 @@ Section letinC. Variables (d d' d3 d4 : _) (R : realType) (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (U : measurableType d4). + Let f (xyz : unit * X * X) := (xyz.1.2, xyz.2). + Lemma mf : measurable_fun setT f. Proof. rewrite /=. From 15d569e65dba2cade9934dd399d5386c2eccbfb1 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Fri, 2 Sep 2022 10:16:10 +0900 Subject: [PATCH 14/54] generalize mscoreE --- theories/kernel.v | 283 +++++++++++++++++-------------------------- theories/prob_lang.v | 117 +++++++++++------- 2 files changed, 186 insertions(+), 214 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 5f0d7c2e9f..ec15c77e3d 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -83,16 +83,18 @@ Definition discrete_measurable_unit : set (set unit) := [set: set unit]. Let discrete_measurable0 : discrete_measurable_unit set0. Proof. by []. Qed. -Let discrete_measurableC X : discrete_measurable_unit X -> discrete_measurable_unit (~` X). +Let discrete_measurableC X : + discrete_measurable_unit X -> discrete_measurable_unit (~` X). Proof. by []. Qed. Let discrete_measurableU (F : (set unit)^nat) : - (forall i, discrete_measurable_unit (F i)) -> discrete_measurable_unit (\bigcup_i F i). + (forall i, discrete_measurable_unit (F i)) -> + discrete_measurable_unit (\bigcup_i F i). Proof. by []. Qed. -HB.instance Definition _ := @isMeasurable.Build default_measure_display unit (Pointed.class _) - discrete_measurable_unit discrete_measurable0 discrete_measurableC - discrete_measurableU. +HB.instance Definition _ := @isMeasurable.Build default_measure_display unit + (Pointed.class _) discrete_measurable_unit discrete_measurable0 + discrete_measurableC discrete_measurableU. End discrete_measurable_unit. @@ -111,9 +113,9 @@ Let discrete_measurableU (F : (set bool)^nat) : discrete_measurable_bool (\bigcup_i F i). Proof. by []. Qed. -HB.instance Definition _ := @isMeasurable.Build default_measure_display bool (Pointed.class _) - discrete_measurable_bool discrete_measurable0 discrete_measurableC - discrete_measurableU. +HB.instance Definition _ := @isMeasurable.Build default_measure_display bool + (Pointed.class _) discrete_measurable_bool discrete_measurable0 + discrete_measurableC discrete_measurableU. End discrete_measurable_bool. @@ -143,130 +145,105 @@ Variables (T1 : measurableType d1). Variables (T2 : measurableType d2). Variables (T3 : measurableType d3). -Lemma measurable_fun_comp_new F (f : T2 -> T3) E (g : T1 -> T2) : +(* NB: this generalizes MathComp's measurable_fun_comp' *) +Lemma measurable_fun_comp' F (f : T2 -> T3) E (g : T1 -> T2) : measurable F -> g @` E `<=` F -> measurable_fun F f -> measurable_fun E g -> measurable_fun E (f \o g). Proof. move=> mF FgE mf mg /= mE A mA. rewrite comp_preimage. -rewrite [X in measurable X](_ : _ = (E `&` g @^-1` (F `&` f @^-1` A))); last first. - apply/seteqP; split. - move=> x/= [Ex Afgx]; split => //; split => //. - by apply: FgE => //. - by move=> x/= [Ex] [Fgx Afgx]. -apply/mg => //. -by apply: mf => //. +rewrite [X in measurable X](_ : _ = E `&` g @^-1` (F `&` f @^-1` A)); last first. + apply/seteqP; split=> [|? [?] []//]. + by move=> x/= [Ex Afgx]; split => //; split => //; exact: FgE. +by apply/mg => //; exact: mf. Qed. End measurable_fun_comp. +Lemma set_unit (A : set unit) : A = set0 \/ A = setT. +Proof. +have [->|/set0P[[] Att]] := eqVneq A set0; [by left|right]. +by apply/seteqP; split => [|] []. +Qed. + Lemma set_boolE (B : set bool) : [\/ B == [set true], B == [set false], B == set0 | B == setT]. Proof. have [Bt|Bt] := boolP (true \in B). have [Bf|Bf] := boolP (false \in B). have -> : B = setT. by apply/seteqP; split => // -[] _; [rewrite inE in Bt| rewrite inE in Bf]. - apply/or4P. - by rewrite eqxx/= !orbT. + by apply/or4P; rewrite eqxx/= !orbT. have -> : B = [set true]. apply/seteqP; split => -[]//=. by rewrite notin_set in Bf. by rewrite inE in Bt. - apply/or4P. - by rewrite eqxx/=. + by apply/or4P; rewrite eqxx. have [Bf|Bf] := boolP (false \in B). have -> : B = [set false]. apply/seteqP; split => -[]//=. by rewrite notin_set in Bt. by rewrite inE in Bf. - apply/or4P. - by rewrite eqxx/= orbT. + by apply/or4P; rewrite eqxx/= orbT. have -> : B = set0. apply/seteqP; split => -[]//=. by rewrite notin_set in Bt. by rewrite notin_set in Bf. -apply/or4P. -by rewrite eqxx/= !orbT. +by apply/or4P; rewrite eqxx/= !orbT. Qed. -Lemma measurable_fun_if000 (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') - D (md : measurable D) (f : T -> bool) (mf : measurable_fun setT f) : - measurable_fun (D `&` [set b | f b ]) x -> - measurable_fun (D `&` [set b | ~~ f b]) y -> - measurable_fun D (fun b : T => if f b then x b else y b). +Lemma measurable_fun_if (d d' : _) (T : measurableType d) + (T' : measurableType d') (x y : T -> T') D (md : measurable D) + (f : T -> bool) (mf : measurable_fun setT f) : + measurable_fun (D `&` (f @^-1` [set true])) x -> + measurable_fun (D `&` (f @^-1` [set false])) y -> + measurable_fun D (fun t => if f t then x t else y t). Proof. move=> mx my /= _ Y mY. -have H1 : measurable (D `&` [set b | f b]). +have mDf : measurable (D `&` [set b | f b]). apply: measurableI => //. rewrite [X in measurable X](_ : _ = f @^-1` [set true])//. - have := mf measurableT [set true]. - rewrite setTI. - exact. -have := mx H1 Y mY. -have H0 : [set t | ~~ f t] = [set t | f t = false]. - by apply/seteqP; split => [t/= /negbTE//|t/= ->]. -have H2 : measurable (D `&` [set b | ~~ f b]). + by have := mf measurableT [set true]; rewrite setTI; exact. +have := mx mDf Y mY. +have mDNf : measurable (D `&` f @^-1` [set false]). apply: measurableI => //. - have := mf measurableT [set false]. - rewrite setTI. - rewrite /preimage/=. - by rewrite H0; exact. -have := my H2 Y mY. + by have := mf measurableT [set false]; rewrite setTI; exact. +have := my mDNf Y mY. move=> yY xY. -rewrite (_ : _ @^-1` Y = ([set b | f b = true] `&` (x @^-1` Y) `&` (f @^-1` [set true])) `|` - ([set b | f b = false] `&` (y @^-1` Y) `&` (f @^-1` [set false]))); last first. - apply/seteqP; split. - move=> t/=; case: ifPn => ft. - by left. - by right. - by move=> t/= [|]; case: ifPn => ft; case=> -[]. -rewrite setIUr. -apply: measurableU. - rewrite -(setIid D). - rewrite -(setIA D). - rewrite setICA. - rewrite setIA. - apply: measurableI => //. - by rewrite setIA. - - rewrite -(setIid D). - rewrite -(setIA D). - rewrite setICA. - rewrite setIA. - rewrite /preimage/=. - rewrite -H0. - apply: measurableI => //. - by rewrite setIA. +rewrite (_ : _ @^-1` Y = + ((f @^-1` [set true]) `&` (x @^-1` Y) `&` (f @^-1` [set true])) `|` + ((f @^-1` [set false]) `&` (y @^-1` Y) `&` (f @^-1` [set false]))); last first. + apply/seteqP; split=> [t /=| t]. + by case: ifPn => ft; [left|right]. + by move=> /= [|]; case: ifPn => ft; case=> -[]. +rewrite setIUr; apply: measurableU. +- rewrite -(setIid D) -(setIA D) setICA setIA. + by apply: measurableI => //; rewrite setIA. +- rewrite -(setIid D) -(setIA D) setICA setIA. + by apply: measurableI => //; rewrite setIA. Qed. -Lemma measurable_fun_if0 (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') - (f : T -> bool) (mf : measurable_fun setT f) : - measurable_fun setT x -> - measurable_fun setT y -> - measurable_fun setT (fun b : T => if f b then x b else y b). +Lemma measurable_fun_ifT (d d' : _) (T : measurableType d) + (T' : measurableType d') (x y : T -> T') (f : T -> bool) + (mf : measurable_fun setT f) : + measurable_fun setT x -> measurable_fun setT y -> + measurable_fun setT (fun t => if f t then x t else y t). Proof. -move=> mx my. -apply: measurable_fun_if000 => //. -by apply: measurable_funS mx. -by apply: measurable_funS my. +by move=> mx my; apply: measurable_fun_if => //; + [exact: measurable_funS mx|exact: measurable_funS my]. Qed. -Lemma measurable_fun_if (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') : - measurable_fun setT x -> - measurable_fun setT y -> - measurable_fun setT (fun b : T * bool => if b.2 then x b.1 else y b.1). +Lemma measurable_fun_if_pair (d d' : _) (T : measurableType d) + (T' : measurableType d') (x y : T -> T') : + measurable_fun setT x -> measurable_fun setT y -> + measurable_fun setT (fun tb => if tb.2 then x tb.1 else y tb.1). Proof. move=> mx my. have {}mx : measurable_fun [set: T * bool] (x \o fst). - apply: measurable_fun_comp => //. - exact: measurable_fun_fst. + by apply: measurable_fun_comp => //; exact: measurable_fun_fst. have {}my : measurable_fun [set: T * bool] (y \o fst). - apply: measurable_fun_comp => //. - exact: measurable_fun_fst. -rewrite /=. -apply: measurable_fun_if0 => //=. -exact: measurable_fun_snd. + by apply: measurable_fun_comp => //; exact: measurable_fun_fst. +by apply: measurable_fun_ifT => //=; exact: measurable_fun_snd. Qed. Lemma emeasurable_itv (R : realType) (i : nat) : @@ -279,12 +256,6 @@ apply: measurableU. exact: emeasurable_itv_ninfty_bnd. exact: emeasurable_itv_bnd_pinfty. Qed. - -Lemma set_unit (A : set unit) : A = set0 \/ A = setT. -Proof. -have [->|/set0P[[] Att]] := eqVneq A set0; [by left|right]. -by apply/seteqP; split => [|] []. -Qed. (*/ PR*) Reserved Notation "R .-ker X ~> Y" (at level 42). @@ -474,19 +445,6 @@ HB.instance Definition _ := @isProbabilityFam.Build _ _ _ _ _ _ is_probability_k HB.end. -(*Section tmp. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType) - (f : R.-fker T ~> T'). - -Let tmp : exists k_ : (R.-fker _ ~> _)^nat, - forall x U, measurable U -> - f x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. exact: sfinite_finite. Qed. - -HB.instance Definition _ := - @isSFiniteKernel.Build d d' T T' R f tmp. -End tmp.*) - (* see measurable_prod_subset in lebesgue_integral.v; the differences between the two are: - m2 is a kernel instead of a measure @@ -1106,17 +1064,13 @@ transitivity (\sum_(n t _; exact: integral_ge0 => x _. -(* have := @measurable_fun_integral_sfinite_kernel _ _ _ Y R la. - rewrite /=.*) - rewrite /=. rewrite [X in measurable_fun _ X](_ : _ = fun x => \sum_(n x. rewrite ge0_integral_measure_series//. exact/measurable_fun_prod1. apply: ge0_emeasurable_fun_sum => //. - move=> k x. - by apply: integral_ge0. + by move=> k x; exact: integral_ge0. move=> k. apply: measurable_fun_fubini_tonelli_F => //=. apply: finite_measure_sigma_finite. @@ -1158,9 +1112,7 @@ transitivity (\int[[the measure _ _ of mseries (fun i => la_ i tt) 0]]_y \int[[t rewrite ge0_integral_measure_series//. exact/measurable_fun_prod2. rewrite /=. -transitivity ( - \int[la tt]_y \int[mseries (fun i : nat => mu_ i tt) 0]_x f (x, y) -). +transitivity (\int[la tt]_y \int[mseries (fun i : nat => mu_ i tt) 0]_x f (x, y)). apply eq_measure_integral => A mA _ /=. by rewrite la_E. apply eq_integral => y _. @@ -1278,47 +1230,39 @@ HB.instance Definition _ t := isSFinite.Build _ _ _ _ R (kadd k1 k2) sfinite_kadd. End sfkadd. -Lemma measurable_eq_cst (d d' : _) (T : measurableType d) (T' : measurableType d') - (R : realType) (f : R.-ker T ~> T') k : +Section kernel_measurable_preimage. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). +Variable R : realType. + +Lemma measurable_eq_cst (f : R.-ker T ~> T') k : measurable [set t | f t setT == k]. Proof. rewrite [X in measurable X](_ : _ = (f ^~ setT) @^-1` [set k]); last first. by apply/seteqP; split => t/= /eqP. -rewrite /=. -have := measurable_kernel f setT measurableT. -rewrite /=. -move/(_ measurableT [set k]). -rewrite setTI. -exact. +have /(_ measurableT [set k]) := measurable_kernel f setT measurableT. +by rewrite setTI; exact. Qed. -Lemma measurable_neq_cst (d d' : _) (T : measurableType d) (T' : measurableType d') - (R : realType) (f : R.-ker T ~> T') k : measurable [set t | f t setT != k]. +Lemma measurable_neq_cst (f : R.-ker T ~> T') k : + measurable [set t | f t setT != k]. Proof. -rewrite [X in measurable X](_ : _ = (f ^~ setT) @^-1` (setT `\` [set k])); last first. - apply/seteqP; split => t/=. - by move/eqP; tauto. - by move=> []? /eqP; tauto. -rewrite /=. -have := measurable_kernel f setT measurableT. -rewrite /=. -move/(_ measurableT (setT `\` [set k])). -rewrite setTI. -apply => //. -exact: measurableD. +rewrite [X in measurable X](_ : _ = (f ^~ setT) @^-1` [set~ k]); last first. + by apply/seteqP; split => t /eqP. +have /(_ measurableT [set~ k]) := measurable_kernel f setT measurableT. +by rewrite setTI; apply => //; exact: measurableC. Qed. -Lemma measurable_fun_eq_cst (d d' : _) (T : measurableType d) (T' : measurableType d') - (R : realType) (f : R.-ker T ~> T') k : measurable_fun [set: T] (fun b : T => f b setT == k). +End kernel_measurable_preimage. + +Lemma measurable_fun_eq_cst (d d' : _) (T : measurableType d) + (T' : measurableType d') (R : realType) (f : R.-ker T ~> T') k : + measurable_fun setT (fun t => f t setT == k). Proof. -move=> _ /= B mB. -rewrite setTI. +move=> _ /= B mB; rewrite setTI. have [/eqP->|/eqP->|/eqP->|/eqP->] := set_boolE B. - exact: measurable_eq_cst. - rewrite (_ : _ @^-1` _ = [set b | f b setT != k]); last first. - apply/seteqP; split => t/=. - by move/negbT. - by move/negbTE. + by apply/seteqP; split => [t /negbT//|t /negbTE]. exact: measurable_neq_cst. - by rewrite preimage_set0. - by rewrite preimage_setT. @@ -1326,7 +1270,8 @@ Qed. Section mnormalize. Variables (d d' : _) (T : measurableType d) (Y : measurableType d'). -Variables (R : realType) (f : T -> {measure set Y -> \bar R}) (P : probability Y R). +Variables (R : realType) (f : T -> {measure set Y -> \bar R}). +Variable P : probability Y R. Definition mnormalize t U := let evidence := f t setT in @@ -1335,8 +1280,7 @@ Definition mnormalize t U := Let mnormalize0 t : mnormalize t set0 = 0. Proof. -rewrite /mnormalize; case: ifPn => // _. -by rewrite measure0 mul0e. +by rewrite /mnormalize; case: ifPn => // _; rewrite measure0 mul0e. Qed. Let mnormalize_ge0 t U : 0 <= mnormalize t U. @@ -1347,14 +1291,14 @@ Proof. move=> F mF tF mUF; rewrite /mnormalize/=. case: ifPn => [_|_]. exact: measure_semi_sigma_additive. -rewrite (_ : (fun n => _) = ((fun n=> \sum_(0 <= i < n) f t (F i)) \* +rewrite (_ : (fun n => _) = ((fun n => \sum_(0 <= i < n) f t (F i)) \* cst ((fine (f t setT))^-1)%:E)); last first. by apply/funext => n; rewrite -ge0_sume_distrl. by apply: ereal_cvgMr => //; exact: measure_semi_sigma_additive. Qed. -HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ - (mnormalize t) (mnormalize0 t) (mnormalize_ge0 t) (@mnormalize_sigma_additive t). +HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ (mnormalize t) + (mnormalize0 t) (mnormalize_ge0 t) (@mnormalize_sigma_additive t). Lemma mnormalize1 t : mnormalize t setT = 1. Proof. @@ -1362,8 +1306,7 @@ rewrite /mnormalize; case: ifPn; first by rewrite probability_setT. rewrite negb_or => /andP[ft0 ftoo]. have ? : f t setT \is a fin_num. by rewrite ge0_fin_numE// lt_neqAle ftoo/= leey. -rewrite -{1}(@fineK _ (f t setT))//. -by rewrite -EFinM divrr// ?unitfE fine_eq0. +by rewrite -{1}(@fineK _ (f t setT))// -EFinM divrr// ?unitfE fine_eq0. Qed. HB.instance Definition _ t := @@ -1383,42 +1326,39 @@ Variable P : probability Y R. Let measurable_fun_knormalize U : measurable U -> measurable_fun setT (knormalize P ^~ U). Proof. -move=> mU. -rewrite /knormalize/= /mnormalize /=. +move=> mU; rewrite /knormalize/= /mnormalize /=. rewrite (_ : (fun _ => _) = (fun x => - if f x [set: Y] == 0 then P U else if f x [set: Y] == +oo then P U - else f x U * ((fine (f x [set: Y]))^-1)%:E)); last first. + if f x setT == 0 then P U else if f x setT == +oo then P U + else f x U * ((fine (f x setT))^-1)%:E)); last first. apply/funext => x; case: ifPn => [/orP[->//|->]|]. by case: ifPn. by rewrite negb_or=> /andP[/negbTE -> /negbTE ->]. -apply: measurable_fun_if000 => //. +apply: measurable_fun_if => //. - exact: measurable_fun_eq_cst. - exact: measurable_fun_cst. -- apply: measurable_fun_if000 => //. - + rewrite setTI. +- apply: measurable_fun_if => //. + + rewrite setTI [X in measurable X](_ : _ = [set t | f t setT != 0]); last first. + by apply/seteqP; split => [x /negbT//|x /negbTE]. exact: measurable_neq_cst. + exact: measurable_fun_eq_cst. + exact: measurable_fun_cst. + apply: emeasurable_funM. - have := (measurable_kernel f U mU). - by apply: measurable_funS => //. + by have := measurable_kernel f U mU; exact: measurable_funS. apply/EFin_measurable_fun. - rewrite /=. - apply: (measurable_fun_comp_new (F := [set r : R | r != 0%R])) => //. - exact: open_measurable. - move=> /= r [t] [] [_ H1] H2 H3. + apply: (measurable_fun_comp' (F := [set r : R | r != 0%R])) => //. + * exact: open_measurable. + * move=> /= r [t] [] [_ H1] H2 H3. apply/eqP => H4; subst r. move/eqP : H4. - rewrite fine_eq0 ?(negbTE H1)//. + rewrite fine_eq0 ?H1//. rewrite ge0_fin_numE//. by rewrite lt_neqAle leey H2. - apply: open_continuous_measurable_fun => //. - apply/in_setP => x /= x0. - by apply: inv_continuous. - apply: measurable_fun_comp => /=. - exact: measurable_fun_fine. - have := (measurable_kernel f setT measurableT). - by apply: measurable_funS => //. + * apply: open_continuous_measurable_fun => //. + apply/in_setP => x /= x0. + by apply: inv_continuous. + * apply: measurable_fun_comp => /=. + exact: measurable_fun_fine. + by have := measurable_kernel f _ measurableT; exact: measurable_funS. Qed. HB.instance Definition _ := isKernel.Build _ _ _ _ R (knormalize P) @@ -1429,8 +1369,7 @@ Proof. rewrite /knormalize/= /mnormalize. case: ifPn => [_|]; first by rewrite probability_setT. rewrite negb_or => /andP[fx0 fxoo]. -have ? : f x [set: _] \is a fin_num. - by rewrite ge0_fin_numE// lt_neqAle fxoo/= leey. +have ? : f x setT \is a fin_num by rewrite ge0_fin_numE// lt_neqAle fxoo/= leey. rewrite -{1}(@fineK _ (f x setT))//=. by rewrite -EFinM divrr// ?lte_fin ?ltr1n// ?unitfE fine_eq0. Qed. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 12a615e58a..0de50bd9db 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -33,13 +33,16 @@ Local Open Scope ring_scope. Local Open Scope ereal_scope. (* TODO: PR *) +Lemma setT0 (T1 : pointedType) : setT != set0 :> set T1. +Proof. by apply/eqP => /seteqP[] /(_ point) /(_ Logic.I). Qed. + Definition swap (T1 T2 : Type) (x : T1 * T2) := (x.2, x.1). -Lemma measurable_fun_swap d (X : measurableType d) : measurable_fun [set: X * X] (swap (T2:=X)). +Lemma measurable_fun_swap d d' (X : measurableType d) (Y : measurableType d') : + measurable_fun [set: X * Y] (@swap X Y). Proof. -apply/prod_measurable_funP => /=; split. - exact: measurable_fun_snd. -exact: measurable_fun_fst. +by apply/prod_measurable_funP => /=; split; + [exact: measurable_fun_snd|exact: measurable_fun_fst]. Qed. Lemma onem1' (R : numDomainType) (p : R) : (p + `1- p = 1)%R. @@ -89,8 +92,7 @@ Lemma mscoreE t U : mscore t U = if U == set0 then 0 else `| (f t)%:E |. Proof. rewrite /mscore/= /mscale/=; have [->|->] := set_unit U. by rewrite eqxx diracE in_set0 mule0. -rewrite diracE in_setT mule1 ifF// ?normr_id//. -by apply/negbTE/set0P; exists tt. +by rewrite diracE in_setT mule1 (negbTE (setT0 _)) normr_id. Qed. Lemma measurable_fun_mscore U : measurable_fun setT f -> @@ -264,7 +266,7 @@ move=> /= mcU; rewrite /kiteT. rewrite (_ : (fun _ => _) = (fun x => if x.2 then k x.1 U else [the {measure set Y -> \bar R} of mzero] U)); last first. by apply/funext => -[t b]/=; case: ifPn. -apply: (@measurable_fun_if _ _ _ _ (k ^~ U) (fun=> mzero U)). +apply: (@measurable_fun_if_pair _ _ _ _ (k ^~ U) (fun=> mzero U)). exact/measurable_kernel. exact: measurable_fun_cst. Qed. @@ -321,7 +323,7 @@ move=> /= mcU; rewrite /kiteF. rewrite (_ : (fun x => _) = (fun x => if x.2 then [the measure _ _ of mzero] U else k x.1 U)); last first. apply/funext => -[t b]/=. by rewrite if_neg//; case: ifPn. -apply: (@measurable_fun_if _ _ _ _ (fun=> mzero U) (k ^~ U)). +apply: (@measurable_fun_if_pair _ _ _ _ (fun=> mzero U) (k ^~ U)). exact: measurable_fun_cst. exact/measurable_kernel. Qed. @@ -398,39 +400,6 @@ Definition kite := End ite. -Section insn1. -Variables (R : realType) (d : _) (X : measurableType d). - -Definition score (f : X -> R) (mf : measurable_fun setT f) := - [the R.-sfker X ~> _ of kscore mf]. - -End insn1. - -Section insn1_lemmas. -Variables (R : realType) (d : _) (T : measurableType d). - -Lemma scoreE (t : T) (U : set bool) (n : nat) (b : bool) - (f : R -> R) - (f0 : forall r, (0 <= r)%R -> (0 <= f r)%R) - (mf : measurable_fun setT f) : - score (measurable_fun_comp mf (@measurable_fun_snd _ _ _ _)) - (t, b, n%:R) (curry (snd \o fst) (t, b) @^-1` U) = - (f n%:R)%:E * \d_b U. -Proof. -set x := score _. -rewrite /score/= /kscore/= mscoreE diracE. -have [U0|U0] := set_unit ((fun=> b) @^-1` U). -- rewrite U0 eqxx memNset ?mule0// => Ub. - by move: U0 => /seteqP[/(_ tt)] /(_ Ub). -- rewrite U0 setT_unit ifF//; last first. - by apply/negbTE/negP => /eqP/seteqP[/(_ tt erefl)]. - rewrite /= mem_set//; last first. - by move: U0 => /seteqP[_]/(_ tt)/=; exact. - by rewrite mule1 ger0_norm// f0. -Qed. - -End insn1_lemmas. - Section insn2. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). Variable R : realType. @@ -544,6 +513,70 @@ Qed. End letin_return. +Section insn1. +Variables (R : realType) (d : _) (X : measurableType d). + +Definition score (f : X -> R) (mf : measurable_fun setT f) := + [the R.-sfker X ~> _ of kscore mf]. + +End insn1. + +Section insn1_lemmas. +Variables (R : realType) (d : _) (T : measurableType d). + +Lemma scoreE' d' (T' : measurableType d') d2 (T2 : measurableType d2) (U : set T') + (g : R.-sfker [the measurableType _ of (T2 * unit)%type] ~> T') r fh (mh : measurable_fun setT fh) : + (score mh \; g) r U = + g (r, tt) U * `|fh r|%:E. +Proof. +rewrite [in LHS]/score [in LHS]/=. +rewrite /kcomp. +rewrite /kscore. +rewrite [in LHS]/=. +rewrite ge0_integral_mscale//=. +rewrite integral_dirac// normr_id muleC. +by rewrite indicE in_setT mul1e. +Qed. + +Lemma scoreE (t : T) (U : set bool) (n : nat) (b : bool) + (f : R -> R) + (f0 : forall r, (0 <= r)%R -> (0 <= f r)%R) + (mf : measurable_fun setT f) : + score (measurable_fun_comp mf (@measurable_fun_snd _ _ _ _)) + (t, b, n%:R) (curry (snd \o fst) (t, b) @^-1` U) = + (f n%:R)%:E * \d_b U. +Proof. +transitivity (letin ( + score (measurable_fun_comp mf (measurable_fun_snd (T2:=Real_sort__canonical__measure_Measurable R))) + ) ( + ret R (@measurable_fun_id _ _ _) +) (t, b, n%:R) (curry (snd \o fst) (t, b) @^-1` U)). + rewrite letin_kret//. + rewrite /curry/=. + rewrite preimage_cst. + by case: ifPn => //. +rewrite /letin. +unlock. +rewrite scoreE'//. +rewrite retE. +by rewrite ger0_norm// ?f0//= muleC. +Qed. + +(* example of property *) +Lemma score_score (f : R -> R) (g : R * unit -> R) (mf : measurable_fun setT f) (mg : measurable_fun setT g) x U : + letin (score mf) (score mg) x U = if U == set0 then 0 else `|g (x, tt)|%:E * `|f x|%:E. +Proof. +rewrite {1}/letin. +unlock. +rewrite scoreE'//=. +rewrite /mscale/= diracE !normr_id. +have [->|->]:= set_unit U. + by rewrite eqxx in_set0 mule0 mul0e. +by rewrite in_setT mule1 (negbTE (setT0 _)). +Qed. + +End insn1_lemmas. + Section letin_ite. Variables (R : realType) (d d2 d3 : _) (T : measurableType d) (T2 : measurableType d2) (Z : measurableType d3) @@ -731,7 +764,7 @@ Variable P : probability mbool R. Import Notations. -Definition staton_bus_annotated : R.-sfker T ~> mbool := +Definition staton_bus_annotated : R.-pker T ~> mbool := normalize (letin (sample (bernoulli p27) : _.-sfker T ~> mbool) (letin From cf854c1463ff07aaeee6a7f39419db826a2100fc Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Thu, 8 Sep 2022 10:13:33 +0900 Subject: [PATCH 15/54] various minor simplifications and generalizations --- theories/kernel.v | 1273 ++++++++++++++++++++---------------------- theories/prob_lang.v | 175 ++++-- 2 files changed, 735 insertions(+), 713 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index ec15c77e3d..646cc75c79 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -8,14 +8,21 @@ Require Import lebesgue_measure fsbigop numfun lebesgue_integral. (******************************************************************************) (* Kernels *) (* *) -(* R.-ker X ~> Y == kernel *) -(* R.-sfker X ~> Y == s-finite kernel *) -(* R.-fker X ~> Y == finite kernel *) -(* R.-pker X ~> Y == probability kernel *) -(* sum_of_kernels == *) -(* l \; k == composition of kernels *) -(* kdirac mf == kernel defined by a measurable function *) -(* kadd k1 k2 == *) +(* This file provides a formation of kernels and extends the theory of *) +(* measure with, e.g., Fubini's theorem for s-finite measures. *) +(* *) +(* R.-ker X ~> Y == kernel *) +(* kseries == countable sum of kernels *) +(* R.-sfker X ~> Y == s-finite kernel *) +(* R.-fker X ~> Y == finite kernel *) +(* R.-pker X ~> Y == probability kernel *) +(* finite_measure mu == the measure mu is finite *) +(* sfinite_measure mu == the measure my is s-finite *) +(* kprobability m == kernel defined by a probability measure *) +(* kdirac mf == kernel defined by a measurable function *) +(* kadd k1 k2 == lifting of the addition of measures to kernels *) +(* mnormalize f == normalization of a kernel to a probability *) +(* l \; k == composition of kernels *) (******************************************************************************) Set Implicit Arguments. @@ -256,12 +263,27 @@ apply: measurableU. exact: emeasurable_itv_ninfty_bnd. exact: emeasurable_itv_bnd_pinfty. Qed. + +Section fubini_tonelli. (* TODO: move to lebesgue_integral.v *) +Local Open Scope ereal_scope. +Variables (d1 d2 : measure_display). +Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). +Variables (m1 : {measure set T1 -> \bar R}) (m2 : {measure set T2 -> \bar R}). +Hypotheses (sm1 : sigma_finite setT m1) (sm2 : sigma_finite setT m2). +Variables (f : T1 * T2 -> \bar R) (f0 : forall xy, 0 <= f xy). +Variables (mf : measurable_fun setT f). + +Lemma fubini_tonelli : + \int[m1]_x \int[m2]_y f (x, y) = \int[m2]_y \int[m1]_x f (x, y). +Proof. by rewrite -fubini_tonelli1// fubini_tonelli2. Qed. + +End fubini_tonelli. (*/ PR*) -Reserved Notation "R .-ker X ~> Y" (at level 42). -Reserved Notation "R .-fker X ~> Y" (at level 42). -Reserved Notation "R .-sfker X ~> Y" (at level 42). -Reserved Notation "R .-pker X ~> Y" (at level 42). +Reserved Notation "R .-ker X ~> Y" (at level 42, format "R .-ker X ~> Y"). +Reserved Notation "R .-fker X ~> Y" (at level 42, format "R .-fker X ~> Y"). +Reserved Notation "R .-sfker X ~> Y" (at level 42, format "R .-sfker X ~> Y"). +Reserved Notation "R .-pker X ~> Y" (at level 42, format "R .-pker X ~> Y"). HB.mixin Record isKernel d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) := @@ -275,42 +297,35 @@ Notation "R .-ker X ~> Y" := (kernel X Y R). Arguments measurable_kernel {_ _ _ _ _} _. -Section sum_of_kernels. +Section kseries. Variables (d d' : measure_display) (R : realType). Variables (X : measurableType d) (Y : measurableType d'). Variable k : (R.-ker X ~> Y)^nat. -Definition sum_of_kernels : X -> {measure set Y -> \bar R} := +Definition kseries : X -> {measure set Y -> \bar R} := fun x => [the measure _ _ of mseries (k ^~ x) 0]. -Lemma kernel_measurable_fun_sum_of_kernels (U : set Y) : +Lemma measurable_fun_kseries (U : set Y) : measurable U -> - measurable_fun setT (sum_of_kernels ^~ U). + measurable_fun setT (kseries ^~ U). Proof. -move=> mU; rewrite /sum_of_kernels /= /mseries. -rewrite [X in measurable_fun _ X](_ : _ = - (fun x => elim_sup (fun n => \sum_(0 <= i < n) k i x U))); last first. - apply/funext => x; rewrite -lim_mkord is_cvg_elim_supE. - by rewrite -lim_mkord. - exact: is_cvg_nneseries. -apply: measurable_fun_elim_sup => n. -by apply: emeasurable_fun_sum => *; exact/measurable_kernel. +move=> mU; rewrite /kseries /= /mseries. +by apply: ge0_emeasurable_fun_sum => // n; apply/measurable_kernel. Qed. HB.instance Definition _ := - isKernel.Build _ _ _ _ _ sum_of_kernels - kernel_measurable_fun_sum_of_kernels. + isKernel.Build _ _ _ _ _ kseries measurable_fun_kseries. -End sum_of_kernels. +End kseries. -Lemma integral_sum_of_kernels +Lemma integral_kseries (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType) (k : (R.-ker X ~> Y)^nat) (f : Y -> \bar R) x : (forall y, 0 <= f y) -> measurable_fun setT f -> - \int[sum_of_kernels k x]_y (f y) = \sum_(i f0 mf; rewrite /sum_of_kernels/= ge0_integral_measure_series. +by move=> f0 mf; rewrite /kseries/= ge0_integral_measure_series. Qed. Section measure_fam_uub. @@ -371,8 +386,7 @@ HB.mixin Record isSFinite d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) := { sfinite : exists s : (R.-fker X ~> Y)^nat, - forall x U, measurable U -> - k x U = [the measure _ _ of mseries (s ^~ x) 0] U }. + forall x U, measurable U -> k x U = kseries s x U }. #[short(type=sfinite_kernel)] HB.structure Definition SFiniteKernel @@ -447,8 +461,9 @@ HB.end. (* see measurable_prod_subset in lebesgue_integral.v; the differences between the two are: - - m2 is a kernel instead of a measure - - m2D_bounded holds for all x *) + - m2 is a kernel instead of a measure (the proof uses the + measurability of each measure of the family) + - as a consequence, m2D_bounded holds for all x *) Section measurable_prod_subset_kernel. Variables (d1 d2 : _) (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). @@ -515,19 +530,14 @@ Lemma measurable_fun_xsection_finite_kernel A : A \in measurable -> measurable_fun setT (phi A). Proof. move: A; suff : measurable `<=` B by move=> + A; rewrite inE => /[apply] -[]. -move=> X mX. -rewrite /B/=; split => //. -rewrite /phi. +move=> /= X mX; rewrite /B/=; split => //; rewrite /phi. rewrite -(_ : (fun x => mrestr (m2 x) measurableT (xsection X x)) = - (fun x => (m2 x) (xsection X x)))//; last first. + (fun x => m2 x (xsection X x)))//; last first. by apply/funext => x//=; rewrite /mrestr setIT. -apply measurable_prod_subset_xsection_kernel => //. -move=> x. -have [r hr] := measure_uub m2. -exists r => Y mY. -apply: (le_lt_trans _ (hr x)) => //. -rewrite /mrestr. -by apply le_measure => //; rewrite inE//; exact: measurableI. +apply measurable_prod_subset_xsection_kernel => // x. +have [r hr] := measure_uub m2; exists r => Y mY. +rewrite (le_lt_trans _ (hr x)) // /mrestr /= setIT. +by apply: le_measure => //; rewrite inE. Qed. End measurable_fun_xsection_finite_kernel. @@ -566,11 +576,11 @@ rewrite (_ : (fun x => _) = - by move=> y _ m n mn; rewrite lee_fin; exact/lefP/ndk_. apply: measurable_fun_elim_sup => n. rewrite [X in measurable_fun _ X](_ : _ = (fun x => \int[l x]_y - (\sum_(r <- fset_set (range (k_ n))) + (\sum_(r <- fset_set (range (k_ n)))(*TODO: upd when the PR is merged*) r * \1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. rewrite [X in measurable_fun _ X](_ : _ = (fun x => - \sum_(r <- fset_set (range (k_ n))) + \sum_(r <- fset_set (range (k_ n)))(*TODO: upd when the PR is merged*) (\int[l x]_y (r * \1_(k_ n @^-1` [set r]) (x, y))%:E))); last first. apply/funext => x; rewrite -ge0_integral_sum//. - by apply: eq_integral => y _; rewrite sumEFin. @@ -632,749 +642,702 @@ Arguments measurable_fun_xsection_integral {_ _ _ _ _} l k. Arguments measurable_fun_integral_finite_kernel {_ _ _ _ _} l k. Arguments measurable_fun_integral_sfinite_kernel {_ _ _ _ _} l k. -Section kcomp_def. -Variables (d1 d2 d3 : _) (X : measurableType d1) (Y : measurableType d2) - (Z : measurableType d3) (R : realType). -Variable l : X -> {measure set Y -> \bar R}. -Variable k : (X * Y)%type -> {measure set Z -> \bar R}. +(*HB.mixin Record isFiniteMeasure d (R : numFieldType) (T : semiRingOfSetsType d) + (mu : set T -> \bar R) := { + finite_measure : mu setT < +oo +}. -Definition kcomp x U := \int[l x]_y k (x, y) U. +#[short(type=fmeasure)] +HB.structure Definition FiniteMeasure d (R : realFieldType) + (T : semiRingOfSetsType d) := + {mu of isMeasure d R T mu & isFiniteMeasure d R T mu}. -End kcomp_def. +Notation "{ 'fmeasure' 'set' T '->' '\bar' R }" := (@fmeasure _ R T) + (at level 36, T, R at next level, + format "{ 'fmeasure' 'set' T '->' '\bar' R }") : ring_scope.*) -Section kcomp_is_measure. -Variables (d1 d2 d3 : _) (X : measurableType d1) (Y : measurableType d2) - (Z : measurableType d3) (R : realType). -Variable l : R.-ker X ~> Y. -Variable k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z. +Definition finite_measure d (T : measurableType d) (R : realType) + (mu : set T -> \bar R) := + mu setT < +oo. -Local Notation "l \; k" := (kcomp l k). +Definition sfinite_measure d (T : measurableType d) (R : realType) + (mu : set T -> \bar R) := + exists mu_ : {measure set T -> \bar R}^nat, + (forall n, finite_measure (mu_ n)) /\ + (forall U, measurable U -> mu U = mseries mu_ 0 U). -Let kcomp0 x : (l \; k) x set0 = 0. +Lemma finite_measure_sigma_finite d (T : measurableType d) (R : realType) + (mu : {measure set T -> \bar R}) : + finite_measure mu -> sigma_finite setT mu. Proof. -by rewrite /kcomp (eq_integral (cst 0)) ?integral0// => y _; rewrite measure0. +exists (fun i => if i \in [set 0%N] then setT else set0). + by rewrite -bigcup_mkcondr setTI bigcup_const//; exists 0%N. +move=> n; split; first by case: ifPn. +by case: ifPn => // _; rewrite ?measure0//; exact: finite_measure. Qed. -Let kcomp_ge0 x U : 0 <= (l \; k) x U. Proof. exact: integral_ge0. Qed. +Section sfinite_fubini. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). +Variables (m1 : {measure set X -> \bar R}) (sfm1 : sfinite_measure m1). +Variables (m2 : {measure set Y -> \bar R}) (sfm2 : sfinite_measure m2). +Variables (f : X * Y -> \bar R) (f0 : forall xy, 0 <= f xy). +Variable (mf : measurable_fun setT f). -Let kcomp_sigma_additive x : semi_sigma_additive ((l \; k) x). +Lemma sfinite_fubini : + \int[m1]_x \int[m2]_y f (x, y) = \int[m2]_y \int[m1]_x f (x, y). Proof. -move=> U mU tU mUU; rewrite [X in _ --> X](_ : _ = - \int[l x]_y (\sum_(n V _. - by apply/esym/cvg_lim => //; exact/measure_semi_sigma_additive. -apply/cvg_closeP; split. - by apply: is_cvg_nneseries => n _; exact: integral_ge0. -rewrite closeE// integral_sum// => n. -by have /measurable_fun_prod1 := measurable_kernel k (U n) (mU n). +have [m1_ [fm1 m1E]] := sfm1. +have [m2_ [fm2 m2E]] := sfm2. +rewrite [LHS](eq_measure_integral [the measure _ _ of mseries m1_ 0]); last first. + by move=> A mA _; rewrite m1E. +transitivity (\int[[the measure _ _ of mseries m1_ 0]]_x + \int[[the measure _ _ of mseries m2_ 0]]_y f (x, y)). + by apply eq_integral => x _; apply: eq_measure_integral => U mA _; rewrite m2E. +transitivity (\sum_(n t _; exact: integral_ge0. + rewrite [X in measurable_fun _ X](_ : _ = + fun x => \sum_(n x. + by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. + apply: ge0_emeasurable_fun_sum; first by move=> k x; exact: integral_ge0. + move=> k; apply: measurable_fun_fubini_tonelli_F => //=. + exact: finite_measure_sigma_finite. + apply: eq_nneseries => n _; apply eq_integral => x _. + by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. +transitivity (\sum_(n n _. + rewrite integral_sum(*TODO: rename to ge0_integral_sum*)//. + move=> m; apply: measurable_fun_fubini_tonelli_F => //=. + exact: finite_measure_sigma_finite. + by move=> m x _; exact: integral_ge0. +transitivity (\sum_(n n _; apply eq_nneseries => m _. + by rewrite fubini_tonelli//; exact: finite_measure_sigma_finite. +transitivity (\sum_(n n _ /=. rewrite ge0_integral_measure_series//. + by move=> y _; exact: integral_ge0. + apply: measurable_fun_fubini_tonelli_G => //=. + by apply: finite_measure_sigma_finite; exact: fm1. +transitivity (\int[[the measure _ _ of mseries m2_ 0]]_y \sum_(n n; apply: measurable_fun_fubini_tonelli_G => //=. + by apply: finite_measure_sigma_finite; exact: fm1. + by move=> n y _; exact: integral_ge0. +transitivity (\int[[the measure _ _ of mseries m2_ 0]]_y + \int[[the measure _ _ of mseries m1_ 0]]_x f (x, y)). + apply eq_integral => y _. + by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod2. +transitivity (\int[m2]_y \int[mseries m1_ 0]_x f (x, y)). + by apply eq_measure_integral => A mA _ /=; rewrite m2E. +by apply eq_integral => y _; apply eq_measure_integral => A mA _ /=; rewrite m1E. Qed. -HB.instance Definition _ x := isMeasure.Build _ R _ - ((l \; k) x) (kcomp0 x) (kcomp_ge0 x) (@kcomp_sigma_additive x). +End sfinite_fubini. +Arguments sfinite_fubini {d d' X Y R m1} _ {m2} _ f. -Definition mkcomp : X -> {measure set Z -> \bar R} := - fun x => [the measure _ _ of (l \; k) x]. +Lemma finite_kernel_finite_measure d (T : measurableType d) (R : realType) + (mu : R.-fker Datatypes_unit__canonical__measure_Measurable ~> T) : + mu tt setT < +oo. +Proof. +have [M muM] := measure_uub mu. +by rewrite /finite_measure (lt_le_trans (muM tt))// leey. +Qed. -End kcomp_is_measure. +Section kprobability. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (m : probability Y R). -Notation "l \; k" := (mkcomp l k). +Definition kprobability : X -> {measure set Y -> \bar R} := fun _ : X => m. -Module KCOMP_FINITE_KERNEL. +Let measurable_fun_kprobability U : measurable U -> + measurable_fun setT (kprobability ^~ U). +Proof. by move=> mU; exact: measurable_fun_cst. Qed. -Section kcomp_finite_kernel_kernel. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) (l : R.-fker X ~> Y) - (k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z). +HB.instance Definition _ := + @isKernel.Build _ _ X Y R kprobability measurable_fun_kprobability. -Lemma measurable_fun_kcomp_finite U : - measurable U -> measurable_fun setT ((l \; k) ^~ U). -Proof. -move=> mU; apply: (measurable_fun_integral_finite_kernel _ (k ^~ U)) => //=. -exact/measurable_kernel. -Qed. +Let kprobability_prob x : kprobability x setT = 1. +Proof. by rewrite /kprobability/= probability_setT. Qed. HB.instance Definition _ := - isKernel.Build _ _ X Z R (l \; k) measurable_fun_kcomp_finite. + @isProbabilityKernel.Build _ _ X Y R kprobability kprobability_prob. -End kcomp_finite_kernel_kernel. +End kprobability. -Section kcomp_finite_kernel_finite. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). -Variable l : R.-fker X ~> Y. -Variable k : R.-fker [the measurableType _ of (X * Y)%type] ~> Z. +Section kdirac. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (f : X -> Y). -Let mkcomp_finite : measure_fam_uub (l \; k). +Definition kdirac (mf : measurable_fun setT f) + : X -> {measure set Y -> \bar R} := + fun x : X => [the measure _ _ of dirac (f x)]. + +Hypothesis mf : measurable_fun setT f. + +Let measurable_fun_kdirac U : measurable U -> + measurable_fun setT (kdirac mf ^~ U). Proof. -have /measure_fam_uubP[r hr] := measure_uub k. -have /measure_fam_uubP[s hs] := measure_uub l. -apply/measure_fam_uubP; exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x /=. -apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). - apply: ge0_le_integral => //. - - have /measurable_fun_prod1 := measurable_kernel k setT measurableT. - exact. - - exact/measurable_fun_cst. - - by move=> y _; exact/ltW/hr. -by rewrite integral_cst//= EFinM lte_pmul2l. +move=> mU; apply/EFin_measurable_fun. +by rewrite (_ : (fun x => _) = mindic R mU \o f)//; exact/measurable_fun_comp. Qed. -HB.instance Definition _ := - isFiniteFam.Build _ _ X Z R (l \; k) mkcomp_finite. +HB.instance Definition _ := isKernel.Build _ _ _ _ _ (kdirac mf) + measurable_fun_kdirac. -End kcomp_finite_kernel_finite. -End KCOMP_FINITE_KERNEL. +Let kdirac_prob x : kdirac mf x setT = 1. +Proof. by rewrite /kdirac/= diracE in_setT. Qed. -Section kcomp_sfinite_kernel. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). -Variable l : R.-sfker X ~> Y. -Variable k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. +HB.instance Definition _ := isProbabilityKernel.Build _ _ _ _ _ + (kdirac mf) kdirac_prob. -Import KCOMP_FINITE_KERNEL. +End kdirac. +Arguments kdirac {d d' X Y R f}. -Lemma mkcomp_sfinite : exists k_ : (R.-fker X ~> Z)^nat, forall x U, measurable U -> - (l \; k) x U = [the measure _ _ of mseries (k_ ^~ x) O] U. -Proof. -have [k_ hk_] := sfinite k. -have [l_ hl_] := sfinite l. -pose K := [the kernel _ _ _ of sum_of_kernels k_]. -pose L := [the kernel _ _ _ of sum_of_kernels l_]. -have H1 x U : measurable U -> (l \; k) x U = (L \; K) x U. - move=> mU /=. - rewrite /kcomp /L /K /=. - (* TODO: lemma so that we can get away with a rewrite *) - transitivity (\int[ - [the measure _ _ of mseries (l_ ^~ x) 0] ]_y k (x, y) U). - by apply eq_measure_integral => A mA _; rewrite hl_. - by apply eq_integral => y _; rewrite hk_. -have H2 x U : (L \; K) x U = - \int[mseries (l_ ^~ x) 0]_y (\sum_(i - \int[mseries (l_ ^~ x) 0]_y (\sum_(i mU. - rewrite integral_sum//= => n. - have := measurable_kernel (k_ n) _ mU. - by move=> /measurable_fun_prod1; exact. -have H4 x U : measurable U -> - \sum_(i mU. - apply: eq_nneseries => i _. - rewrite integral_sum_of_kernels//. - have := measurable_kernel (k_ i) _ mU. - by move=> /measurable_fun_prod1; exact. -have H5 x U : \sum_(i i _; exact: eq_nneseries. -suff: exists k_0 : (R.-fker X ~> Z) ^nat, forall x U, - \esum_(i in setT) ((l_ i.2) \; (k_ i.1)) x U = \sum_(i [kl_ hkl_]. - exists kl_ => x U mU. - rewrite /= H1// H2 H3// H4// H5// /mseries -hkl_/=. - rewrite (_ : setT = setT `*`` (fun=> setT)); last by apply/seteqP; split. - rewrite -(@esum_esum _ _ _ _ _ (fun i j => (l_ j \; k_ i) x U))//. - rewrite nneseries_esum; last by move=> n _; exact: nneseries_ge0. - by rewrite fun_true; apply: eq_esum => /= i _; rewrite nneseries_esum// fun_true. -rewrite /=. -have /ppcard_eqP[f] : ([set: nat] #= [set: nat * nat])%card. - by rewrite card_eq_sym; exact: card_nat2. -exists (fun i => [the _.-fker _ ~> _ of (l_ (f i).2) \; (k_ (f i).1)]) => x U. -rewrite (reindex_esum [set: nat] [set: nat * nat] f)//. -by rewrite nneseries_esum// fun_true. -Qed. +Section kadd. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k1 k2 : R.-ker X ~> Y). -Lemma measurable_fun_mkcomp_sfinite U : measurable U -> - measurable_fun setT ((l \; k) ^~ U). +Definition kadd : X -> {measure set Y -> \bar R} := + fun x => [the measure _ _ of measure_add (k1 x) (k2 x)]. + +Let measurable_fun_kadd U : measurable U -> + measurable_fun setT (kadd ^~ U). Proof. -move=> mU; apply: (measurable_fun_integral_sfinite_kernel _ (k ^~ U)) => //. -exact/measurable_kernel. +move=> mU; rewrite /kadd. +rewrite (_ : (fun _ => _) = (fun x => k1 x U + k2 x U)); last first. + by apply/funext => x; rewrite -measure_addE. +by apply: emeasurable_funD; exact/measurable_kernel. Qed. -End kcomp_sfinite_kernel. - -Module KCOMP_SFINITE_KERNEL. -Section kcomp_sfinite_kernel. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). -Variable l : R.-sfker X ~> Y. -Variable k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. - HB.instance Definition _ := - isKernel.Build _ _ X Z R (l \; k) (measurable_fun_mkcomp_sfinite l k). + @isKernel.Build _ _ _ _ _ kadd measurable_fun_kadd. +End kadd. -#[export] -HB.instance Definition _ := - isSFinite.Build _ _ X Z R (l \; k) (mkcomp_sfinite l k). +Section fkadd. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k1 k2 : R.-fker X ~> Y). -End kcomp_sfinite_kernel. -End KCOMP_SFINITE_KERNEL. -HB.export KCOMP_SFINITE_KERNEL. +Let kadd_finite_uub : measure_fam_uub (kadd k1 k2). +Proof. +have [f1 hk1] := measure_uub k1; have [f2 hk2] := measure_uub k2. +exists (f1 + f2)%R => x; rewrite /kadd /=. +rewrite -/(measure_add (k1 x) (k2 x)). +by rewrite measure_addE EFinD; exact: lte_add. +Qed. -(* pollard? *) -Section measurable_fun_integral_kernel'. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d') - (R : realType). -Variables (l : X -> {measure set Y -> \bar R}) - (k : Y -> \bar R) - (k_ : ({nnsfun Y >-> R}) ^nat) - (ndk_ : nondecreasing_seq (k_ : (Y -> R)^nat)) - (k_k : forall z, setT z -> EFin \o (k_ ^~ z) --> k z). +HB.instance Definition _ t := + isFiniteFam.Build _ _ _ _ R (kadd k1 k2) kadd_finite_uub. +End fkadd. -Let p : (X * Y -> R)^nat := fun n xy => k_ n xy.2. +Section sfkadd. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k1 k2 : R.-sfker X ~> Y). -Let p_ge0 n x : (0 <= p n x)%R. Proof. by []. Qed. +Let sfinite_kadd : exists k_ : (R.-fker _ ~> _)^nat, + forall x U, measurable U -> + kadd k1 k2 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. +Proof. +have [f1 hk1] := sfinite k1. +have [f2 hk2] := sfinite k2. +exists (fun n => [the finite_kernel _ _ _ of kadd (f1 n) (f2 n)]) => x U mU. +rewrite /kadd/=. +rewrite -/(measure_add (k1 x) (k2 x)) measure_addE. +rewrite /mseries. +rewrite hk1//= hk2//= /mseries. +rewrite -nneseriesD//. +apply: eq_nneseries => n _. +by rewrite -/(measure_add (f1 n x) (f2 n x)) measure_addE. +Qed. -HB.instance Definition _ n := @IsNonNegFun.Build _ R (p n) (p_ge0 n). +HB.instance Definition _ t := + isSFinite.Build _ _ _ _ R (kadd k1 k2) sfinite_kadd. +End sfkadd. -Let mp n : measurable_fun setT (p n). +Section kernel_measurable_preimage. +Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). +Variable R : realType. + +Lemma measurable_eq_cst (f : R.-ker T ~> T') k : + measurable [set t | f t setT == k]. Proof. -rewrite /p => _ /= B mB; rewrite setTI. -have mk_n : measurable_fun setT (k_ n) by []. -rewrite (_ : _ @^-1` _ = setT `*` (k_ n @^-1` B)); last first. - by apply/seteqP; split => xy /=; tauto. -apply: measurableM => //. -have := mk_n measurableT _ mB. -by rewrite setTI. +rewrite [X in measurable X](_ : _ = (f ^~ setT) @^-1` [set k]); last first. + by apply/seteqP; split => t/= /eqP. +have /(_ measurableT [set k]) := measurable_kernel f setT measurableT. +by rewrite setTI; exact. Qed. -HB.instance Definition _ n := @IsMeasurableFun.Build _ _ R (p n) (mp n). - -Let fp n : finite_set (range (p n)). +Lemma measurable_neq_cst (f : R.-ker T ~> T') k : + measurable [set t | f t setT != k]. Proof. -have := @fimfunP _ _ (k_ n). -suff : range (k_ n) = range (p n) by move=> <-. -by apply/seteqP; split => r [y ?] <-; [exists (point, y)|exists y.2]. +rewrite [X in measurable X](_ : _ = (f ^~ setT) @^-1` [set~ k]); last first. + by apply/seteqP; split => t /eqP. +have /(_ measurableT [set~ k]) := measurable_kernel f setT measurableT. +by rewrite setTI; apply => //; exact: measurableC. Qed. -HB.instance Definition _ n := @FiniteImage.Build _ _ (p n) (fp n). +End kernel_measurable_preimage. -Lemma measurable_fun_preimage_integral : - (forall n r, measurable_fun setT (fun x => l x (k_ n @^-1` [set r]))) -> - measurable_fun setT (fun x => \int[l x]_z k z). +Lemma measurable_fun_eq_cst (d d' : _) (T : measurableType d) + (T' : measurableType d') (R : realType) (f : R.-ker T ~> T') k : + measurable_fun setT (fun t => f t setT == k). Proof. -move=> h. -apply: (measurable_fun_xsection_integral l (fun xy => k xy.2) - (fun n => [the {nnsfun _ >-> _} of p n])) => /=. -- by rewrite /p => m n mn; apply/lefP => -[x y] /=; exact/lefP/ndk_. -- by move=> [x y]; exact: k_k. -- move=> n r _ /= B mB. - have := h n r measurableT B mB. - rewrite !setTI. - suff : ((fun x => l x (k_ n @^-1` [set r])) @^-1` B) = - ((fun x => l x (xsection (p n @^-1` [set r]) x)) @^-1` B) by move=> ->. - apply/seteqP; split => x/=. - suff : (k_ n @^-1` [set r]) = (xsection (p n @^-1` [set r]) x) by move=> ->. - by apply/seteqP; split; move=> y/=; - rewrite /xsection/= /p /preimage/= inE/=. - suff : (k_ n @^-1` [set r]) = (xsection (p n @^-1` [set r]) x) by move=> ->. - by apply/seteqP; split; move=> y/=; rewrite /xsection/= /p /preimage/= inE/=. +move=> _ /= B mB; rewrite setTI. +have [/eqP->|/eqP->|/eqP->|/eqP->] := set_boolE B. +- exact: measurable_eq_cst. +- rewrite (_ : _ @^-1` _ = [set b | f b setT != k]); last first. + by apply/seteqP; split => [t /negbT//|t /negbTE]. + exact: measurable_neq_cst. +- by rewrite preimage_set0. +- by rewrite preimage_setT. Qed. -End measurable_fun_integral_kernel'. +Section mnormalize. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (f : X -> {measure set Y -> \bar R}). +Variable P : probability Y R. -Lemma measurable_fun_integral_kernel - (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) - (l : R.-ker [the measurableType _ of (X * Y)%type] ~> Z) c - (k : Z -> \bar R) (k0 : forall z, True -> 0 <= k z) (mk : measurable_fun setT k) : - measurable_fun setT (fun y => \int[l (c, y)]_z k z). +Definition mnormalize x U := + let evidence := f x [set: Y] in + if (evidence == 0) || (evidence == +oo) then P U + else f x U * (fine evidence)^-1%:E. + +Let mnormalize0 x : mnormalize x set0 = 0. Proof. -have [k_ [ndk_ k_k]] := approximation measurableT mk k0. -apply: (measurable_fun_preimage_integral ndk_ k_k) => n r. -have := measurable_kernel l (k_ n @^-1` [set r]) (measurable_sfunP (k_ n) r). -by move=> /measurable_fun_prod1; exact. +by rewrite /mnormalize; case: ifPn => // _; rewrite measure0 mul0e. Qed. -Section integral_kcomp. +Let mnormalize_ge0 x U : 0 <= mnormalize x U. +Proof. by rewrite /mnormalize; case: ifPn => //; case: ifPn. Qed. -Let integral_kcomp_indic d d' d3 (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) - x (E : set _) (mE : measurable E) : - \int[(l \; k) x]_z (\1_E z)%:E = \int[l x]_y (\int[k (x, y)]_z (\1_E z)%:E). +Lemma mnormalize_sigma_additive x : semi_sigma_additive (mnormalize x). Proof. -rewrite integral_indic//= /kcomp. -by apply eq_integral => y _; rewrite integral_indic. +move=> F mF tF mUF; rewrite /mnormalize/=. +case: ifPn => [_|_]. + exact: measure_semi_sigma_additive. +rewrite (_ : (fun n => _) = ((fun n => \sum_(0 <= i < n) f x (F i)) \* + cst ((fine (f x setT))^-1)%:E)); last first. + by apply/funext => n; rewrite -ge0_sume_distrl. +by apply: ereal_cvgMr => //; exact: measure_semi_sigma_additive. Qed. -Let integral_kcomp_nnsfun d d' d3 (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) - x (f : {nnsfun Z >-> R}) : - \int[(l \; k) x]_z (f z)%:E = \int[l x]_y (\int[k (x, y)]_z (f z)%:E). -Proof. -under [in LHS]eq_integral do rewrite fimfunE -sumEFin. -rewrite ge0_integral_sum//; last 2 first. - move=> r; apply/EFin_measurable_fun/measurable_funrM. - have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. - by rewrite (_ : \1__ = mindic R fr). - by move=> r z _; rewrite EFinM nnfun_muleindic_ge0. -under [in RHS]eq_integral. - move=> y _. - under eq_integral. - move=> z _. - rewrite fimfunE -sumEFin. - over. - rewrite /= ge0_integral_sum//; last 2 first. - move=> r; apply/EFin_measurable_fun/measurable_funrM. - have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. - by rewrite (_ : \1__ = mindic R fr). - by move=> r z _; rewrite EFinM nnfun_muleindic_ge0. - under eq_bigr. - move=> r _. - rewrite (@integralM_indic _ _ _ _ _ _ (fun r => f @^-1` [set r]))//; last first. - by move=> r0; rewrite preimage_nnfun0. - rewrite integral_indic// setIT. - over. - over. -rewrite /= ge0_integral_sum//; last 2 first. - - move=> r; apply: measurable_funeM. - have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). - by move=> /measurable_fun_prod1; exact. - - move=> n y _. - have := @mulemu_ge0 _ _ _ (k (x, y)) n (fun n => f @^-1` [set n]). - by apply; exact: preimage_nnfun0. -apply eq_bigr => r _. -rewrite (@integralM_indic _ _ _ _ _ _ (fun r => f @^-1` [set r]))//; last first. - exact: preimage_nnfun0. -rewrite /= integral_kcomp_indic; last exact/measurable_sfunP. -rewrite (@integralM_0ifneg _ _ _ _ _ _ (fun r t => k (x, t) (f @^-1` [set r])))//; last 2 first. - move=> r0. - apply/funext => y. - by rewrite preimage_nnfun0// measure0. - have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). - by move/measurable_fun_prod1; exact. -congr (_ * _); apply eq_integral => y _. -by rewrite integral_indic// setIT. -Qed. +HB.instance Definition _ x := isMeasure.Build _ _ _ (mnormalize x) + (mnormalize0 x) (mnormalize_ge0 x) (@mnormalize_sigma_additive x). -Lemma integral_kcomp d d' d3 (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) - x f : (forall z, 0 <= f z) -> measurable_fun setT f -> - \int[(l \; k) x]_z f z = \int[l x]_y (\int[k (x, y)]_z f z). +Lemma mnormalize1 x : mnormalize x setT = 1. Proof. -move=> f0 mf. -have [f_ [ndf_ f_f]] := approximation measurableT mf (fun z _ => f0 z). -transitivity (\int[(l \; k) x]_z (lim (EFin \o (f_^~ z)))). - apply/eq_integral => z _. - apply/esym/cvg_lim => //=. - exact: f_f. -rewrite monotone_convergence//; last 3 first. - by move=> n; apply/EFin_measurable_fun. - by move=> n z _; rewrite lee_fin. - by move=> z _ a b /ndf_ /lefP ab; rewrite lee_fin. -rewrite (_ : (fun _ => _) = (fun n => \int[l x]_y (\int[k (x, y)]_z (f_ n z)%:E)))//; last first. - by apply/funext => n; rewrite integral_kcomp_nnsfun. -transitivity (\int[l x]_y lim (fun n => \int[k (x, y)]_z (f_ n z)%:E)). - rewrite -monotone_convergence//; last 3 first. - move=> n. - apply: measurable_fun_integral_kernel => //. - - by move=> z; rewrite lee_fin. - - by apply/EFin_measurable_fun. - - move=> n y _. - by apply integral_ge0 => // z _; rewrite lee_fin. - - move=> y _ a b ab. - apply: ge0_le_integral => //. - + by move=> z _; rewrite lee_fin. - + exact/EFin_measurable_fun. - + by move=> z _; rewrite lee_fin. - + exact/EFin_measurable_fun. - + move: ab => /ndf_ /lefP ab z _. - by rewrite lee_fin. -apply eq_integral => y _. -rewrite -monotone_convergence//; last 3 first. - move=> n; exact/EFin_measurable_fun. - by move=> n z _; rewrite lee_fin. - by move=> z _ a b /ndf_ /lefP; rewrite lee_fin. -apply eq_integral => z _. -apply/cvg_lim => //. -exact: f_f. +rewrite /mnormalize; case: ifPn; first by rewrite probability_setT. +rewrite negb_or => /andP[ft0 ftoo]. +have ? : f x setT \is a fin_num. + by rewrite ge0_fin_numE// lt_neqAle ftoo/= leey. +by rewrite -{1}(@fineK _ (f x setT))// -EFinM divrr// ?unitfE fine_eq0. Qed. -End integral_kcomp. +HB.instance Definition _ x := + isProbability.Build _ _ _ (mnormalize x) (mnormalize1 x). -Definition finite_measure d (T : measurableType d) (R : realType) (mu : set T -> \bar R) := - mu setT < +oo. +End mnormalize. -Lemma finite_kernel_finite_measure d (T : measurableType d) (R : realType) - (mu : R.-fker Datatypes_unit__canonical__measure_Measurable ~> T) : - finite_measure (mu tt). -Proof. -have [M muM] := measure_uub mu. -by rewrite /finite_measure (lt_le_trans (muM tt))// leey. -Qed. +Section knormalize. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (f : R.-ker X ~> Y). -Lemma finite_measure_sigma_finite d (T : measurableType d) (R : realType) - (mu : {measure set T -> \bar R}) : - finite_measure mu -> sigma_finite setT mu. -Proof. -rewrite /finite_measure => muoo. -exists (fun i => if i \in [set 0%N] then setT else set0). - by rewrite -bigcup_mkcondr setTI bigcup_const//; exists 0%N. -move=> n; split; first by case: ifPn. -by case: ifPn => // _; rewrite measure0. -Qed. +Definition knormalize (P : probability Y R) := + fun t => [the measure _ _ of mnormalize f P t]. -Section finite_fubini. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). -Variables (mu : {measure set X -> \bar R}) (fmu : finite_measure mu). -Variables (la : {measure set Y -> \bar R}) (fla : finite_measure la). -Variables (f : X * Y -> \bar R) (f0 : forall xy, 0 <= f xy). -Variables (mf : measurable_fun setT f). +Variable P : probability Y R. -Lemma finite_fubini : - \int[mu]_x \int[la]_y f (x, y) = \int[la]_y \int[mu]_x f (x, y). +Let measurable_fun_knormalize U : + measurable U -> measurable_fun setT (knormalize P ^~ U). Proof. -rewrite -fubini_tonelli1//. - exact: finite_measure_sigma_finite. -move=> H. -rewrite fubini_tonelli2//. -exact: finite_measure_sigma_finite. +move=> mU; rewrite /knormalize/= /mnormalize /=. +rewrite (_ : (fun _ => _) = (fun x => + if f x setT == 0 then P U else if f x setT == +oo then P U + else f x U * ((fine (f x setT))^-1)%:E)); last first. + apply/funext => x; case: ifPn => [/orP[->//|->]|]. + by case: ifPn. + by rewrite negb_or=> /andP[/negbTE -> /negbTE ->]. +apply: measurable_fun_if => //. +- exact: measurable_fun_eq_cst. +- exact: measurable_fun_cst. +- apply: measurable_fun_if => //. + + rewrite setTI [X in measurable X](_ : _ = [set t | f t setT != 0]); last first. + by apply/seteqP; split => [x /negbT//|x /negbTE]. + exact: measurable_neq_cst. + + exact: measurable_fun_eq_cst. + + exact: measurable_fun_cst. + + apply: emeasurable_funM. + by have := measurable_kernel f U mU; exact: measurable_funS. + apply/EFin_measurable_fun. + apply: (measurable_fun_comp' (F := [set r : R | r != 0%R])) => //. + * exact: open_measurable. + * move=> /= r [t] [] [_ H1] H2 H3. + apply/eqP => H4; subst r. + move/eqP : H4. + rewrite fine_eq0 ?H1//. + rewrite ge0_fin_numE//. + by rewrite lt_neqAle leey H2. + * apply: open_continuous_measurable_fun => //. + apply/in_setP => x /= x0. + by apply: inv_continuous. + * apply: measurable_fun_comp => /=. + exact: measurable_fun_fine. + by have := measurable_kernel f _ measurableT; exact: measurable_funS. Qed. -End finite_fubini. - -Section sfinite_fubini. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). -Variables (mu : R.-sfker Datatypes_unit__canonical__measure_Measurable ~> X). -Variables (la : R.-sfker Datatypes_unit__canonical__measure_Measurable ~> Y). -Variables (f : X * Y -> \bar R) (f0 : forall xy, 0 <= f xy). -Variable (mf : measurable_fun setT f). +HB.instance Definition _ := isKernel.Build _ _ _ _ R (knormalize P) + measurable_fun_knormalize. -Lemma sfinite_fubini : - \int[mu tt]_x \int[la tt]_y f (x, y) = \int[la tt]_y \int[mu tt]_x f (x, y). +Let knormalize1 x : knormalize P x setT = 1. Proof. -have [mu_ mu_E] := sfinite mu. -have [la_ la_E] := sfinite la. -transitivity ( - \int[[the measure _ _ of mseries (fun i => mu_ i tt) 0]]_x - \int[la tt]_y f (x, y)). - apply: eq_measure_integral => U mU _. (* TODO: awkward *) - by rewrite mu_E. -transitivity ( - \int[[the measure _ _ of mseries (fun i => mu_ i tt) 0]]_x - \int[[the measure _ _ of mseries (fun i => la_ i tt) 0]]_y f (x, y)). - apply eq_integral => x _. - apply: eq_measure_integral => U mU _. (* TODO: awkward *) - by rewrite la_E. -transitivity (\sum_(n t _; exact: integral_ge0 => x _. - rewrite [X in measurable_fun _ X](_ : _ = - fun x => \sum_(n x. - rewrite ge0_integral_measure_series//. - exact/measurable_fun_prod1. - apply: ge0_emeasurable_fun_sum => //. - by move=> k x; exact: integral_ge0. - move=> k. - apply: measurable_fun_fubini_tonelli_F => //=. - apply: finite_measure_sigma_finite. - exact: finite_kernel_finite_measure. - apply: eq_nneseries => n _; apply eq_integral => x _. - rewrite ge0_integral_measure_series//. - exact/measurable_fun_prod1. -transitivity (\sum_(n n _. - rewrite integral_sum(*TODO: ge0_integral_sum*)//. - move=> m. - apply: measurable_fun_fubini_tonelli_F => //=. - apply: finite_measure_sigma_finite. - exact: finite_kernel_finite_measure. - by move=> m x _; exact: integral_ge0. -transitivity (\sum_(n n _; apply eq_nneseries => m _. - rewrite finite_fubini//. - exact: finite_kernel_finite_measure. - exact: finite_kernel_finite_measure. -transitivity (\sum_(n la_ i tt) 0]]_y \int[mu_ n tt]_x f (x, y)). - apply eq_nneseries => n _. - rewrite /= ge0_integral_measure_series//. - by move=> y _; exact: integral_ge0. - apply: measurable_fun_fubini_tonelli_G => //=. - apply: finite_measure_sigma_finite. - exact: finite_kernel_finite_measure. -rewrite /=. -transitivity (\int[[the measure _ _ of mseries (fun i => la_ i tt) 0]]_y \sum_(n n. - apply: measurable_fun_fubini_tonelli_G => //=. - apply: finite_measure_sigma_finite. - exact: finite_kernel_finite_measure. - by move=> n y _; exact: integral_ge0. -rewrite /=. -transitivity (\int[[the measure _ _ of mseries (fun i => la_ i tt) 0]]_y \int[[the measure _ _ of mseries (fun i => mu_ i tt) 0]]_x f (x, y)). - apply eq_integral => y _. - rewrite ge0_integral_measure_series//. - exact/measurable_fun_prod2. -rewrite /=. -transitivity (\int[la tt]_y \int[mseries (fun i : nat => mu_ i tt) 0]_x f (x, y)). - apply eq_measure_integral => A mA _ /=. - by rewrite la_E. -apply eq_integral => y _. -apply eq_measure_integral => A mA _ /=. -by rewrite mu_E. +rewrite /knormalize/= /mnormalize. +case: ifPn => [_|]; first by rewrite probability_setT. +rewrite negb_or => /andP[fx0 fxoo]. +have ? : f x setT \is a fin_num by rewrite ge0_fin_numE// lt_neqAle fxoo/= leey. +rewrite -{1}(@fineK _ (f x setT))//=. +by rewrite -EFinM divrr// ?lte_fin ?ltr1n// ?unitfE fine_eq0. Qed. -End sfinite_fubini. - -Section kprobability. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (m : probability Y R). +HB.instance Definition _ := + @isProbabilityKernel.Build _ _ _ _ _ (knormalize P) knormalize1. -Definition kprobability : X -> {measure set Y -> \bar R} := fun _ : X => m. +End knormalize. -Let measurable_fun_kprobability U : measurable U -> - measurable_fun setT (kprobability ^~ U). -Proof. by move=> mU; exact: measurable_fun_cst. Qed. +Section kcomp_def. +Variables (d1 d2 d3 : _) (X : measurableType d1) (Y : measurableType d2) + (Z : measurableType d3) (R : realType). +Variable l : X -> {measure set Y -> \bar R}. +Variable k : (X * Y)%type -> {measure set Z -> \bar R}. -HB.instance Definition _ := - @isKernel.Build _ _ X Y R kprobability measurable_fun_kprobability. +Definition kcomp x U := \int[l x]_y k (x, y) U. -Let kprobability_prob x : kprobability x setT = 1. -Proof. by rewrite /kprobability/= probability_setT. Qed. +End kcomp_def. -HB.instance Definition _ := - @isProbabilityKernel.Build _ _ X Y R kprobability kprobability_prob. - -End kprobability. +Section kcomp_is_measure. +Variables (d1 d2 d3 : _) (X : measurableType d1) (Y : measurableType d2) + (Z : measurableType d3) (R : realType). +Variable l : R.-ker X ~> Y. +Variable k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z. -Section kdirac. -Variables (d d' : _) (T : measurableType d) (Y : measurableType d'). -Variables (R : realType) (f : T -> Y). +Local Notation "l \; k" := (kcomp l k). -Definition kdirac (mf : measurable_fun setT f) : T -> {measure set Y -> \bar R} := - fun t => [the measure _ _ of dirac (f t)]. +Let kcomp0 x : (l \; k) x set0 = 0. +Proof. +by rewrite /kcomp (eq_integral (cst 0)) ?integral0// => y _; rewrite measure0. +Qed. -Hypothesis mf : measurable_fun setT f. +Let kcomp_ge0 x U : 0 <= (l \; k) x U. Proof. exact: integral_ge0. Qed. -Let measurable_fun_kdirac U : measurable U -> measurable_fun setT (kdirac mf ^~ U). +Let kcomp_sigma_additive x : semi_sigma_additive ((l \; k) x). Proof. -move=> mU; apply/EFin_measurable_fun. -rewrite (_ : (fun x => _) = mindic R mU \o f)//. -exact/measurable_fun_comp. +move=> U mU tU mUU; rewrite [X in _ --> X](_ : _ = + \int[l x]_y (\sum_(n V _. + by apply/esym/cvg_lim => //; exact/measure_semi_sigma_additive. +apply/cvg_closeP; split. + by apply: is_cvg_nneseries => n _; exact: integral_ge0. +rewrite closeE// integral_sum// => n. +by have /measurable_fun_prod1 := measurable_kernel k (U n) (mU n). Qed. -HB.instance Definition _ := isKernel.Build _ _ _ _ R (kdirac mf) - measurable_fun_kdirac. +HB.instance Definition _ x := isMeasure.Build _ R _ + ((l \; k) x) (kcomp0 x) (kcomp_ge0 x) (@kcomp_sigma_additive x). -Let kdirac_prob x : kdirac mf x setT = 1. -Proof. by rewrite /kdirac/= diracE in_setT. Qed. +Definition mkcomp : X -> {measure set Z -> \bar R} := + fun x => [the measure _ _ of (l \; k) x]. -HB.instance Definition _ := - @isProbabilityKernel.Build _ _ _ _ _ (kdirac mf) kdirac_prob. +End kcomp_is_measure. -End kdirac. -Arguments kdirac {d d' T Y R f}. +Notation "l \; k" := (mkcomp l k). -Section kadd. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k1 k2 : R.-ker X ~> Y). +Module KCOMP_FINITE_KERNEL. -Definition kadd : X -> {measure set Y -> \bar R} := - fun t => [the measure _ _ of measure_add (k1 t) (k2 t)]. +Section kcomp_finite_kernel_kernel. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) (l : R.-fker X ~> Y) + (k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z). -Let measurable_fun_kadd U : measurable U -> measurable_fun setT (kadd ^~ U). +Lemma measurable_fun_kcomp_finite U : + measurable U -> measurable_fun setT ((l \; k) ^~ U). Proof. -move=> mU; rewrite /kadd. -rewrite (_ : (fun _ => _) = (fun x => k1 x U + k2 x U)); last first. - by apply/funext => x; rewrite -measure_addE. -by apply: emeasurable_funD; exact/measurable_kernel. +move=> mU; apply: (measurable_fun_integral_finite_kernel _ (k ^~ U)) => //=. +exact/measurable_kernel. Qed. HB.instance Definition _ := - @isKernel.Build _ _ _ _ _ kadd measurable_fun_kadd. -End kadd. + isKernel.Build _ _ X Z R (l \; k) measurable_fun_kcomp_finite. -Section fkadd. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k1 k2 : R.-fker X ~> Y). +End kcomp_finite_kernel_kernel. -Let kadd_finite_uub : measure_fam_uub (kadd k1 k2). +Section kcomp_finite_kernel_finite. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : R.-fker X ~> Y. +Variable k : R.-fker [the measurableType _ of (X * Y)%type] ~> Z. + +Let mkcomp_finite : measure_fam_uub (l \; k). Proof. -have [f1 hk1] := measure_uub k1; have [f2 hk2] := measure_uub k2. -exists (f1 + f2)%R => x; rewrite /kadd /=. -rewrite -/(measure_add (k1 x) (k2 x)). -by rewrite measure_addE EFinD; exact: lte_add. +have /measure_fam_uubP[r hr] := measure_uub k. +have /measure_fam_uubP[s hs] := measure_uub l. +apply/measure_fam_uubP; exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x /=. +apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). + apply: ge0_le_integral => //. + - have /measurable_fun_prod1 := measurable_kernel k setT measurableT. + exact. + - exact/measurable_fun_cst. + - by move=> y _; exact/ltW/hr. +by rewrite integral_cst//= EFinM lte_pmul2l. Qed. -HB.instance Definition _ t := - isFiniteFam.Build _ _ _ _ R (kadd k1 k2) kadd_finite_uub. -End fkadd. - -Section sfkadd. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k1 k2 : R.-sfker X ~> Y). +HB.instance Definition _ := + isFiniteFam.Build _ _ X Z R (l \; k) mkcomp_finite. -Let sfinite_kadd : exists k_ : (R.-fker _ ~> _)^nat, - forall x U, measurable U -> - kadd k1 k2 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. -have [f1 hk1] := sfinite k1. -have [f2 hk2] := sfinite k2. -exists (fun n => [the finite_kernel _ _ _ of kadd (f1 n) (f2 n)]) => x U mU. -rewrite /kadd/=. -rewrite -/(measure_add (k1 x) (k2 x)) measure_addE. -rewrite /mseries. -rewrite hk1//= hk2//= /mseries. -rewrite -nneseriesD//. -apply: eq_nneseries => n _. -by rewrite -/(measure_add (f1 n x) (f2 n x)) measure_addE. -Qed. +End kcomp_finite_kernel_finite. +End KCOMP_FINITE_KERNEL. -HB.instance Definition _ t := - isSFinite.Build _ _ _ _ R (kadd k1 k2) sfinite_kadd. -End sfkadd. +Section kcomp_sfinite_kernel. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : R.-sfker X ~> Y. +Variable k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. -Section kernel_measurable_preimage. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). -Variable R : realType. +Import KCOMP_FINITE_KERNEL. -Lemma measurable_eq_cst (f : R.-ker T ~> T') k : - measurable [set t | f t setT == k]. +Lemma mkcomp_sfinite : exists k_ : (R.-fker X ~> Z)^nat, forall x U, measurable U -> + (l \; k) x U = kseries k_ x U. Proof. -rewrite [X in measurable X](_ : _ = (f ^~ setT) @^-1` [set k]); last first. - by apply/seteqP; split => t/= /eqP. -have /(_ measurableT [set k]) := measurable_kernel f setT measurableT. -by rewrite setTI; exact. +have [k_ hk_] := sfinite k; have [l_ hl_] := sfinite l. +have [kl hkl] : exists kl : (R.-fker X ~> Z) ^nat, forall x U, + \esum_(i in setT) (l_ i.2 \; k_ i.1) x U = \sum_(i [the _.-fker _ ~> _ of l_ (f i).2 \; k_ (f i).1]) => x U. + by rewrite (reindex_esum [set: nat] _ f)// nneseries_esum// fun_true. +exists kl => x U mU. +transitivity (([the _.-ker _ ~> _ of kseries l_] \; + [the _.-ker _ ~> _ of kseries k_]) x U). + rewrite /= /kcomp [in RHS](eq_measure_integral (l x)); last first. + by move=> *; rewrite hl_. + by apply: eq_integral => y _; rewrite hk_. +rewrite /= /kcomp/= integral_sum//=; last first. + by move=> n; have /measurable_fun_prod1 := measurable_kernel (k_ n) _ mU; exact. +transitivity (\sum_(i i _; rewrite integral_kseries//. + by have /measurable_fun_prod1 := measurable_kernel (k_ i) _ mU; exact. +rewrite /mseries -hkl/=. +rewrite (_ : setT = setT `*`` (fun=> setT)); last by apply/seteqP; split. +rewrite -(@esum_esum _ _ _ _ _ (fun i j => (l_ j \; k_ i) x U))//. +rewrite nneseries_esum; last by move=> n _; exact: nneseries_ge0. +by rewrite fun_true; apply: eq_esum => /= i _; rewrite nneseries_esum// fun_true. Qed. -Lemma measurable_neq_cst (f : R.-ker T ~> T') k : - measurable [set t | f t setT != k]. +Lemma measurable_fun_mkcomp_sfinite U : measurable U -> + measurable_fun setT ((l \; k) ^~ U). Proof. -rewrite [X in measurable X](_ : _ = (f ^~ setT) @^-1` [set~ k]); last first. - by apply/seteqP; split => t /eqP. -have /(_ measurableT [set~ k]) := measurable_kernel f setT measurableT. -by rewrite setTI; apply => //; exact: measurableC. +move=> mU; apply: (measurable_fun_integral_sfinite_kernel _ (k ^~ U)) => //. +exact/measurable_kernel. Qed. -End kernel_measurable_preimage. +End kcomp_sfinite_kernel. -Lemma measurable_fun_eq_cst (d d' : _) (T : measurableType d) - (T' : measurableType d') (R : realType) (f : R.-ker T ~> T') k : - measurable_fun setT (fun t => f t setT == k). -Proof. -move=> _ /= B mB; rewrite setTI. -have [/eqP->|/eqP->|/eqP->|/eqP->] := set_boolE B. -- exact: measurable_eq_cst. -- rewrite (_ : _ @^-1` _ = [set b | f b setT != k]); last first. - by apply/seteqP; split => [t /negbT//|t /negbTE]. - exact: measurable_neq_cst. -- by rewrite preimage_set0. -- by rewrite preimage_setT. -Qed. +Module KCOMP_SFINITE_KERNEL. +Section kcomp_sfinite_kernel. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : R.-sfker X ~> Y. +Variable k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. -Section mnormalize. -Variables (d d' : _) (T : measurableType d) (Y : measurableType d'). -Variables (R : realType) (f : T -> {measure set Y -> \bar R}). -Variable P : probability Y R. +HB.instance Definition _ := + isKernel.Build _ _ X Z R (l \; k) (measurable_fun_mkcomp_sfinite l k). -Definition mnormalize t U := - let evidence := f t setT in - if (evidence == 0) || (evidence == +oo) then P U - else f t U * (fine evidence)^-1%:E. +#[export] +HB.instance Definition _ := + isSFinite.Build _ _ X Z R (l \; k) (mkcomp_sfinite l k). -Let mnormalize0 t : mnormalize t set0 = 0. -Proof. -by rewrite /mnormalize; case: ifPn => // _; rewrite measure0 mul0e. -Qed. +End kcomp_sfinite_kernel. +End KCOMP_SFINITE_KERNEL. +HB.export KCOMP_SFINITE_KERNEL. -Let mnormalize_ge0 t U : 0 <= mnormalize t U. -Proof. by rewrite /mnormalize; case: ifPn => //; case: ifPn. Qed. +(* pollard? *) +Section measurable_fun_integral_kernel'. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d') + (R : realType). +Variables (l : X -> {measure set Y -> \bar R}) + (k : Y -> \bar R) + (k_ : ({nnsfun Y >-> R}) ^nat) + (ndk_ : nondecreasing_seq (k_ : (Y -> R)^nat)) + (k_k : forall z, setT z -> EFin \o (k_ ^~ z) --> k z). + +Let p : (X * Y -> R)^nat := fun n xy => k_ n xy.2. + +Let p_ge0 n x : (0 <= p n x)%R. Proof. by []. Qed. + +HB.instance Definition _ n := @IsNonNegFun.Build _ R (p n) (p_ge0 n). -Lemma mnormalize_sigma_additive t : semi_sigma_additive (mnormalize t). +Let mp n : measurable_fun setT (p n). Proof. -move=> F mF tF mUF; rewrite /mnormalize/=. -case: ifPn => [_|_]. - exact: measure_semi_sigma_additive. -rewrite (_ : (fun n => _) = ((fun n => \sum_(0 <= i < n) f t (F i)) \* - cst ((fine (f t setT))^-1)%:E)); last first. - by apply/funext => n; rewrite -ge0_sume_distrl. -by apply: ereal_cvgMr => //; exact: measure_semi_sigma_additive. +rewrite /p => _ /= B mB; rewrite setTI. +have mk_n : measurable_fun setT (k_ n) by []. +rewrite (_ : _ @^-1` _ = setT `*` (k_ n @^-1` B)); last first. + by apply/seteqP; split => xy /=; tauto. +apply: measurableM => //. +have := mk_n measurableT _ mB. +by rewrite setTI. Qed. -HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ (mnormalize t) - (mnormalize0 t) (mnormalize_ge0 t) (@mnormalize_sigma_additive t). +HB.instance Definition _ n := @IsMeasurableFun.Build _ _ R (p n) (mp n). -Lemma mnormalize1 t : mnormalize t setT = 1. +Let fp n : finite_set (range (p n)). Proof. -rewrite /mnormalize; case: ifPn; first by rewrite probability_setT. -rewrite negb_or => /andP[ft0 ftoo]. -have ? : f t setT \is a fin_num. - by rewrite ge0_fin_numE// lt_neqAle ftoo/= leey. -by rewrite -{1}(@fineK _ (f t setT))// -EFinM divrr// ?unitfE fine_eq0. +have := @fimfunP _ _ (k_ n). +suff : range (k_ n) = range (p n) by move=> <-. +by apply/seteqP; split => r [y ?] <-; [exists (point, y)|exists y.2]. Qed. -HB.instance Definition _ t := - isProbability.Build _ _ _ (mnormalize t) (mnormalize1 t). +HB.instance Definition _ n := @FiniteImage.Build _ _ (p n) (fp n). -End mnormalize. +Lemma measurable_fun_preimage_integral : + (forall n r, measurable_fun setT (fun x => l x (k_ n @^-1` [set r]))) -> + measurable_fun setT (fun x => \int[l x]_z k z). +Proof. +move=> h. +apply: (measurable_fun_xsection_integral l (fun xy => k xy.2) + (fun n => [the {nnsfun _ >-> _} of p n])) => /=. +- by rewrite /p => m n mn; apply/lefP => -[x y] /=; exact/lefP/ndk_. +- by move=> [x y]; exact: k_k. +- move=> n r _ /= B mB. + have := h n r measurableT B mB. + rewrite !setTI. + suff : ((fun x => l x (k_ n @^-1` [set r])) @^-1` B) = + ((fun x => l x (xsection (p n @^-1` [set r]) x)) @^-1` B) by move=> ->. + apply/seteqP; split => x/=. + suff : (k_ n @^-1` [set r]) = (xsection (p n @^-1` [set r]) x) by move=> ->. + by apply/seteqP; split; move=> y/=; + rewrite /xsection/= /p /preimage/= inE/=. + suff : (k_ n @^-1` [set r]) = (xsection (p n @^-1` [set r]) x) by move=> ->. + by apply/seteqP; split; move=> y/=; rewrite /xsection/= /p /preimage/= inE/=. +Qed. -Section knormalize. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (f : R.-ker X ~> Y). +End measurable_fun_integral_kernel'. -Definition knormalize (P : probability Y R) := - fun t => [the measure _ _ of mnormalize f P t]. +Lemma measurable_fun_integral_kernel + (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) + (l : R.-ker [the measurableType _ of (X * Y)%type] ~> Z) c + (k : Z -> \bar R) (k0 : forall z, True -> 0 <= k z) (mk : measurable_fun setT k) : + measurable_fun setT (fun y => \int[l (c, y)]_z k z). +Proof. +have [k_ [ndk_ k_k]] := approximation measurableT mk k0. +apply: (measurable_fun_preimage_integral ndk_ k_k) => n r. +have := measurable_kernel l (k_ n @^-1` [set r]) (measurable_sfunP (k_ n) r). +by move=> /measurable_fun_prod1; exact. +Qed. -Variable P : probability Y R. +Section integral_kcomp. -Let measurable_fun_knormalize U : - measurable U -> measurable_fun setT (knormalize P ^~ U). +Let integral_kcomp_indic d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) + x (E : set _) (mE : measurable E) : + \int[(l \; k) x]_z (\1_E z)%:E = \int[l x]_y (\int[k (x, y)]_z (\1_E z)%:E). Proof. -move=> mU; rewrite /knormalize/= /mnormalize /=. -rewrite (_ : (fun _ => _) = (fun x => - if f x setT == 0 then P U else if f x setT == +oo then P U - else f x U * ((fine (f x setT))^-1)%:E)); last first. - apply/funext => x; case: ifPn => [/orP[->//|->]|]. - by case: ifPn. - by rewrite negb_or=> /andP[/negbTE -> /negbTE ->]. -apply: measurable_fun_if => //. -- exact: measurable_fun_eq_cst. -- exact: measurable_fun_cst. -- apply: measurable_fun_if => //. - + rewrite setTI [X in measurable X](_ : _ = [set t | f t setT != 0]); last first. - by apply/seteqP; split => [x /negbT//|x /negbTE]. - exact: measurable_neq_cst. - + exact: measurable_fun_eq_cst. - + exact: measurable_fun_cst. - + apply: emeasurable_funM. - by have := measurable_kernel f U mU; exact: measurable_funS. - apply/EFin_measurable_fun. - apply: (measurable_fun_comp' (F := [set r : R | r != 0%R])) => //. - * exact: open_measurable. - * move=> /= r [t] [] [_ H1] H2 H3. - apply/eqP => H4; subst r. - move/eqP : H4. - rewrite fine_eq0 ?H1//. - rewrite ge0_fin_numE//. - by rewrite lt_neqAle leey H2. - * apply: open_continuous_measurable_fun => //. - apply/in_setP => x /= x0. - by apply: inv_continuous. - * apply: measurable_fun_comp => /=. - exact: measurable_fun_fine. - by have := measurable_kernel f _ measurableT; exact: measurable_funS. +rewrite integral_indic//= /kcomp. +by apply eq_integral => y _; rewrite integral_indic. Qed. -HB.instance Definition _ := isKernel.Build _ _ _ _ R (knormalize P) - measurable_fun_knormalize. - -Let knormalize1 x : knormalize P x setT = 1. +Let integral_kcomp_nnsfun d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) + x (f : {nnsfun Z >-> R}) : + \int[(l \; k) x]_z (f z)%:E = \int[l x]_y (\int[k (x, y)]_z (f z)%:E). Proof. -rewrite /knormalize/= /mnormalize. -case: ifPn => [_|]; first by rewrite probability_setT. -rewrite negb_or => /andP[fx0 fxoo]. -have ? : f x setT \is a fin_num by rewrite ge0_fin_numE// lt_neqAle fxoo/= leey. -rewrite -{1}(@fineK _ (f x setT))//=. -by rewrite -EFinM divrr// ?lte_fin ?ltr1n// ?unitfE fine_eq0. +under [in LHS]eq_integral do rewrite fimfunE -sumEFin. +rewrite ge0_integral_sum//; last 2 first. + move=> r; apply/EFin_measurable_fun/measurable_funrM. + have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). + by move=> r z _; rewrite EFinM nnfun_muleindic_ge0. +under [in RHS]eq_integral. + move=> y _. + under eq_integral. + move=> z _. + rewrite fimfunE -sumEFin. + over. + rewrite /= ge0_integral_sum//; last 2 first. + move=> r; apply/EFin_measurable_fun/measurable_funrM. + have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). + by move=> r z _; rewrite EFinM nnfun_muleindic_ge0. + under eq_bigr. + move=> r _. + rewrite (@integralM_indic _ _ _ _ _ _ (fun r => f @^-1` [set r]))//; last first. + by move=> r0; rewrite preimage_nnfun0. + rewrite integral_indic// setIT. + over. + over. +rewrite /= ge0_integral_sum//; last 2 first. + - move=> r; apply: measurable_funeM. + have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). + by move=> /measurable_fun_prod1; exact. + - move=> n y _. + have := @mulemu_ge0 _ _ _ (k (x, y)) n (fun n => f @^-1` [set n]). + by apply; exact: preimage_nnfun0. +apply eq_bigr => r _. +rewrite (@integralM_indic _ _ _ _ _ _ (fun r => f @^-1` [set r]))//; last first. + exact: preimage_nnfun0. +rewrite /= integral_kcomp_indic; last exact/measurable_sfunP. +rewrite (@integralM_0ifneg _ _ _ _ _ _ (fun r t => k (x, t) (f @^-1` [set r])))//; last 2 first. + move=> r0. + apply/funext => y. + by rewrite preimage_nnfun0// measure0. + have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). + by move/measurable_fun_prod1; exact. +congr (_ * _); apply eq_integral => y _. +by rewrite integral_indic// setIT. Qed. -HB.instance Definition _ := - @isProbabilityKernel.Build _ _ _ _ _ (knormalize P) knormalize1. +Lemma integral_kcomp d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) + x f : (forall z, 0 <= f z) -> measurable_fun setT f -> + \int[(l \; k) x]_z f z = \int[l x]_y (\int[k (x, y)]_z f z). +Proof. +move=> f0 mf. +have [f_ [ndf_ f_f]] := approximation measurableT mf (fun z _ => f0 z). +transitivity (\int[(l \; k) x]_z (lim (EFin \o (f_^~ z)))). + apply/eq_integral => z _. + apply/esym/cvg_lim => //=. + exact: f_f. +rewrite monotone_convergence//; last 3 first. + by move=> n; apply/EFin_measurable_fun. + by move=> n z _; rewrite lee_fin. + by move=> z _ a b /ndf_ /lefP ab; rewrite lee_fin. +rewrite (_ : (fun _ => _) = (fun n => \int[l x]_y (\int[k (x, y)]_z (f_ n z)%:E)))//; last first. + by apply/funext => n; rewrite integral_kcomp_nnsfun. +transitivity (\int[l x]_y lim (fun n => \int[k (x, y)]_z (f_ n z)%:E)). + rewrite -monotone_convergence//; last 3 first. + move=> n. + apply: measurable_fun_integral_kernel => //. + - by move=> z; rewrite lee_fin. + - by apply/EFin_measurable_fun. + - move=> n y _. + by apply integral_ge0 => // z _; rewrite lee_fin. + - move=> y _ a b ab. + apply: ge0_le_integral => //. + + by move=> z _; rewrite lee_fin. + + exact/EFin_measurable_fun. + + by move=> z _; rewrite lee_fin. + + exact/EFin_measurable_fun. + + move: ab => /ndf_ /lefP ab z _. + by rewrite lee_fin. +apply eq_integral => y _. +rewrite -monotone_convergence//; last 3 first. + move=> n; exact/EFin_measurable_fun. + by move=> n z _; rewrite lee_fin. + by move=> z _ a b /ndf_ /lefP; rewrite lee_fin. +apply eq_integral => z _. +apply/cvg_lim => //. +exact: f_f. +Qed. -End knormalize. +End integral_kcomp. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 0de50bd9db..708c5780d9 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -15,7 +15,7 @@ Require Import lebesgue_measure fsbigop numfun lebesgue_integral kernel. (* 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, *) +(* pnormalize 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 *) @@ -408,11 +408,14 @@ Definition ret (f : X -> Y) (mf : measurable_fun setT f) := locked [the R.-sfker X ~> Y of kdirac mf]. Definition sample (P : probability Y R) := - locked [the R.-sfker X ~> Y of kprobability P] . + locked [the R.-pker X ~> Y of kprobability P] . -Definition normalize (k : R.-sfker X ~> Y) P := +Definition pnormalize (k : R.-sfker X ~> Y) P := locked [the R.-pker X ~> Y of knormalize k P]. +Definition dnormalize t (k : R.-sfker X ~> Y) P := + locked [the probability _ _ of mnormalize k P t]. + Definition ite (f : X -> bool) (mf : measurable_fun setT f) (k1 k2 : R.-sfker X ~> Y):= locked [the R.-sfker X ~> Y of kite k1 k2 mf]. @@ -431,12 +434,20 @@ Proof. by rewrite [in LHS]/ret; unlock. Qed. Lemma sampleE (P : probability Y R) (x : X) : sample P x = P. Proof. by rewrite [in LHS]/sample; unlock. Qed. -Lemma normalizeE (f : R.-sfker X ~> Y) P x U : - normalize f P x U = +Lemma pnormalizeE (f : R.-sfker X ~> Y) P x U : + pnormalize f P x U = + if (f x [set: Y] == 0) || (f x [set: Y] == +oo) then P U + else f x U * ((fine (f x [set: Y]))^-1)%:E. +Proof. +by rewrite /pnormalize; unlock => /=; rewrite /mnormalize; case: ifPn. +Qed. + +Lemma dnormalizeE (f : R.-sfker X ~> Y) P x U : + dnormalize x f P U = if (f x [set: Y] == 0) || (f x [set: Y] == +oo) then P U else f x U * ((fine (f x [set: Y]))^-1)%:E. Proof. -by rewrite /normalize; unlock => /=; rewrite /mnormalize; case: ifPn. +by rewrite /dnormalize; unlock => /=; rewrite /mnormalize; case: ifPn. Qed. Lemma iteE (f : X -> bool) (mf : measurable_fun setT f) @@ -563,8 +574,10 @@ by rewrite ger0_norm// ?f0//= muleC. Qed. (* example of property *) -Lemma score_score (f : R -> R) (g : R * unit -> R) (mf : measurable_fun setT f) (mg : measurable_fun setT g) x U : - letin (score mf) (score mg) x U = if U == set0 then 0 else `|g (x, tt)|%:E * `|f x|%:E. +Lemma score_score (f : R -> R) (g : R * unit -> R) (mf : measurable_fun setT f) + (mg : measurable_fun setT g) x U : + letin (score mf) (score mg) x U = + if U == set0 then 0 else `|f x|%:E * `|g (x, tt)|%:E. Proof. rewrite {1}/letin. unlock. @@ -572,7 +585,7 @@ rewrite scoreE'//=. rewrite /mscale/= diracE !normr_id. have [->|->]:= set_unit U. by rewrite eqxx in_set0 mule0 mul0e. -by rewrite in_setT mule1 (negbTE (setT0 _)). +by rewrite in_setT mule1 (negbTE (setT0 _)) muleC. Qed. End insn1_lemmas. @@ -765,7 +778,7 @@ Variable P : probability mbool R. Import Notations. Definition staton_bus_annotated : R.-pker T ~> mbool := - normalize (letin + pnormalize (letin (sample (bernoulli p27) : _.-sfker T ~> mbool) (letin (letin @@ -810,7 +823,7 @@ rewrite -!muleA; congr (_ * _ + _ * _). by rewrite scoreE// => r r0; exact: poisson_ge0. Qed. -Definition staton_bus : R.-pker T ~> mbool := normalize staton_bus' P. +Definition staton_bus : R.-pker T ~> mbool := pnormalize staton_bus' P. Lemma staton_busE t U : let N := ((2 / 7%:R) * poisson 3%:R 4 + @@ -820,7 +833,7 @@ Lemma staton_busE t U : (5%:R / 7%:R)%:E * (poisson 10%:R 4)%:E * \d_false U) * N^-1%:E. Proof. rewrite /staton_bus. -rewrite normalizeE /=. +rewrite pnormalizeE /=. rewrite !staton_bus'E. rewrite diracE mem_set// mule1. rewrite diracE mem_set// mule1. @@ -829,71 +842,117 @@ apply/negbTE. by rewrite gt_eqF// lte_fin addr_gt0// mulr_gt0//= poisson_gt0. Qed. -End staton_bus. +Definition dstaton_bus (t : T) : probability mbool R := dnormalize t staton_bus' P. -(* wip *) +Lemma dstaton_busE t U : + let N := ((2 / 7%:R) * poisson 3%:R 4 + + (5%:R / 7%:R) * poisson 10%:R 4)%R in + dstaton_bus t U = + ((2 / 7%:R)%:E * (poisson 3%:R 4)%:E * \d_true U + + (5%:R / 7%:R)%:E * (poisson 10%:R 4)%:E * \d_false U) * N^-1%:E. +Proof. +rewrite /staton_bus. +rewrite dnormalizeE /=. +rewrite !staton_bus'E. +rewrite diracE mem_set// mule1. +rewrite diracE mem_set// mule1. +rewrite ifF //. +apply/negbTE. +by rewrite gt_eqF// lte_fin addr_gt0// mulr_gt0//= poisson_gt0. +Qed. -Section letinC. +End staton_bus. + +(* TODO: move *) +Section measurable_fun_pair. +Variables (d d' d3 : _) (X : measurableType d) + (Y : measurableType d') (Z : measurableType d3). -Variables (d d' d3 d4 : _) (R : realType) (X : measurableType d) - (Y : measurableType d') (Z : measurableType d3) (U : measurableType d4). +Lemma measurable_fun_pair (f : X -> Y) (g : X -> Z) : + measurable_fun setT f -> + measurable_fun setT g -> + measurable_fun setT (fun x => (f x, g x)). +Proof. +by move=> mf mg; apply/prod_measurable_funP. +Qed. -Let f (xyz : unit * X * X) := (xyz.1.2, xyz.2). +End measurable_fun_pair. -Lemma mf : measurable_fun setT f. +(* TODO: move *) +Lemma finite_kernel_measure (d d' : _) (X : measurableType d) + (Y : measurableType d') (R : realType) (k : R.-fker X ~> Y) (x : X) : + finite_measure (k x). Proof. -rewrite /=. -apply/prod_measurable_funP => /=; split. - rewrite /f. - rewrite (_ : _ \o _ = (fun xyz : unit * X * X => xyz.1.2))//. - apply: measurable_fun_comp => /=. - exact: measurable_fun_snd. - exact: measurable_fun_fst. -rewrite (_ : _ \o _ = (fun xyz : unit * X * X => xyz.2))//. -apply: measurable_fun_comp => /=. - exact: measurable_fun_snd. -exact: measurable_fun_id. +have [r k_r] := measure_uub k. +by rewrite /finite_measure (@lt_trans _ _ r%:E) ?ltey. Qed. -Let f' := @swap _ _ \o f. -Lemma mf' : measurable_fun setT f'. +Lemma sfinite_kernel_measure (d d' : _) (X : measurableType d) + (Y : measurableType d') (R : realType) (k : R.-sfker X ~> Y) (x : X) : + sfinite_measure (k x). Proof. -rewrite /=. -apply: measurable_fun_comp => /=. - exact: measurable_fun_swap. -exact: mf. +have [k_ k_E] := sfinite k. +exists (fun n => k_ n x); split; last by move=> A mA; rewrite k_E. +by move=> n; exact: finite_kernel_measure. Qed. -Variables (t : R.-sfker Datatypes_unit__canonical__measure_Measurable ~> X) - (t' : R.-sfker [the measurableType _ of (unit * X)%type] ~> X) - (u : R.-sfker Datatypes_unit__canonical__measure_Measurable ~> X) - (u' : R.-sfker [the measurableType _ of (unit * X)%type] ~> X) - (H1 : forall y, u tt = u' (tt, y)) - (H2 : forall y, t tt = t' (tt, y)). +Section letinC. +Variables (d d1 : _) (X : measurableType d) (Y : measurableType d1). +Variables (R : realType) (d' : _) (Z : measurableType d'). + +Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) + (@measurable_fun_fst _ _ _ _)). +Notation var3_of3 := (@measurable_fun_snd _ _ _ _). -Lemma letinC x A : measurable A -> - letin t (letin u' (ret R mf)) x A = letin u (letin t' (ret R mf')) x A. +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)). + +Lemma letinC z A : measurable A -> + letin t + (letin u' + (ret R (measurable_fun_pair var2_of3 var3_of3))) z A = + letin u + (letin t' + (ret R (measurable_fun_pair var3_of3 var2_of3))) z A. Proof. move=> mA. rewrite !letinE. -destruct x. -rewrite /f/=. under eq_integral. move=> x _. - rewrite letinE/=. - rewrite -H1. + rewrite letinE/= -uu'. under eq_integral do rewrite retE /=. over. -rewrite /=. -rewrite (@sfinite_fubini _ _ X X R t u (fun x => \d_(x.1, x.2) A ))//=. -apply eq_integral => x _. - rewrite letinE/=. - rewrite -H2. - apply eq_integral => // x' _. - by rewrite retE. -apply/EFin_measurable_fun => /=. -rewrite (_ : (fun x => _) = mindic R mA)//. -by apply/funext => -[a b] /=. +rewrite (sfinite_fubini _ _ (fun x => \d_(x.1, x.2) A ))//; last 3 first. + exact: sfinite_kernel_measure. + exact: sfinite_kernel_measure. + apply/EFin_measurable_fun => /=; rewrite (_ : (fun x => _) = mindic R mA)//. + by apply/funext => -[]. +apply eq_integral => y _. +by rewrite letinE/= -tt'; apply eq_integral => // x _; rewrite retE. Qed. End letinC. + +Section dist_salgebra_instance. +Variables (d : measure_display) (T : measurableType d) (R : realType). +Variables p0 : probability T R. + +Definition prob_pointed := Pointed.Class + (Choice.Class gen_eqMixin (Choice.Class gen_eqMixin gen_choiceMixin)) p0. + +Canonical probability_eqType := EqType (probability T R) prob_pointed. +Canonical probability_choiceType := ChoiceType (probability T R) prob_pointed. +Canonical probability_ptType := PointedType (probability T R) prob_pointed. + +Definition mset (U : set T) (r : R) := [set mu : probability T R | mu U < r%:E]. + +Definition pset : set (set (probability T R)) := + [set mset U r | r in `[0%R,1%R]%classic & U in @measurable d T]. + +Definition sset := [the measurableType pset.-sigma of salgebraType pset]. + +End dist_salgebra_instance. From f6db52cc3b30b0a41caee78c310749a24f3ca2e9 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Tue, 13 Sep 2022 19:44:41 +0900 Subject: [PATCH 16/54] staton bus with exp --- theories/kernel.v | 378 ++++++++++++++-------------- theories/prob_lang.v | 574 ++++++++++++++++++++----------------------- 2 files changed, 471 insertions(+), 481 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 646cc75c79..08083a9df4 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -9,15 +9,15 @@ Require Import lebesgue_measure fsbigop numfun lebesgue_integral. (* Kernels *) (* *) (* This file provides a formation of kernels and extends the theory of *) -(* measure with, e.g., Fubini's theorem for s-finite measures. *) +(* measures with, e.g., Tonelli-Fubini's theorem for s-finite measures. *) (* *) +(* finite_measure mu == the measure mu is finite *) +(* sfinite_measure mu == the measure mu is s-finite *) (* R.-ker X ~> Y == kernel *) (* kseries == countable sum of kernels *) -(* R.-sfker X ~> Y == s-finite kernel *) (* R.-fker X ~> Y == finite kernel *) +(* R.-sfker X ~> Y == s-finite kernel *) (* R.-pker X ~> Y == probability kernel *) -(* finite_measure mu == the measure mu is finite *) -(* sfinite_measure mu == the measure my is s-finite *) (* kprobability m == kernel defined by a probability measure *) (* kdirac mf == kernel defined by a measurable function *) (* kadd k1 k2 == lifting of the addition of measures to kernels *) @@ -57,31 +57,41 @@ Qed. End probability_lemmas. (* /PR 516 in progress *) -(* TODO: PR? *) -Section integralM_0ifneg. -Local Open Scope ereal_scope. -Variables (d : _) (T : measurableType d) (R : realType). -Variables (m : {measure set T -> \bar R}) (D : set T) (mD : measurable D). +(* TODO: PR *) +Lemma setT0 (T : pointedType) : setT != set0 :> set T. +Proof. by apply/eqP => /seteqP[] /(_ point) /(_ Logic.I). Qed. -Lemma integralM_0ifneg (f : R -> T -> \bar R) (k : R) - (f0 : forall r t, D t -> 0 <= f r t) : - ((k < 0)%R -> f k = cst 0%E) -> measurable_fun setT (f k) -> - \int[m]_(x in D) (k%:E * (f k) x) = k%:E * \int[m]_(x in D) ((f k) x). +Lemma set_unit (A : set unit) : A = set0 \/ A = setT. Proof. -move=> fk0 mfk; have [k0|k0] := ltP k 0%R. - rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0; last first. - by move=> x _; rewrite fk0// mule0. - rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0// => x _. - by rewrite fk0// indic0. -rewrite ge0_integralM//. -- by apply/(@measurable_funS _ _ _ _ setT) => //. -- by move=> y Dy; rewrite f0. +have [->|/set0P[[] Att]] := eqVneq A set0; [by left|right]. +by apply/seteqP; split => [|] []. Qed. -End integralM_0ifneg. -Arguments integralM_0ifneg {d T R} m {D} mD f. +Lemma set_boolE (B : set bool) : [\/ B == [set true], B == [set false], B == set0 | B == setT]. +Proof. +have [Bt|Bt] := boolP (true \in B). + have [Bf|Bf] := boolP (false \in B). + have -> : B = setT. + by apply/seteqP; split => // -[] _; [rewrite inE in Bt| rewrite inE in Bf]. + by apply/or4P; rewrite eqxx/= !orbT. + have -> : B = [set true]. + apply/seteqP; split => -[]//=. + by rewrite notin_set in Bf. + by rewrite inE in Bt. + by apply/or4P; rewrite eqxx. +have [Bf|Bf] := boolP (false \in B). + have -> : B = [set false]. + apply/seteqP; split => -[]//=. + by rewrite notin_set in Bt. + by rewrite inE in Bf. + by apply/or4P; rewrite eqxx/= orbT. +have -> : B = set0. + apply/seteqP; split => -[]//=. + by rewrite notin_set in Bt. + by rewrite notin_set in Bf. +by apply/or4P; rewrite eqxx/= !orbT. +Qed. -(* TODO: PR *) Canonical unit_pointedType := PointedType unit tt. Section discrete_measurable_unit. @@ -126,7 +136,22 @@ HB.instance Definition _ := @isMeasurable.Build default_measure_display bool End discrete_measurable_bool. -(* TODO: PR *) +Lemma measurable_curry (T1 T2 : Type) (d : _) (T : semiRingOfSetsType d) + (G : T1 * T2 -> set T) (x : T1 * T2) : + measurable (G x) <-> measurable (curry G x.1 x.2). +Proof. by case: x. Qed. + +Lemma emeasurable_itv (R : realType) (i : nat) : + measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set \bar R). +Proof. +rewrite -[X in measurable X]setCK. +apply: measurableC. +rewrite set_interval.setCitv /=. +apply: measurableU. + exact: emeasurable_itv_ninfty_bnd. +exact: emeasurable_itv_bnd_pinfty. +Qed. + Lemma measurable_fun_fst (d1 d2 : _) (T1 : measurableType d1) (T2 : measurableType d2) : measurable_fun setT (@fst T1 T2). Proof. @@ -141,10 +166,25 @@ have := @measurable_fun_id _ [the measurableType _ of (T1 * T2)%type] setT. by move=> /prod_measurable_funP[]. Qed. -Lemma measurable_curry (T1 T2 : Type) (d : _) (T : semiRingOfSetsType d) - (G : T1 * T2 -> set T) (x : T1 * T2) : - measurable (G x) <-> measurable (curry G x.1 x.2). -Proof. by case: x. Qed. +Definition swap (T1 T2 : Type) (x : T1 * T2) := (x.2, x.1). + +Lemma measurable_fun_swap d d' (X : measurableType d) (Y : measurableType d') : + measurable_fun [set: X * Y] (@swap X Y). +Proof. +by apply/prod_measurable_funP => /=; split; + [exact: measurable_fun_snd|exact: measurable_fun_fst]. +Qed. + +Section measurable_fun_pair. +Variables (d d2 d3 : _) (X : measurableType d) (Y : measurableType d2) + (Z : measurableType d3). + +Lemma measurable_fun_pair (f : X -> Y) (g : X -> Z) : + measurable_fun setT f -> measurable_fun setT g -> + measurable_fun setT (fun x => (f x, g x)). +Proof. by move=> mf mg; apply/prod_measurable_funP. Qed. + +End measurable_fun_pair. Section measurable_fun_comp. Variables (d1 d2 d3 : measure_display). @@ -152,7 +192,7 @@ Variables (T1 : measurableType d1). Variables (T2 : measurableType d2). Variables (T3 : measurableType d3). -(* NB: this generalizes MathComp's measurable_fun_comp' *) +(* NB: this generalizes MathComp-Analysis' measurable_fun_comp *) Lemma measurable_fun_comp' F (f : T2 -> T3) E (g : T1 -> T2) : measurable F -> g @` E `<=` F -> @@ -168,37 +208,6 @@ Qed. End measurable_fun_comp. -Lemma set_unit (A : set unit) : A = set0 \/ A = setT. -Proof. -have [->|/set0P[[] Att]] := eqVneq A set0; [by left|right]. -by apply/seteqP; split => [|] []. -Qed. - -Lemma set_boolE (B : set bool) : [\/ B == [set true], B == [set false], B == set0 | B == setT]. -Proof. -have [Bt|Bt] := boolP (true \in B). - have [Bf|Bf] := boolP (false \in B). - have -> : B = setT. - by apply/seteqP; split => // -[] _; [rewrite inE in Bt| rewrite inE in Bf]. - by apply/or4P; rewrite eqxx/= !orbT. - have -> : B = [set true]. - apply/seteqP; split => -[]//=. - by rewrite notin_set in Bf. - by rewrite inE in Bt. - by apply/or4P; rewrite eqxx. -have [Bf|Bf] := boolP (false \in B). - have -> : B = [set false]. - apply/seteqP; split => -[]//=. - by rewrite notin_set in Bt. - by rewrite inE in Bf. - by apply/or4P; rewrite eqxx/= orbT. -have -> : B = set0. - apply/seteqP; split => -[]//=. - by rewrite notin_set in Bt. - by rewrite notin_set in Bf. -by apply/or4P; rewrite eqxx/= !orbT. -Qed. - Lemma measurable_fun_if (d d' : _) (T : measurableType d) (T' : measurableType d') (x y : T -> T') D (md : measurable D) (f : T -> bool) (mf : measurable_fun setT f) : @@ -253,18 +262,36 @@ have {}my : measurable_fun [set: T * bool] (y \o fst). by apply: measurable_fun_ifT => //=; exact: measurable_fun_snd. Qed. -Lemma emeasurable_itv (R : realType) (i : nat) : - measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set \bar R). +Lemma measurable_fun_opp (R : realType) : measurable_fun [set: R] -%R. Proof. -rewrite -[X in measurable X]setCK. -apply: measurableC. -rewrite set_interval.setCitv /=. -apply: measurableU. - exact: emeasurable_itv_ninfty_bnd. -exact: emeasurable_itv_bnd_pinfty. +apply: continuous_measurable_fun. +by have := (@opp_continuous R [the normedModType R of R^o]). Qed. -Section fubini_tonelli. (* TODO: move to lebesgue_integral.v *) +Section integralM_0ifneg. +Local Open Scope ereal_scope. +Variables (d : _) (T : measurableType d) (R : realType). +Variables (m : {measure set T -> \bar R}) (D : set T) (mD : measurable D). + +Lemma integralM_0ifneg (f : R -> T -> \bar R) (k : R) + (f0 : forall r t, D t -> 0 <= f r t) : + ((k < 0)%R -> f k = cst 0%E) -> measurable_fun setT (f k) -> + \int[m]_(x in D) (k%:E * (f k) x) = k%:E * \int[m]_(x in D) ((f k) x). +Proof. +move=> fk0 mfk; have [k0|k0] := ltP k 0%R. + rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0; last first. + by move=> x _; rewrite fk0// mule0. + rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0// => x _. + by rewrite fk0// indic0. +rewrite ge0_integralM//. +- by apply/(@measurable_funS _ _ _ _ setT) => //. +- by move=> y Dy; rewrite f0. +Qed. + +End integralM_0ifneg. +Arguments integralM_0ifneg {d T R} m {D} mD f. + +Section fubini_tonelli. Local Open Scope ereal_scope. Variables (d1 d2 : measure_display). Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). @@ -278,7 +305,87 @@ Lemma fubini_tonelli : Proof. by rewrite -fubini_tonelli1// fubini_tonelli2. Qed. End fubini_tonelli. -(*/ PR*) +(* /TODO: PR *) + +Definition finite_measure d (T : measurableType d) (R : realType) + (mu : set T -> \bar R) := + mu setT < +oo. + +Definition sfinite_measure d (T : measurableType d) (R : realType) + (mu : set T -> \bar R) := + exists mu_ : {measure set T -> \bar R}^nat, + (forall n, finite_measure (mu_ n)) /\ + (forall U, measurable U -> mu U = mseries mu_ 0 U). + +Lemma finite_measure_sigma_finite d (T : measurableType d) (R : realType) + (mu : {measure set T -> \bar R}) : + finite_measure mu -> sigma_finite setT mu. +Proof. +exists (fun i => if i \in [set 0%N] then setT else set0). + by rewrite -bigcup_mkcondr setTI bigcup_const//; exists 0%N. +move=> n; split; first by case: ifPn. +by case: ifPn => // _; rewrite ?measure0//; exact: finite_measure. +Qed. + +Section sfinite_fubini. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). +Variables (m1 : {measure set X -> \bar R}) (sfm1 : sfinite_measure m1). +Variables (m2 : {measure set Y -> \bar R}) (sfm2 : sfinite_measure m2). +Variables (f : X * Y -> \bar R) (f0 : forall xy, 0 <= f xy). +Variable (mf : measurable_fun setT f). + +Lemma sfinite_fubini : + \int[m1]_x \int[m2]_y f (x, y) = \int[m2]_y \int[m1]_x f (x, y). +Proof. +have [m1_ [fm1 m1E]] := sfm1. +have [m2_ [fm2 m2E]] := sfm2. +rewrite [LHS](eq_measure_integral [the measure _ _ of mseries m1_ 0]); last first. + by move=> A mA _; rewrite m1E. +transitivity (\int[[the measure _ _ of mseries m1_ 0]]_x + \int[[the measure _ _ of mseries m2_ 0]]_y f (x, y)). + by apply eq_integral => x _; apply: eq_measure_integral => U mA _; rewrite m2E. +transitivity (\sum_(n t _; exact: integral_ge0. + rewrite [X in measurable_fun _ X](_ : _ = + fun x => \sum_(n x. + by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. + apply: ge0_emeasurable_fun_sum; first by move=> k x; exact: integral_ge0. + move=> k; apply: measurable_fun_fubini_tonelli_F => //=. + exact: finite_measure_sigma_finite. + apply: eq_nneseries => n _; apply eq_integral => x _. + by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. +transitivity (\sum_(n n _. + rewrite integral_sum//. + move=> m; apply: measurable_fun_fubini_tonelli_F => //=. + exact: finite_measure_sigma_finite. + by move=> m x _; exact: integral_ge0. +transitivity (\sum_(n n _; apply eq_nneseries => m _. + by rewrite fubini_tonelli//; exact: finite_measure_sigma_finite. +transitivity (\sum_(n n _ /=. rewrite ge0_integral_measure_series//. + by move=> y _; exact: integral_ge0. + apply: measurable_fun_fubini_tonelli_G => //=. + by apply: finite_measure_sigma_finite; exact: fm1. +transitivity (\int[[the measure _ _ of mseries m2_ 0]]_y \sum_(n n; apply: measurable_fun_fubini_tonelli_G => //=. + by apply: finite_measure_sigma_finite; exact: fm1. + by move=> n y _; exact: integral_ge0. +transitivity (\int[[the measure _ _ of mseries m2_ 0]]_y + \int[[the measure _ _ of mseries m1_ 0]]_x f (x, y)). + apply eq_integral => y _. + by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod2. +transitivity (\int[m2]_y \int[mseries m1_ 0]_x f (x, y)). + by apply eq_measure_integral => A mA _ /=; rewrite m2E. +by apply eq_integral => y _; apply eq_measure_integral => A mA _ /=; rewrite m1E. +Qed. + +End sfinite_fubini. +Arguments sfinite_fubini {d d' X Y R m1} _ {m2} _ f. Reserved Notation "R .-ker X ~> Y" (at level 42, format "R .-ker X ~> Y"). Reserved Notation "R .-fker X ~> Y" (at level 42, format "R .-fker X ~> Y"). @@ -459,6 +566,23 @@ HB.instance Definition _ := @isProbabilityFam.Build _ _ _ _ _ _ is_probability_k HB.end. +Lemma finite_kernel_measure (d d' : _) (X : measurableType d) + (Y : measurableType d') (R : realType) (k : R.-fker X ~> Y) (x : X) : + finite_measure (k x). +Proof. +have [r k_r] := measure_uub k. +by rewrite /finite_measure (@lt_trans _ _ r%:E) ?ltey. +Qed. + +Lemma sfinite_kernel_measure (d d' : _) (X : measurableType d) + (Y : measurableType d') (R : realType) (k : R.-sfker X ~> Y) (x : X) : + sfinite_measure (k x). +Proof. +have [k_ k_E] := sfinite k. +exists (fun n => k_ n x); split; last by move=> A mA; rewrite k_E. +by move=> n; exact: finite_kernel_measure. +Qed. + (* see measurable_prod_subset in lebesgue_integral.v; the differences between the two are: - m2 is a kernel instead of a measure (the proof uses the @@ -542,7 +666,7 @@ Qed. End measurable_fun_xsection_finite_kernel. -(* pollard *) +(* pollard? *) Section measurable_fun_integral_finite_sfinite. Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). @@ -576,11 +700,11 @@ rewrite (_ : (fun x => _) = - by move=> y _ m n mn; rewrite lee_fin; exact/lefP/ndk_. apply: measurable_fun_elim_sup => n. rewrite [X in measurable_fun _ X](_ : _ = (fun x => \int[l x]_y - (\sum_(r <- fset_set (range (k_ n)))(*TODO: upd when the PR is merged*) + (\sum_(r <- fset_set (range (k_ n)))(*TODO: upd when the PR 743 is merged*) r * \1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. rewrite [X in measurable_fun _ X](_ : _ = (fun x => - \sum_(r <- fset_set (range (k_ n)))(*TODO: upd when the PR is merged*) + \sum_(r <- fset_set (range (k_ n)))(*TODO: upd when the PR 743 is merged*) (\int[l x]_y (r * \1_(k_ n @^-1` [set r]) (x, y))%:E))); last first. apply/funext => x; rewrite -ge0_integral_sum//. - by apply: eq_integral => y _; rewrite sumEFin. @@ -642,113 +766,11 @@ Arguments measurable_fun_xsection_integral {_ _ _ _ _} l k. Arguments measurable_fun_integral_finite_kernel {_ _ _ _ _} l k. Arguments measurable_fun_integral_sfinite_kernel {_ _ _ _ _} l k. -(*HB.mixin Record isFiniteMeasure d (R : numFieldType) (T : semiRingOfSetsType d) - (mu : set T -> \bar R) := { - finite_measure : mu setT < +oo -}. - -#[short(type=fmeasure)] -HB.structure Definition FiniteMeasure d (R : realFieldType) - (T : semiRingOfSetsType d) := - {mu of isMeasure d R T mu & isFiniteMeasure d R T mu}. - -Notation "{ 'fmeasure' 'set' T '->' '\bar' R }" := (@fmeasure _ R T) - (at level 36, T, R at next level, - format "{ 'fmeasure' 'set' T '->' '\bar' R }") : ring_scope.*) - -Definition finite_measure d (T : measurableType d) (R : realType) - (mu : set T -> \bar R) := - mu setT < +oo. - -Definition sfinite_measure d (T : measurableType d) (R : realType) - (mu : set T -> \bar R) := - exists mu_ : {measure set T -> \bar R}^nat, - (forall n, finite_measure (mu_ n)) /\ - (forall U, measurable U -> mu U = mseries mu_ 0 U). - -Lemma finite_measure_sigma_finite d (T : measurableType d) (R : realType) - (mu : {measure set T -> \bar R}) : - finite_measure mu -> sigma_finite setT mu. -Proof. -exists (fun i => if i \in [set 0%N] then setT else set0). - by rewrite -bigcup_mkcondr setTI bigcup_const//; exists 0%N. -move=> n; split; first by case: ifPn. -by case: ifPn => // _; rewrite ?measure0//; exact: finite_measure. -Qed. - -Section sfinite_fubini. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). -Variables (m1 : {measure set X -> \bar R}) (sfm1 : sfinite_measure m1). -Variables (m2 : {measure set Y -> \bar R}) (sfm2 : sfinite_measure m2). -Variables (f : X * Y -> \bar R) (f0 : forall xy, 0 <= f xy). -Variable (mf : measurable_fun setT f). - -Lemma sfinite_fubini : - \int[m1]_x \int[m2]_y f (x, y) = \int[m2]_y \int[m1]_x f (x, y). -Proof. -have [m1_ [fm1 m1E]] := sfm1. -have [m2_ [fm2 m2E]] := sfm2. -rewrite [LHS](eq_measure_integral [the measure _ _ of mseries m1_ 0]); last first. - by move=> A mA _; rewrite m1E. -transitivity (\int[[the measure _ _ of mseries m1_ 0]]_x - \int[[the measure _ _ of mseries m2_ 0]]_y f (x, y)). - by apply eq_integral => x _; apply: eq_measure_integral => U mA _; rewrite m2E. -transitivity (\sum_(n t _; exact: integral_ge0. - rewrite [X in measurable_fun _ X](_ : _ = - fun x => \sum_(n x. - by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. - apply: ge0_emeasurable_fun_sum; first by move=> k x; exact: integral_ge0. - move=> k; apply: measurable_fun_fubini_tonelli_F => //=. - exact: finite_measure_sigma_finite. - apply: eq_nneseries => n _; apply eq_integral => x _. - by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. -transitivity (\sum_(n n _. - rewrite integral_sum(*TODO: rename to ge0_integral_sum*)//. - move=> m; apply: measurable_fun_fubini_tonelli_F => //=. - exact: finite_measure_sigma_finite. - by move=> m x _; exact: integral_ge0. -transitivity (\sum_(n n _; apply eq_nneseries => m _. - by rewrite fubini_tonelli//; exact: finite_measure_sigma_finite. -transitivity (\sum_(n n _ /=. rewrite ge0_integral_measure_series//. - by move=> y _; exact: integral_ge0. - apply: measurable_fun_fubini_tonelli_G => //=. - by apply: finite_measure_sigma_finite; exact: fm1. -transitivity (\int[[the measure _ _ of mseries m2_ 0]]_y \sum_(n n; apply: measurable_fun_fubini_tonelli_G => //=. - by apply: finite_measure_sigma_finite; exact: fm1. - by move=> n y _; exact: integral_ge0. -transitivity (\int[[the measure _ _ of mseries m2_ 0]]_y - \int[[the measure _ _ of mseries m1_ 0]]_x f (x, y)). - apply eq_integral => y _. - by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod2. -transitivity (\int[m2]_y \int[mseries m1_ 0]_x f (x, y)). - by apply eq_measure_integral => A mA _ /=; rewrite m2E. -by apply eq_integral => y _; apply eq_measure_integral => A mA _ /=; rewrite m1E. -Qed. - -End sfinite_fubini. -Arguments sfinite_fubini {d d' X Y R m1} _ {m2} _ f. - -Lemma finite_kernel_finite_measure d (T : measurableType d) (R : realType) - (mu : R.-fker Datatypes_unit__canonical__measure_Measurable ~> T) : - mu tt setT < +oo. -Proof. -have [M muM] := measure_uub mu. -by rewrite /finite_measure (lt_le_trans (muM tt))// leey. -Qed. - Section kprobability. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (m : probability Y R). +Variables (R : realType) (P : probability Y R). -Definition kprobability : X -> {measure set Y -> \bar R} := fun _ : X => m. +Definition kprobability : X -> {measure set Y -> \bar R} := fun=> P. Let measurable_fun_kprobability U : measurable U -> measurable_fun setT (kprobability ^~ U). diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 708c5780d9..3a6579a012 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -1,13 +1,16 @@ From HB Require Import structures. From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval finmap. +From mathcomp Require Import rat. Require Import mathcomp_extra boolp classical_sets signed functions cardinality. Require Import reals ereal topology normedtype sequences esum measure. -Require Import lebesgue_measure fsbigop numfun lebesgue_integral kernel. +Require Import lebesgue_measure fsbigop numfun lebesgue_integral exp kernel. +Require Import exp. (******************************************************************************) (* Semantics of a programming language PPL using s-finite kernels *) (* *) -(* bernoulli r1 == Bernoulli probability *) +(* bernoulli r1 == Bernoulli probability with r1 a proof that *) +(* r : {nonneg R} is smaller than 1 *) (* *) (* sample P == sample according to the probability P *) (* letin l k == execute l, augment the context, and execute k *) @@ -20,6 +23,10 @@ Require Import lebesgue_measure fsbigop numfun lebesgue_integral kernel. (* 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 *) +(* *) (******************************************************************************) Set Implicit Arguments. @@ -33,18 +40,6 @@ Local Open Scope ring_scope. Local Open Scope ereal_scope. (* TODO: PR *) -Lemma setT0 (T1 : pointedType) : setT != set0 :> set T1. -Proof. by apply/eqP => /seteqP[] /(_ point) /(_ Logic.I). Qed. - -Definition swap (T1 T2 : Type) (x : T1 * T2) := (x.2, x.1). - -Lemma measurable_fun_swap d d' (X : measurableType d) (Y : measurableType d') : - measurable_fun [set: X * Y] (@swap X Y). -Proof. -by apply/prod_measurable_funP => /=; split; - [exact: measurable_fun_snd|exact: measurable_fun_fst]. -Qed. - Lemma onem1' (R : numDomainType) (p : R) : (p + `1- p = 1)%R. Proof. by rewrite /onem addrCA subrr addr0. Qed. @@ -55,6 +50,10 @@ 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). +Lemma expR_ge0 (R : realType) (x : R) : (0 <= expR x)%R. +Proof. by rewrite ltW// expR_gt0. Qed. +(* /TODO: PR *) + Section bernoulli. Variables (R : realType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R). Local Open Scope ring_scope. @@ -212,8 +211,8 @@ Variable (mr : measurable_fun setT r). Let measurable_fun_kscore U : measurable U -> measurable_fun setT (kscore mr ^~ U). Proof. by move=> /= _; exact: measurable_fun_mscore. Qed. -HB.instance Definition _ := isKernel.Build _ _ T _ - (*Datatypes_unit__canonical__measure_Measurable*) R (kscore mr) measurable_fun_kscore. +HB.instance Definition _ := isKernel.Build _ _ T _ R + (kscore mr) measurable_fun_kscore. Import SCORE. @@ -376,19 +375,19 @@ Definition mite (mf : measurable_fun setT f) : T -> set T' -> \bar R := Variables mf : measurable_fun setT f. -Let mite0 tb : mite mf tb set0 = 0. +Let mite0 t : mite mf t set0 = 0. Proof. by rewrite /mite; case: ifPn => //. Qed. -Let mite_ge0 tb (U : set _) : 0 <= mite mf tb U. +Let mite_ge0 t (U : set _) : 0 <= mite mf t U. Proof. by rewrite /mite; case: ifPn => //. Qed. -Let mite_sigma_additive tb : semi_sigma_additive (mite mf tb). +Let mite_sigma_additive t : semi_sigma_additive (mite mf t). Proof. -by rewrite /mite; case: ifPn => ftb; exact: measure_semi_sigma_additive. +by rewrite /mite; case: ifPn => ft; exact: measure_semi_sigma_additive. Qed. -HB.instance Definition _ tb := isMeasure.Build _ _ _ (mite mf tb) - (mite0 tb) (mite_ge0 tb) (@mite_sigma_additive tb). +HB.instance Definition _ t := isMeasure.Build _ _ _ (mite mf t) + (mite0 t) (mite_ge0 t) (@mite_sigma_additive t). Import ITE. @@ -400,6 +399,27 @@ Definition kite := End ite. +(* wip *) +Section dist_salgebra_instance. +Variables (d : measure_display) (T : measurableType d) (R : realType). +Variables p0 : probability T R. + +Definition prob_pointed := Pointed.Class + (Choice.Class gen_eqMixin (Choice.Class gen_eqMixin gen_choiceMixin)) p0. + +Canonical probability_eqType := EqType (probability T R) prob_pointed. +Canonical probability_choiceType := ChoiceType (probability T R) prob_pointed. +Canonical probability_ptType := PointedType (probability T R) prob_pointed. + +Definition mset (U : set T) (r : R) := [set mu : probability T R | mu U < r%:E]. + +Definition pset : set (set (probability T R)) := + [set mset U r | r in `[0%R,1%R]%classic & U in @measurable d T]. + +Definition sset := [the measurableType pset.-sigma of salgebraType pset]. + +End dist_salgebra_instance. + Section insn2. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). Variable R : realType. @@ -410,17 +430,15 @@ Definition ret (f : X -> Y) (mf : measurable_fun setT f) := Definition sample (P : probability Y R) := locked [the R.-pker X ~> Y of kprobability P] . -Definition pnormalize (k : R.-sfker X ~> Y) P := - locked [the R.-pker X ~> Y of knormalize k P]. - -Definition dnormalize t (k : R.-sfker X ~> Y) P := - locked [the probability _ _ of mnormalize k P t]. +Definition normalize (k : R.-sfker X ~> Y) P x := + locked [the probability _ _ of mnormalize k P x]. Definition ite (f : X -> bool) (mf : measurable_fun setT f) (k1 k2 : R.-sfker X ~> Y):= locked [the R.-sfker X ~> Y of kite k1 k2 mf]. End insn2. +Arguments ret {d d' X Y R f} mf. Arguments sample {d d' X Y R}. Section insn2_lemmas. @@ -428,26 +446,18 @@ Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). Variable R : realType. Lemma retE (f : X -> Y) (mf : measurable_fun setT f) x : - ret R mf x = \d_(f x) :> (_ -> _). + ret mf x = \d_(f x) :> (_ -> \bar R). Proof. by rewrite [in LHS]/ret; unlock. Qed. Lemma sampleE (P : probability Y R) (x : X) : sample P x = P. Proof. by rewrite [in LHS]/sample; unlock. Qed. -Lemma pnormalizeE (f : R.-sfker X ~> Y) P x U : - pnormalize f P x U = +Lemma normalizeE (f : R.-sfker X ~> Y) P x U : + normalize f P x U = if (f x [set: Y] == 0) || (f x [set: Y] == +oo) then P U else f x U * ((fine (f x [set: Y]))^-1)%:E. Proof. -by rewrite /pnormalize; unlock => /=; rewrite /mnormalize; case: ifPn. -Qed. - -Lemma dnormalizeE (f : R.-sfker X ~> Y) P x U : - dnormalize x f P U = - if (f x [set: Y] == 0) || (f x [set: Y] == +oo) then P U - else f x U * ((fine (f x [set: Y]))^-1)%:E. -Proof. -by rewrite /dnormalize; unlock => /=; rewrite /mnormalize; case: ifPn. +by rewrite /normalize; unlock => /=; rewrite /mnormalize; case: ifPn. Qed. Lemma iteE (f : X -> bool) (mf : measurable_fun setT f) @@ -492,31 +502,30 @@ Proof. by rewrite /letin; unlock. Qed. End insn3_lemmas. -(* a few laws *) - +(* rewriting laws *) Section letin_return. Variables (d d' d3 : _) (R : realType) (X : measurableType d) (Y : measurableType d') (Z : measurableType d3). Lemma letin_kret (k : R.-sfker X ~> Y) - (f : _ -> Z) (mf : measurable_fun setT f) x U : + (f : X * Y -> Z) (mf : measurable_fun setT f) x U : measurable U -> - letin k (ret R mf) x U = k x (curry f x @^-1` U). + letin k (ret mf) x U = k x (curry f x @^-1` U). Proof. -move=> mU. -rewrite letinE. +move=> mU; rewrite letinE. under eq_integral do rewrite retE. rewrite integral_indic ?setIT//. -move/measurable_fun_prod1 : mf => /(_ x)/(_ measurableT U mU). +move/measurable_fun_prod1 : mf => /(_ x measurableT U mU). by rewrite setTI. Qed. -Lemma letin_retk (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) - (f : _ -> Y) (mf : measurable_fun setT f) : - forall x U, measurable U -> letin (ret R mf) k x U = k (x, f x) U. +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 -> + letin (ret mf) k x U = k (x, f x) U. Proof. -move=> x U mU. -rewrite letinE retE integral_dirac//. +move=> mU; rewrite letinE retE integral_dirac//. by rewrite indicE mem_set// mul1e. have /measurable_fun_prod1 := measurable_kernel k _ mU. exact. @@ -532,60 +541,54 @@ Definition score (f : X -> R) (mf : measurable_fun setT f) := End insn1. +Module Notations. + +Notation var1_of2 := (@measurable_fun_fst _ _ _ _). +Notation var2_of2 := (@measurable_fun_snd _ _ _ _). +Notation var1_of3 := (measurable_fun_comp (@measurable_fun_fst _ _ _ _) + (@measurable_fun_fst _ _ _ _)). +Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) + (@measurable_fun_fst _ _ _ _)). +Notation var3_of3 := (@measurable_fun_snd _ _ _ _). + +Notation mR := Real_sort__canonical__measure_Measurable. +Notation munit := Datatypes_unit__canonical__measure_Measurable. +Notation mbool := Datatypes_bool__canonical__measure_Measurable. + +End Notations. + Section insn1_lemmas. +Import Notations. Variables (R : realType) (d : _) (T : measurableType d). -Lemma scoreE' d' (T' : measurableType d') d2 (T2 : measurableType d2) (U : set T') - (g : R.-sfker [the measurableType _ of (T2 * unit)%type] ~> T') r fh (mh : measurable_fun setT fh) : - (score mh \; g) r U = - g (r, tt) U * `|fh r|%:E. -Proof. -rewrite [in LHS]/score [in LHS]/=. -rewrite /kcomp. -rewrite /kscore. -rewrite [in LHS]/=. -rewrite ge0_integral_mscale//=. -rewrite integral_dirac// normr_id muleC. -by rewrite indicE in_setT mul1e. -Qed. - -Lemma scoreE (t : T) (U : set bool) (n : nat) (b : bool) - (f : R -> R) - (f0 : forall r, (0 <= r)%R -> (0 <= f r)%R) - (mf : measurable_fun setT f) : - score (measurable_fun_comp mf (@measurable_fun_snd _ _ _ _)) - (t, b, n%:R) (curry (snd \o fst) (t, b) @^-1` U) = - (f n%:R)%:E * \d_b U. -Proof. -transitivity (letin ( - score (measurable_fun_comp mf (measurable_fun_snd (T2:=Real_sort__canonical__measure_Measurable R))) - ) ( - ret R (@measurable_fun_id _ _ _) -) (t, b, n%:R) (curry (snd \o fst) (t, b) @^-1` U)). - rewrite letin_kret//. - rewrite /curry/=. - rewrite preimage_cst. - by case: ifPn => //. -rewrite /letin. -unlock. -rewrite scoreE'//. -rewrite retE. -by rewrite ger0_norm// ?f0//= muleC. +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//= normr_id. +by rewrite integral_dirac// indicE in_setT mul1e. Qed. -(* example of property *) -Lemma score_score (f : R -> R) (g : R * unit -> R) (mf : measurable_fun setT f) +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 (measurable_fun_comp mf var2_of2) + (x, r) (curry (snd \o fst) x @^-1` U) = + (f r)%:E * \d_x.2 U. +Proof. +by rewrite /score/= /mscale/= normr_id ger0_norm// f0. +Qed. + +Lemma score_score (f : R -> R) (g : R * unit -> R) + (mf : measurable_fun setT f) (mg : measurable_fun setT g) x U : letin (score mf) (score mg) x U = - if U == set0 then 0 else `|f x|%:E * `|g (x, tt)|%:E. + score (measurable_funM mf (measurable_fun_prod2 tt mg)) x U. Proof. rewrite {1}/letin. unlock. -rewrite scoreE'//=. -rewrite /mscale/= diracE !normr_id. -have [->|->]:= set_unit U. - by rewrite eqxx in_set0 mule0 mul0e. -by rewrite in_setT mule1 (negbTE (setT0 _)) muleC. +by rewrite kcomp_scoreE/= /mscale/= diracE !normr_id normrM muleA EFinM. Qed. End insn1_lemmas. @@ -615,6 +618,47 @@ Qed. End letin_ite. +Section letinC. +Variables (d d1 : _) (X : measurableType d) (Y : measurableType d1). +Variables (R : realType) (d' : _) (Z : measurableType d'). + +Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) + (@measurable_fun_fst _ _ _ _)). +Notation var3_of3 := (@measurable_fun_snd _ _ _ _). + +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)). + +Lemma letinC z A : measurable A -> + letin t + (letin u' + (ret (measurable_fun_pair var2_of3 var3_of3))) z A = + letin u + (letin t' + (ret (measurable_fun_pair var3_of3 var2_of3))) 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 _ _ (fun x => \d_(x.1, x.2) A ))//; last 3 first. + exact: sfinite_kernel_measure. + exact: sfinite_kernel_measure. + apply/EFin_measurable_fun => /=; rewrite (_ : (fun x => _) = mindic R mA)//. + by apply/funext => -[]. +apply eq_integral => y _. +by rewrite letinE/= -tt'; apply eq_integral => // x _; rewrite retE. +Qed. + +End letinC. + (* sample programs *) Section constants. @@ -630,39 +674,63 @@ Proof. by rewrite /= lter_pdivr_mulr// mul1r ler_nat. Qed. End constants. Arguments p27 {R}. -Require Import exp. - -Definition poisson (R : realType) (r : R) (k : nat) := (r ^+ k / k%:R^-1 * expR (- r))%R. +Section poisson. +Variable R : realType. +Local Open Scope ring_scope. -Definition poisson3 (R : realType) := poisson (3%:R : R) 4. (* 0.168 *) -Definition poisson10 (R : realType) := poisson (10%:R : R) 4. (* 0.019 *) +(* density function for Poisson *) +Definition poisson k r : R := r ^+ k / k`!%:R^-1 * expR (- r). -Lemma poisson_ge0 (R : realType) (r : R) k : (0 <= r)%R -> (0 <= poisson r k)%R. +Lemma poisson_ge0 k r : 0 <= r -> 0 <= poisson k r. Proof. -move=> r0; rewrite /poisson mulr_ge0//. - by rewrite mulr_ge0// exprn_ge0//. -by rewrite ltW// expR_gt0. +move=> r0; rewrite /poisson mulr_ge0 ?expR_ge0//. +by rewrite mulr_ge0// exprn_ge0. Qed. -Lemma poisson_gt0 (R : realType) (r : R) k : (0 < r)%R -> (0 < poisson r k.+1)%R. +Lemma poisson_gt0 k r : 0 < r -> 0 < poisson k.+1 r. Proof. -move=> r0; rewrite /poisson mulr_gt0//. - by rewrite mulr_gt0// exprn_gt0. -by rewrite expR_gt0. +move=> r0; rewrite /poisson mulr_gt0 ?expR_gt0//. +by rewrite divr_gt0// ?exprn_gt0// invr_gt0 ltr0n fact_gt0. Qed. -Lemma mpoisson (R : realType) k : measurable_fun setT (@poisson R ^~ k). +Lemma mpoisson k : measurable_fun setT (poisson k). Proof. apply: measurable_funM => /=. apply: measurable_funM => //=; last exact: measurable_fun_cst. exact/measurable_fun_exprn/measurable_fun_id. +apply: measurable_fun_comp; last exact: measurable_fun_opp. +by apply: continuous_measurable_fun; exact: continuous_expR. +Qed. + +Definition poisson3 := poisson 4 3. (* 0.168 *) +Definition poisson10 := poisson 4 10. (* 0.019 *) + +End poisson. + +Section exponential. +Variable R : realType. +Local Open Scope ring_scope. + +(* density function for exponential *) +Definition exp_density x r : R := r * expR (- r * x). + +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. + +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. + +Lemma mexp_density x : measurable_fun setT (exp_density x). +Proof. +apply: measurable_funM => /=; first exact: measurable_fun_id. apply: measurable_fun_comp. - apply: continuous_measurable_fun. - exact: continuous_expR. -apply: continuous_measurable_fun. -by have := (@opp_continuous R [the normedModType R of R^o]). + by apply: continuous_measurable_fun; exact: continuous_expR. +apply: measurable_funM => /=; first exact: measurable_fun_opp. +exact: measurable_fun_cst. Qed. +End exponential. + Section cst_fun. Variables (R : realType) (d : _) (T : measurableType d). @@ -674,18 +742,6 @@ End cst_fun. Arguments k3 {R d T}. Arguments k10 {R d T}. -Module Notations. - -Notation var1_of2 := (@measurable_fun_fst _ _ _ _). -Notation var2_of2 := (@measurable_fun_snd _ _ _ _). -Notation var1_of3 := (measurable_fun_comp (@measurable_fun_fst _ _ _ _) - (@measurable_fun_fst _ _ _ _)). -Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) - (@measurable_fun_fst _ _ _ _)). -Notation var3_of3 := (@measurable_fun_snd _ _ _ _). - -End Notations. - Lemma letin_sample_bernoulli (R : realType) (d d' : _) (T : measurableType d) (T' : measurableType d') (r : {nonneg R}) (r1 : (r%:num <= 1)%R) (u : R.-sfker [the measurableType _ of (T * bool)%type] ~> T') x y : @@ -701,17 +757,16 @@ by rewrite indicE in_setT mul1e indicE in_setT mul1e. Qed. Section sample_and_return. -Variables (R : realType) (d : _) (T : measurableType d). - Import Notations. +Variables (R : realType) (d : _) (T : measurableType d). Definition sample_and_return : R.-sfker T ~> _ := letin (sample (bernoulli p27)) (* T -> B *) - (ret R var2_of2) (* T * B -> B *). + (ret var2_of2) (* 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. + (2 / 7)%:E * \d_true U + (5 / 7)%:E * \d_false U. Proof. rewrite /sample_and_return. rewrite letin_sample_bernoulli/=. @@ -721,38 +776,24 @@ Qed. End sample_and_return. -Section sample_and_score. -Variables (R : realType) (d : _) (T : measurableType d). - -Definition sample_and_score : R.-sfker T ~> _ := - letin - (sample (bernoulli p27)) (* T -> B *) - (score (measurable_fun_cst (1%R : R))). - -End sample_and_score. - +(* trivial example *) Section sample_and_branch. +Import Notations. Variables (R : realType) (d : _) (T : measurableType d). (* let x = sample (bernoulli (2/7)) in let r = case x of {(1, _) => return (k3()), (2, _) => return (k10())} in return r *) -Let mR := Real_sort__canonical__measure_Measurable R. - -Import Notations. - Definition sample_and_branch : - R.-sfker T ~> [the measurableType default_measure_display of mR] := + R.-sfker T ~> mR R := letin (sample (bernoulli p27)) (* T -> B *) - (ite var2_of2 - (ret R k3) - (ret R k10)). + (ite var2_of2 (ret k3) (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. rewrite /sample_and_branch letin_sample_bernoulli/=. rewrite !iteE/= !retE. @@ -762,197 +803,124 @@ Qed. End sample_and_branch. Section staton_bus. -Variables (R : realType) (d : _) (T : measurableType d). +Import Notations. +Variables (R : realType) (d : _) (T : measurableType d) (density : R -> R). +Hypothesis mdensity : measurable_fun setT density. +Definition kstaton_bus : R.-sfker T ~> mbool := + letin (sample (bernoulli p27)) + (letin + (letin (ite var2_of2 (ret k3) (ret k10)) + (score (measurable_fun_comp mdensity var3_of3))) + (ret var2_of3)). + +Definition staton_bus := normalize kstaton_bus. + +End staton_bus. (* let x = sample (bernoulli (2/7)) in let r = case x of {(1, _) => return (k3()), (2, _) => return (k10())} in let _ = score (1/4! r^4 e^-r) in return x *) - -Let mR := Real_sort__canonical__measure_Measurable R. -Let munit := Datatypes_unit__canonical__measure_Measurable. -Let mbool := Datatypes_bool__canonical__measure_Measurable. - -Variable P : probability mbool R. - +Section staton_bus_poisson. Import Notations. +Variables (R : realType) (d : _) (T : measurableType d). +Let poisson4 := @poisson R 4%N. +Let mpoisson4 := @mpoisson R 4%N. -Definition staton_bus_annotated : R.-pker T ~> mbool := - pnormalize (letin - (sample (bernoulli p27) : _.-sfker T ~> mbool) - (letin - (letin - (ite var2_of2 - (ret R k3) - (ret R k10) - : _.-sfker [the measurableType _ of (T * bool)%type] ~> mR) - (score (measurable_fun_comp (@mpoisson R 4) var3_of3) - : _.-sfker [the measurableType _ of (T * bool* mR)%type] ~> munit) - : _.-sfker [the measurableType _ of (T * bool)%type] ~> munit) - (ret R var2_of3 - : _.-sfker [the measurableType _ of (T * bool * munit)%type] ~> mbool) - : _.-sfker [the measurableType _ of (T * bool)%type] ~> mbool)) P. - -Let staton_bus' : R.-sfker T ~> _ := - (letin (sample (bernoulli p27)) - (letin - (letin (ite var2_of2 - (ret R k3) - (ret R k10)) - (score (measurable_fun_comp (@mpoisson R 4) var3_of3))) - (ret R var2_of3))). +Definition kstaton_bus_poisson : R.-sfker (mR R) ~> mbool := + kstaton_bus _ mpoisson4. -(* 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 staton_bus'E t U : staton_bus' t U = - (2 / 7%:R)%:E * (poisson 3%:R 4)%:E * \d_true U + - (5%:R / 7%:R)%:E * (poisson 10%:R 4)%:E * \d_false U. +Let kstaton_bus_poissonE t U : kstaton_bus_poisson t U = + (2 / 7)%:E * (poisson4 3)%:E * \d_true U + + (5 / 7)%:E * (poisson4 10)%:E * \d_false U. Proof. -rewrite /staton_bus'. +rewrite /kstaton_bus. rewrite letin_sample_bernoulli. 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_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_ge0. Qed. -Definition staton_bus : R.-pker T ~> mbool := pnormalize staton_bus' P. +(* 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 t U : - let N := ((2 / 7%:R) * poisson 3%:R 4 + - (5%:R / 7%:R) * poisson 10%:R 4)%R in - staton_bus t U = - ((2 / 7%:R)%:E * (poisson 3%:R 4)%:E * \d_true U + - (5%:R / 7%:R)%:E * (poisson 10%:R 4)%:E * \d_false U) * N^-1%:E. +Lemma staton_busE P (t : R) U : + let N := ((2 / 7) * poisson4 3 + + (5 / 7) * poisson4 10)%R in + staton_bus mpoisson4 P t U = + ((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. -rewrite pnormalizeE /=. -rewrite !staton_bus'E. +rewrite normalizeE /=. +rewrite !kstaton_bus_poissonE. rewrite diracE mem_set// mule1. rewrite diracE mem_set// mule1. rewrite ifF //. apply/negbTE. -by rewrite gt_eqF// lte_fin addr_gt0// mulr_gt0//= poisson_gt0. +by rewrite gt_eqF// lte_fin addr_gt0// mulr_gt0//= ?divr_gt0// ?ltr0n// poisson_gt0// ltr0n. Qed. -Definition dstaton_bus (t : T) : probability mbool R := dnormalize t staton_bus' P. +End staton_bus_poisson. -Lemma dstaton_busE t U : - let N := ((2 / 7%:R) * poisson 3%:R 4 + - (5%:R / 7%:R) * poisson 10%:R 4)%R in - dstaton_bus t U = - ((2 / 7%:R)%:E * (poisson 3%:R 4)%:E * \d_true U + - (5%:R / 7%:R)%:E * (poisson 10%:R 4)%:E * \d_false U) * N^-1%:E. -Proof. -rewrite /staton_bus. -rewrite dnormalizeE /=. -rewrite !staton_bus'E. -rewrite diracE mem_set// mule1. -rewrite diracE mem_set// mule1. -rewrite ifF //. -apply/negbTE. -by rewrite gt_eqF// lte_fin addr_gt0// mulr_gt0//= poisson_gt0. -Qed. - -End staton_bus. - -(* TODO: move *) -Section measurable_fun_pair. -Variables (d d' d3 : _) (X : measurableType d) - (Y : measurableType d') (Z : measurableType d3). - -Lemma measurable_fun_pair (f : X -> Y) (g : X -> Z) : - measurable_fun setT f -> - measurable_fun setT g -> - measurable_fun setT (fun x => (f x, g x)). -Proof. -by move=> mf mg; apply/prod_measurable_funP. -Qed. +(* let x = sample (bernoulli (2/7)) in + let r = case x of {(1, _) => return (k3()), (2, _) => return (k10())} in + let _ = score (r e^-(15/60 r)) in + return x *) +Section staton_bus_exponential. +Import Notations. +Variables (R : realType) (d : _) (T : measurableType d). +Let exp1560 := @exp_density R (ratr (15%:Q / 60%:Q)). +Let mexp1560 := @mexp_density R (ratr (15%:Q / 60%:Q)). -End measurable_fun_pair. +(* 15/60 = 0.25 *) -(* TODO: move *) -Lemma finite_kernel_measure (d d' : _) (X : measurableType d) - (Y : measurableType d') (R : realType) (k : R.-fker X ~> Y) (x : X) : - finite_measure (k x). -Proof. -have [r k_r] := measure_uub k. -by rewrite /finite_measure (@lt_trans _ _ r%:E) ?ltey. -Qed. +Definition kstaton_bus_exponential : R.-sfker (mR R) ~> mbool := + kstaton_bus _ mexp1560. -Lemma sfinite_kernel_measure (d d' : _) (X : measurableType d) - (Y : measurableType d') (R : realType) (k : R.-sfker X ~> Y) (x : X) : - sfinite_measure (k x). +Let kstaton_bus_exponentialE t U : kstaton_bus_exponential t U = + (2 / 7)%:E * (exp1560 3)%:E * \d_true U + + (5 / 7)%:E * (exp1560 10)%:E * \d_false U. Proof. -have [k_ k_E] := sfinite k. -exists (fun n => k_ n x); split; last by move=> A mA; rewrite k_E. -by move=> n; exact: finite_kernel_measure. +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. -Section letinC. -Variables (d d1 : _) (X : measurableType d) (Y : measurableType d1). -Variables (R : realType) (d' : _) (Z : measurableType d'). - -Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) - (@measurable_fun_fst _ _ _ _)). -Notation var3_of3 := (@measurable_fun_snd _ _ _ _). - -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)). +(* 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 letinC z A : measurable A -> - letin t - (letin u' - (ret R (measurable_fun_pair var2_of3 var3_of3))) z A = - letin u - (letin t' - (ret R (measurable_fun_pair var3_of3 var2_of3))) z 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. -move=> mA. -rewrite !letinE. -under eq_integral. - move=> x _. - rewrite letinE/= -uu'. - under eq_integral do rewrite retE /=. - over. -rewrite (sfinite_fubini _ _ (fun x => \d_(x.1, x.2) A ))//; last 3 first. - exact: sfinite_kernel_measure. - exact: sfinite_kernel_measure. - apply/EFin_measurable_fun => /=; rewrite (_ : (fun x => _) = mindic R mA)//. - by apply/funext => -[]. -apply eq_integral => y _. -by rewrite letinE/= -tt'; apply eq_integral => // x _; rewrite retE. +rewrite /staton_bus. +rewrite normalizeE /=. +rewrite !kstaton_bus_exponentialE. +rewrite diracE mem_set// mule1. +rewrite diracE mem_set// mule1. +rewrite ifF //. +apply/negbTE. +by rewrite gt_eqF// lte_fin addr_gt0// mulr_gt0//= ?divr_gt0// ?ltr0n// exp_density_gt0 ?ltr0n. Qed. -End letinC. - -Section dist_salgebra_instance. -Variables (d : measure_display) (T : measurableType d) (R : realType). -Variables p0 : probability T R. - -Definition prob_pointed := Pointed.Class - (Choice.Class gen_eqMixin (Choice.Class gen_eqMixin gen_choiceMixin)) p0. - -Canonical probability_eqType := EqType (probability T R) prob_pointed. -Canonical probability_choiceType := ChoiceType (probability T R) prob_pointed. -Canonical probability_ptType := PointedType (probability T R) prob_pointed. - -Definition mset (U : set T) (r : R) := [set mu : probability T R | mu U < r%:E]. - -Definition pset : set (set (probability T R)) := - [set mset U r | r in `[0%R,1%R]%classic & U in @measurable d T]. - -Definition sset := [the measurableType pset.-sigma of salgebraType pset]. - -End dist_salgebra_instance. +End staton_bus_exponential. From ddcaa20e1acf346ac99d03094619dd0d719a16a0 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 14 Sep 2022 12:22:46 +0900 Subject: [PATCH 17/54] wip (gauss) --- _CoqProject | 1 + theories/kernel.v | 96 ++++++++++++++-------------- theories/prob_lang.v | 21 +++--- theories/wip.v | 149 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 207 insertions(+), 60 deletions(-) create mode 100644 theories/wip.v diff --git a/_CoqProject b/_CoqProject index b92567752e..74008d6ef1 100644 --- a/_CoqProject +++ b/_CoqProject @@ -38,6 +38,7 @@ theories/numfun.v theories/lebesgue_integral.v theories/kernel.v theories/prob_lang.v +theories/wip.v theories/summability.v theories/signed.v theories/altreals/xfinmap.v diff --git a/theories/kernel.v b/theories/kernel.v index 08083a9df4..cecc473867 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -313,9 +313,8 @@ Definition finite_measure d (T : measurableType d) (R : realType) Definition sfinite_measure d (T : measurableType d) (R : realType) (mu : set T -> \bar R) := - exists mu_ : {measure set T -> \bar R}^nat, - (forall n, finite_measure (mu_ n)) /\ - (forall U, measurable U -> mu U = mseries mu_ 0 U). + exists2 mu_ : {measure set T -> \bar R}^nat, + forall n, finite_measure (mu_ n) & forall U, measurable U -> mu U = mseries mu_ 0 U. Lemma finite_measure_sigma_finite d (T : measurableType d) (R : realType) (mu : {measure set T -> \bar R}) : @@ -337,8 +336,8 @@ Variable (mf : measurable_fun setT f). Lemma sfinite_fubini : \int[m1]_x \int[m2]_y f (x, y) = \int[m2]_y \int[m1]_x f (x, y). Proof. -have [m1_ [fm1 m1E]] := sfm1. -have [m2_ [fm2 m2E]] := sfm2. +have [m1_ fm1 m1E] := sfm1. +have [m2_ fm2 m2E] := sfm2. rewrite [LHS](eq_measure_integral [the measure _ _ of mseries m1_ 0]); last first. by move=> A mA _; rewrite m1E. transitivity (\int[[the measure _ _ of mseries m1_ 0]]_x @@ -417,7 +416,7 @@ Lemma measurable_fun_kseries (U : set Y) : measurable_fun setT (kseries ^~ U). Proof. move=> mU; rewrite /kseries /= /mseries. -by apply: ge0_emeasurable_fun_sum => // n; apply/measurable_kernel. +by apply: ge0_emeasurable_fun_sum => // n; exact/measurable_kernel. Qed. HB.instance Definition _ := @@ -579,7 +578,7 @@ Lemma sfinite_kernel_measure (d d' : _) (X : measurableType d) sfinite_measure (k x). Proof. have [k_ k_E] := sfinite k. -exists (fun n => k_ n x); split; last by move=> A mA; rewrite k_E. +exists (fun n => k_ n x); last by move=> A mA; rewrite k_E. by move=> n; exact: finite_kernel_measure. Qed. @@ -589,48 +588,51 @@ Qed. measurability of each measure of the family) - as a consequence, m2D_bounded holds for all x *) Section measurable_prod_subset_kernel. -Variables (d1 d2 : _) (T1 : measurableType d1) (T2 : measurableType d2) +Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). -Implicit Types A : set (T1 * T2). +Implicit Types A : set (X * Y). Section xsection_kernel. -Variable (m2 : R.-ker T1 ~> T2) (D : set T2) (mD : measurable D). -Let m2D x := mrestr (m2 x) mD. -HB.instance Definition _ x := Measure.on (m2D x). -Let phi A := fun x => m2D x (xsection A x). -Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. - -Lemma measurable_prod_subset_xsection_kernel - (m2D_bounded : forall x, exists M, forall X, measurable X -> (m2D x X < M%:E)%E) : - measurable `<=` B. +Variable (k : R.-ker X ~> Y) (D : set Y) (mD : measurable D). +Let kD x := mrestr (k x) mD. +HB.instance Definition _ x := Measure.on (kD x). +Let phi A := fun x => kD x (xsection A x). +Let XY := [set A | measurable A /\ measurable_fun setT (phi A)]. + +Let phiM (A : set X) B : phi (A `*` B) = (fun x => kD x B * (\1_A x)%:E). +Proof. +rewrite funeqE => x; rewrite indicE /phi/=. +have [xA|xA] := boolP (x \in A); first by rewrite mule1 in_xsectionM. +by rewrite mule0 notin_xsectionM// set0I measure0. +Qed. + +Lemma measurable_prod_subset_xsection_kernel : + (forall x, exists M, forall X, measurable X -> kD x X < M%:E) -> + measurable `<=` XY. Proof. -rewrite measurable_prod_measurableType. -set C := [set A1 `*` A2 | A1 in measurable & A2 in measurable]. +move=> kD_ub; rewrite measurable_prod_measurableType. +set C := [set A `*` B | A in measurable & B in measurable]. have CI : setI_closed C. - move=> X Y [X1 mX1 [X2 mX2 <-{X}]] [Y1 mY1 [Y2 mY2 <-{Y}]]. + move=> _ _ [X1 mX1 [X2 mX2 <-]] [Y1 mY1 [Y2 mY2 <-]]. exists (X1 `&` Y1); first exact: measurableI. by exists (X2 `&` Y2); [exact: measurableI|rewrite setMI]. have CT : C setT by exists setT => //; exists setT => //; rewrite setMTT. -have CB : C `<=` B. - move=> X [X1 mX1 [X2 mX2 <-{X}]]; split; first exact: measurableM. - have -> : phi (X1 `*` X2) = (fun x => m2D x X2 * (\1_X1 x)%:E)%E. - rewrite funeqE => x; rewrite indicE /phi /m2/= /mrestr. - have [xX1|xX1] := boolP (x \in X1); first by rewrite mule1 in_xsectionM. - by rewrite mule0 notin_xsectionM// set0I measure0. +have CXY : C `<=` XY. + move=> _ [A mA [B mB <-]]; split; first exact: measurableM. + rewrite phiM. apply: emeasurable_funM => //; first exact/measurable_kernel/measurableI. - apply/EFin_measurable_fun. - by rewrite (_ : \1_ _ = mindic R mX1). -suff monoB : monotone_class setT B by exact: monotone_class_subset. -split => //; [exact: CB| |exact: xsection_ndseq_closed]. -move=> X Y XY [mX mphiX] [mY mphiY]; split; first exact: measurableD. -suff : phi (X `\` Y) = (fun x => phi X x - phi Y x)%E. + by apply/EFin_measurable_fun; rewrite (_ : \1_ _ = mindic R mA). +suff monoB : monotone_class setT XY by exact: monotone_class_subset. +split => //; [exact: CXY| |exact: xsection_ndseq_closed]. +move=> A B BA [mA mphiA] [mB mphiB]; split; first exact: measurableD. +suff : phi (A `\` B) = (fun x => phi A x - phi B x). by move=> ->; exact: emeasurable_funB. -rewrite funeqE => x; rewrite /phi/= xsectionD// /m2D measureD. +rewrite funeqE => x; rewrite /phi/= xsectionD// measureD. - by rewrite setIidr//; exact: le_xsection. - exact: measurable_xsection. - exact: measurable_xsection. -- move: (m2D_bounded x) => [M m2M]. - rewrite (lt_le_trans (m2M (xsection X x) _))// ?leey//. +- have [M kM] := kD_ub x. + rewrite (lt_le_trans (kM (xsection A x) _)) ?leey//. exact: measurable_xsection. Qed. @@ -642,26 +644,24 @@ End measurable_prod_subset_kernel. the difference is that this section uses a finite kernel m2 instead of a sigma-finite measure m2 *) Section measurable_fun_xsection_finite_kernel. -Variables (d1 d2 : _) (T1 : measurableType d1) (T2 : measurableType d2) +Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). -Variable m2 : R.-fker T1 ~> T2. -Implicit Types A : set (T1 * T2). +Variable k : R.-fker X ~> Y. +Implicit Types A : set (X * Y). -Let phi A := fun x => m2 x (xsection A x). -Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. +Let phi A := fun x => k x (xsection A x). +Let XY := [set A | measurable A /\ measurable_fun setT (phi A)]. Lemma measurable_fun_xsection_finite_kernel A : A \in measurable -> measurable_fun setT (phi A). Proof. -move: A; suff : measurable `<=` B by move=> + A; rewrite inE => /[apply] -[]. -move=> /= X mX; rewrite /B/=; split => //; rewrite /phi. -rewrite -(_ : (fun x => mrestr (m2 x) measurableT (xsection X x)) = - (fun x => m2 x (xsection X x)))//; last first. +move: A; suff : measurable `<=` XY by move=> + A; rewrite inE => /[apply] -[]. +move=> /= A mA; rewrite /XY/=; split => //; rewrite (_ : phi _ = + (fun x => mrestr (k x) measurableT (xsection A x))); last first. by apply/funext => x//=; rewrite /mrestr setIT. apply measurable_prod_subset_xsection_kernel => // x. -have [r hr] := measure_uub m2; exists r => Y mY. -rewrite (le_lt_trans _ (hr x)) // /mrestr /= setIT. -by apply: le_measure => //; rewrite inE. +have [r hr] := measure_uub k; exists r => B mB. +by rewrite (le_lt_trans _ (hr x)) // /mrestr /= setIT le_measure// inE. Qed. End measurable_fun_xsection_finite_kernel. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 3a6579a012..2bc2e68b11 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -4,7 +4,6 @@ From mathcomp Require Import rat. Require Import mathcomp_extra boolp classical_sets signed functions cardinality. Require Import reals ereal topology normedtype sequences esum measure. Require Import lebesgue_measure fsbigop numfun lebesgue_integral exp kernel. -Require Import exp. (******************************************************************************) (* Semantics of a programming language PPL using s-finite kernels *) @@ -32,7 +31,7 @@ Require Import exp. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Import Order.TTheory GRing.Theory Num.Def Num.Theory. +Import Order.TTheory GRing.Theory Num.Def Num.ExtraDef Num.Theory. Import numFieldTopology.Exports. Local Open Scope classical_set_scope. @@ -84,14 +83,14 @@ Variables (d : _) (T : measurableType d). Variables (R : realType) (f : T -> R). Definition mscore t : {measure set _ -> \bar R} := - let p := NngNum (@normr_ge0 _ _ (`| f t |)%R) in + let p := NngNum (normr_ge0 (f t)) in [the measure _ _ of mscale p [the measure _ _ of dirac tt]]. Lemma mscoreE t U : mscore t U = if U == set0 then 0 else `| (f t)%:E |. Proof. rewrite /mscore/= /mscale/=; have [->|->] := set_unit U. by rewrite eqxx diracE in_set0 mule0. -by rewrite diracE in_setT mule1 (negbTE (setT0 _)) normr_id. +by rewrite diracE in_setT mule1 (negbTE (setT0 _)). Qed. Lemma measurable_fun_mscore U : measurable_fun setT f -> @@ -566,7 +565,7 @@ Let kcomp_scoreE d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) 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//= normr_id. +rewrite /= /kcomp /kscore /= ge0_integral_mscale//=. by rewrite integral_dirac// indicE in_setT mul1e. Qed. @@ -576,9 +575,7 @@ Lemma scoreE d' (T' : measurableType d') (x : T * T') (U : set T') (f : R -> R) score (measurable_fun_comp mf var2_of2) (x, r) (curry (snd \o fst) x @^-1` U) = (f r)%:E * \d_x.2 U. -Proof. -by rewrite /score/= /mscale/= normr_id ger0_norm// f0. -Qed. +Proof. by rewrite /score/= /mscale/= ger0_norm// f0. Qed. Lemma score_score (f : R -> R) (g : R * unit -> R) (mf : measurable_fun setT f) @@ -588,7 +585,7 @@ Lemma score_score (f : R -> R) (g : R * unit -> R) Proof. rewrite {1}/letin. unlock. -by rewrite kcomp_scoreE/= /mscale/= diracE !normr_id normrM muleA EFinM. +by rewrite kcomp_scoreE/= /mscale/= diracE normrM muleA EFinM. Qed. End insn1_lemmas. @@ -804,13 +801,13 @@ End sample_and_branch. Section staton_bus. Import Notations. -Variables (R : realType) (d : _) (T : measurableType d) (density : R -> R). -Hypothesis mdensity : measurable_fun setT density. +Variables (R : realType) (d : _) (T : measurableType d) (h : R -> R). +Hypothesis mh : measurable_fun setT h. Definition kstaton_bus : R.-sfker T ~> mbool := letin (sample (bernoulli p27)) (letin (letin (ite var2_of2 (ret k3) (ret k10)) - (score (measurable_fun_comp mdensity var3_of3))) + (score (measurable_fun_comp mh var3_of3))) (ret var2_of3)). Definition staton_bus := normalize kstaton_bus. diff --git a/theories/wip.v b/theories/wip.v new file mode 100644 index 0000000000..334697b692 --- /dev/null +++ b/theories/wip.v @@ -0,0 +1,149 @@ +From HB Require Import structures. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval finmap. +From mathcomp Require Import rat. +Require Import mathcomp_extra boolp classical_sets signed functions cardinality. +Require Import reals ereal topology normedtype sequences esum measure. +Require Import lebesgue_measure fsbigop numfun lebesgue_integral exp kernel. +Require Import trigo prob_lang. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. +Import Order.TTheory GRing.Theory Num.Def Num.ExtraDef Num.Theory. +Import numFieldTopology.Exports. + +Local Open Scope classical_set_scope. +Local Open Scope ring_scope. +Local Open Scope ereal_scope. + +Section gauss. +Variable R : realType. +Local Open Scope ring_scope. + +(* density function for gauss *) +Definition gauss_density 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. +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. +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 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. + +Definition mgauss01 (V : set R) := + \int[lebesgue_measure]_(x in V) (gauss01_density x)%:E. + +Lemma integral_gauss01_density : + \int[lebesgue_measure]_x (gauss01_density x)%:E = 1%E. +Proof. +Admitted. + +Lemma measurable_fun_gauss_density m s : + measurable_fun setT (gauss_density m s). +Proof. +apply: measurable_funM; first exact: measurable_fun_cst. +apply: measurable_fun_comp => /=. + by apply: continuous_measurable_fun; apply continuous_expR. +apply: measurable_funM; last exact: measurable_fun_cst. +apply: measurable_fun_comp => /=; first exact: measurable_fun_opp. +apply: measurable_fun_exprn. +apply: measurable_funM => /=; last exact: measurable_fun_cst. +apply: measurable_funD => //; first exact: measurable_fun_id. +exact: measurable_fun_cst. +Qed. + +Let mgauss010 : mgauss01 set0 = 0%E. +Proof. by rewrite /mgauss01 integral_set0. Qed. + +Let mgauss01_ge0 A : (0 <= mgauss01 A)%E. +Proof. +by rewrite /mgauss01 integral_ge0//= => x _; rewrite lee_fin gauss_density_ge0. +Qed. + +Let mgauss01_sigma_additive : semi_sigma_additive mgauss01. +Proof. +move=> /= F mF tF mUF. +rewrite /mgauss01/= integral_bigcup//=; last first. + 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: le_lt_trans. + apply: (@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. +apply: is_cvg_ereal_nneg_natsum_cond => n _ _. +by apply: integral_ge0 => /= x ?; rewrite lee_fin gauss_density_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. + +HB.instance Definition _ := @isProbability.Build _ _ R mgauss01 mgauss01_setT. + +Definition gauss01 := [the probability _ _ of mgauss01]. + +End gauss. + +Section gauss_lebesgue. +Import Notations. +Variables (R : realType) (d : _) (T : measurableType d). + +Let f1 (x : R) := (gauss01_density x) ^-1. + +Let mf1 : measurable_fun setT f1. +Proof. +apply: (measurable_fun_comp' (F := [set r : R | r != 0%R])) => //. +- exact: open_measurable. +- by move=> /= r [t _ <-]; rewrite gt_eqF// gauss_density_gt0. +- apply: open_continuous_measurable_fun => //. + by apply/in_setP => x /= x0; exact: inv_continuous. +- exact: measurable_fun_gauss_density. +Qed. + +Variable mu : {measure set mR R -> \bar R}. + +Definition staton_lebesgue : R.-sfker T ~> _ := + letin (sample (@gauss01 R)) + (letin + (score (measurable_fun_comp mf1 var2_of2)) + (ret var2_of3)). + +Lemma staton_lebesgueE x U : measurable U -> + staton_lebesgue x U = lebesgue_measure U. +Proof. +move=> mU; rewrite [in LHS]/staton_lebesgue/=. +rewrite [in LHS]letinE. +rewrite [in LHS]/sample. +unlock. +rewrite [in LHS]/=. +transitivity (\int[@mgauss01 R]_(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 integral_dirac// indicE in_setT mul1e retE/= diracE indicE. +transitivity (\int[lebesgue_measure]_(x in U) (gauss01_density x * f1 x)%:E). + admit. +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 integral_indic//= setIid. +Abort. + +End gauss_lebesgue. From f15d4048c52d26363e211ecc4472ae303d33880d Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Fri, 16 Sep 2022 22:34:18 +0900 Subject: [PATCH 18/54] linearize hierarchy --- theories/kernel.v | 275 +++++++++++++++++++++++++++---------------- theories/prob_lang.v | 112 ++++++++++++------ 2 files changed, 250 insertions(+), 137 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index cecc473867..a94d7db6ea 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -208,27 +208,27 @@ Qed. End measurable_fun_comp. -Lemma measurable_fun_if (d d' : _) (T : measurableType d) - (T' : measurableType d') (x y : T -> T') D (md : measurable D) - (f : T -> bool) (mf : measurable_fun setT f) : +Lemma measurable_fun_if (d d' : _) (X : measurableType d) + (Y : measurableType d') (x y : X -> Y) D (md : measurable D) + (f : X -> bool) (mf : measurable_fun setT f) : measurable_fun (D `&` (f @^-1` [set true])) x -> measurable_fun (D `&` (f @^-1` [set false])) y -> measurable_fun D (fun t => if f t then x t else y t). Proof. -move=> mx my /= _ Y mY. +move=> mx my /= _ B mB. have mDf : measurable (D `&` [set b | f b]). apply: measurableI => //. rewrite [X in measurable X](_ : _ = f @^-1` [set true])//. by have := mf measurableT [set true]; rewrite setTI; exact. -have := mx mDf Y mY. +have := mx mDf _ mB. have mDNf : measurable (D `&` f @^-1` [set false]). apply: measurableI => //. by have := mf measurableT [set false]; rewrite setTI; exact. -have := my mDNf Y mY. -move=> yY xY. -rewrite (_ : _ @^-1` Y = - ((f @^-1` [set true]) `&` (x @^-1` Y) `&` (f @^-1` [set true])) `|` - ((f @^-1` [set false]) `&` (y @^-1` Y) `&` (f @^-1` [set false]))); last first. +have := my mDNf _ mB. +move=> yB xB. +rewrite (_ : _ @^-1` B = + ((f @^-1` [set true]) `&` (x @^-1` B) `&` (f @^-1` [set true])) `|` + ((f @^-1` [set false]) `&` (y @^-1` B) `&` (f @^-1` [set false]))); last first. apply/seteqP; split=> [t /=| t]. by case: ifPn => ft; [left|right]. by move=> /= [|]; case: ifPn => ft; case=> -[]. @@ -239,8 +239,8 @@ rewrite setIUr; apply: measurableU. by apply: measurableI => //; rewrite setIA. Qed. -Lemma measurable_fun_ifT (d d' : _) (T : measurableType d) - (T' : measurableType d') (x y : T -> T') (f : T -> bool) +Lemma measurable_fun_ifT (d d' : _) (X : measurableType d) + (Y : measurableType d') (x y : X -> Y) (f : X -> bool) (mf : measurable_fun setT f) : measurable_fun setT x -> measurable_fun setT y -> measurable_fun setT (fun t => if f t then x t else y t). @@ -249,15 +249,15 @@ by move=> mx my; apply: measurable_fun_if => //; [exact: measurable_funS mx|exact: measurable_funS my]. Qed. -Lemma measurable_fun_if_pair (d d' : _) (T : measurableType d) - (T' : measurableType d') (x y : T -> T') : +Lemma measurable_fun_if_pair (d d' : _) (X : measurableType d) + (Y : measurableType d') (x y : X -> Y) : measurable_fun setT x -> measurable_fun setT y -> measurable_fun setT (fun tb => if tb.2 then x tb.1 else y tb.1). Proof. move=> mx my. -have {}mx : measurable_fun [set: T * bool] (x \o fst). +have {}mx : measurable_fun [set: X * bool] (x \o fst). by apply: measurable_fun_comp => //; exact: measurable_fun_fst. -have {}my : measurable_fun [set: T * bool] (y \o fst). +have {}my : measurable_fun [set: X * bool] (y \o fst). by apply: measurable_fun_comp => //; exact: measurable_fun_fst. by apply: measurable_fun_ifT => //=; exact: measurable_fun_snd. Qed. @@ -450,7 +450,22 @@ Qed. End measure_fam_uub. -HB.mixin Record isFiniteFam +HB.mixin Record Kernel_isSFinite_subdef + d d' (X : measurableType d) (Y : measurableType d') + (R : realType) (k : X -> {measure set Y -> \bar R}) := { + sfinite_subdef : exists2 s : (R.-ker X ~> Y)^nat, forall n, measure_fam_uub (s n) & + forall x U, measurable U -> k x U = kseries s x U }. + +#[short(type=sfinite_kernel)] +HB.structure Definition SFiniteKernel + d d' (X : measurableType d) (Y : measurableType d') + (R : realType) := + {k of Kernel_isSFinite_subdef _ _ X Y R k & isKernel d d' X Y R k }. +Notation "R .-sfker X ~> Y" := (sfinite_kernel X Y R). + +Arguments sfinite_subdef {_ _ _ _ _} _. + +HB.mixin Record SFiniteKernel_isFinite d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) := { measure_uub : measure_fam_uub k }. @@ -459,71 +474,128 @@ HB.mixin Record isFiniteFam HB.structure Definition FiniteKernel d d' (X : measurableType d) (Y : measurableType d') (R : realType) := - {k of isFiniteFam _ _ X Y R k & isKernel _ _ X Y R k}. + {k of SFiniteKernel_isFinite _ _ X Y R k & @SFiniteKernel _ _ X Y R k }. Notation "R .-fker X ~> Y" := (finite_kernel X Y R). Arguments measure_uub {_ _ _ _ _} _. -Section kernel_from_mzero. -Variables (d : _) (T : measurableType d) (R : realType). -Variables (d' : _) (T' : measurableType d'). +HB.factory Record Kernel_isFinite d d' (X : measurableType d) + (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) of isKernel _ _ _ _ _ k := { + measure_uub : measure_fam_uub k }. -Definition kernel_from_mzero : T' -> {measure set T -> \bar R} := - fun _ : T' => [the measure _ _ of mzero]. +Section kzero. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variable R : realType. + +Definition kzero : X -> {measure set Y -> \bar R} := + fun _ : X => [the measure _ _ of mzero]. -Lemma kernel_from_mzeroP : forall U, measurable U -> - measurable_fun setT (kernel_from_mzero ^~ U). -Proof. by move=> U mU/=; exact: measurable_fun_cst. Qed. +Let measurable_fun_kzero U : measurable U -> + measurable_fun setT (kzero ^~ U). +Proof. by move=> ?/=; exact: measurable_fun_cst. Qed. HB.instance Definition _ := - @isKernel.Build _ _ T' T R kernel_from_mzero - kernel_from_mzeroP. + @isKernel.Build _ _ X Y R kzero measurable_fun_kzero. -Let kernel_from_mzero_uub : measure_fam_uub kernel_from_mzero. -Proof. by exists 1%R => /= t; rewrite /mzero/=. Qed. +(*Let kernel_from_mzero_sfinite0 : exists2 s : (R.-ker T' ~> T)^nat, forall n, measure_fam_uub (s n) & + forall x U, measurable U -> kernel_from_mzero x U = kseries s x U. +Proof. +exists (fun=> [the _.-ker _ ~> _ of kernel_from_mzero]). + move=> _. + by exists 1%R => y; rewrite /= /mzero. +by move=> t U mU/=; rewrite /mseries nneseries0. +Qed. HB.instance Definition _ := - @isFiniteFam.Build _ _ _ T R kernel_from_mzero - kernel_from_mzero_uub. + @isSFinite0.Build _ _ _ T R kernel_from_mzero + kernel_from_mzero_sfinite0.*) -End kernel_from_mzero. - -HB.mixin Record isSFinite - d d' (X : measurableType d) (Y : measurableType d') - (R : realType) (k : X -> {measure set Y -> \bar R}) := { - sfinite : exists s : (R.-fker X ~> Y)^nat, - forall x U, measurable U -> k x U = kseries s x U }. +Lemma kzero_uub : measure_fam_uub kzero. +Proof. by exists 1%R => /= t; rewrite /mzero/=. Qed. -#[short(type=sfinite_kernel)] -HB.structure Definition SFiniteKernel - d d' (X : measurableType d) (Y : measurableType d') - (R : realType) := - {k of isSFinite _ _ X Y R k & isKernel _ _ X Y _ k}. -Notation "R .-sfker X ~> Y" := (sfinite_kernel X Y R). +(*HB.instance Definition _ := + @SFiniteKernel_isFinite.Build _ _ _ T R kernel_from_mzero + kernel_from_mzero_uub.*) -Arguments sfinite {_ _ _ _ _} _. +End kzero. -(* a finite kernel is always an s-finite kernel *) -Section finite_is_sfinite. -Variables (d d' : _) (X : measurableType d) (T : measurableType d'). -Variables (R : realType) (k : R.-fker T ~> X). +HB.builders Context d d' (X : measurableType d) (Y : measurableType d') + (R : realType) k of Kernel_isFinite d d' X Y R k. Lemma sfinite_finite : - exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> - k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. + exists2 k_ : (R.-ker _ ~> _)^nat, forall n, measure_fam_uub (k_ n) & + forall x U, measurable U -> k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. Proof. -exists (fun n => if n is O then k else - [the finite_kernel _ _ _ of @kernel_from_mzero _ X R _ T]). -move=> t U mU/=. -rewrite /mseries. +exists (fun n => if n is O then [the _.-ker _ ~> _ of k] else + [the _.-ker _ ~> _ of @kzero _ _ X Y R]). + by case => [|_]; [exact: measure_uub|exact: kzero_uub]. +move=> t U mU/=; rewrite /mseries. rewrite (nneseries_split 1%N)// big_ord_recl/= big_ord0 adde0. rewrite ereal_series (@eq_nneseries _ _ (fun=> 0%E)); last by case. by rewrite nneseries0// adde0. Qed. -End finite_is_sfinite. +HB.instance Definition _ := @Kernel_isSFinite_subdef.Build d d' X Y R k sfinite_finite. + +HB.instance Definition _ := @SFiniteKernel_isFinite.Build d d' X Y R k measure_uub. + +HB.end. + +Section sfinite. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k : R.-sfker X ~> Y). + +Let s : (X -> {measure set Y -> \bar R})^nat := + let: exist2 x _ _ := cid2 (sfinite_subdef k) in x. + +Let ms n : @isKernel d d' X Y R (s n). +Proof. +split; rewrite /s; case: cid2 => /= s' s'_uub kE. +exact: measurable_kernel. +Qed. + +HB.instance Definition _ n := ms n. + +Let s_uub n : measure_fam_uub (s n). +Proof. by rewrite /s; case: cid2. Qed. + +HB.instance Definition _ n := + @Kernel_isFinite.Build d d' X Y R (s n) (s_uub n). + +Lemma sfinite : exists s : (R.-fker X ~> Y)^nat, + forall x U, measurable U -> k x U = kseries s x U. +Proof. +exists (fun n => [the _.-fker _ ~> _ of s n]) => x U mU. +by rewrite /s /= /s; by case: cid2 => ? ? ->. +Qed. + +End sfinite. -HB.mixin Record isProbabilityFam +HB.instance Definition _ (d d' : _) (X : measurableType d) + (Y : measurableType d') (R : realType) := + @Kernel_isFinite.Build _ _ _ _ R (@kzero _ _ X Y R) + (@kzero_uub _ _ X Y R). + +HB.factory Record Kernel_isSFinite d d' (X : measurableType d) + (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) + of isKernel _ _ _ _ _ k := { + sfinite : exists s : (R.-fker X ~> Y)^nat, + forall x U, measurable U -> k x U = kseries s x U }. + +HB.builders Context d d' (X : measurableType d) (Y : measurableType d') + (R : realType) k of Kernel_isSFinite d d' X Y R k. + +Lemma sfinite_subdef : Kernel_isSFinite_subdef d d' X Y R k. +Proof. +split; have [s sE] := sfinite; exists s => //. +by move=> n; exact: measure_uub. +Qed. + +HB.instance Definition _ := (*@isSFinite0.Build d d' X Y R k*) sfinite_subdef. + +HB.end. + +HB.mixin Record FiniteKernel_isProbability d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) := { prob_kernel : forall x, k x [set: Y] = 1}. @@ -532,36 +604,28 @@ HB.mixin Record isProbabilityFam HB.structure Definition ProbabilityKernel (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType) := - {k of isProbabilityFam _ _ X Y R k & isKernel _ _ X Y R k & - isFiniteFam _ _ X Y R k & isSFinite _ _ X Y R k}. + {k of FiniteKernel_isProbability _ _ X Y R k & + @FiniteKernel _ _ X Y R k}. Notation "R .-pker X ~> Y" := (probability_kernel X Y R). -HB.factory Record isProbabilityKernel +HB.factory Record Kernel_isProbability d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) of isKernel _ _ X Y R k := - { prob_kernel' : forall x, k x setT = 1 }. + { prob_kernel : forall x, k x setT = 1 }. HB.builders Context d d' (X : measurableType d) (Y : measurableType d') - (R : realType) k of isProbabilityKernel d d' X Y R k. + (R : realType) k of Kernel_isProbability d d' X Y R k. -Let is_finite_kernel : measure_fam_uub k. +Let finite : @Kernel_isFinite d d' X Y R k. Proof. +split. exists 2%R => /= ?. -by rewrite (@le_lt_trans _ _ 1%:E) ?lte_fin ?ltr1n// prob_kernel'. +by rewrite (@le_lt_trans _ _ 1%:E) ?lte_fin ?ltr1n// prob_kernel. Qed. -HB.instance Definition _ := @isFiniteFam.Build _ _ _ _ _ _ is_finite_kernel. +HB.instance Definition _ := finite. -Lemma is_sfinite_kernel : exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> - k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. exact: sfinite_finite. Qed. - -HB.instance Definition _ := @isSFinite.Build _ _ _ _ _ _ is_sfinite_kernel. - -Lemma is_probability_kernel : forall x, k x setT = 1. - exact/prob_kernel'. Qed. - -HB.instance Definition _ := @isProbabilityFam.Build _ _ _ _ _ _ is_probability_kernel. +HB.instance Definition _ := @FiniteKernel_isProbability.Build _ _ _ _ _ k prob_kernel. HB.end. @@ -579,7 +643,8 @@ Lemma sfinite_kernel_measure (d d' : _) (X : measurableType d) Proof. have [k_ k_E] := sfinite k. exists (fun n => k_ n x); last by move=> A mA; rewrite k_E. -by move=> n; exact: finite_kernel_measure. +move=> n; rewrite /finite_measure. +exact: finite_kernel_measure. Qed. (* see measurable_prod_subset in lebesgue_integral.v; @@ -646,7 +711,7 @@ End measurable_prod_subset_kernel. Section measurable_fun_xsection_finite_kernel. Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). -Variable k : R.-fker X ~> Y. +Variables (k : R.-fker X ~> Y). Implicit Types A : set (X * Y). Let phi A := fun x => k x (xsection A x). @@ -783,7 +848,7 @@ Let kprobability_prob x : kprobability x setT = 1. Proof. by rewrite /kprobability/= probability_setT. Qed. HB.instance Definition _ := - @isProbabilityKernel.Build _ _ X Y R kprobability kprobability_prob. + @Kernel_isProbability.Build _ _ X Y R kprobability kprobability_prob. End kprobability. @@ -810,7 +875,7 @@ HB.instance Definition _ := isKernel.Build _ _ _ _ _ (kdirac mf) Let kdirac_prob x : kdirac mf x setT = 1. Proof. by rewrite /kdirac/= diracE in_setT. Qed. -HB.instance Definition _ := isProbabilityKernel.Build _ _ _ _ _ +HB.instance Definition _ := Kernel_isProbability.Build _ _ _ _ _ (kdirac mf) kdirac_prob. End kdirac. @@ -836,33 +901,23 @@ HB.instance Definition _ := @isKernel.Build _ _ _ _ _ kadd measurable_fun_kadd. End kadd. -Section fkadd. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k1 k2 : R.-fker X ~> Y). - -Let kadd_finite_uub : measure_fam_uub (kadd k1 k2). -Proof. -have [f1 hk1] := measure_uub k1; have [f2 hk2] := measure_uub k2. -exists (f1 + f2)%R => x; rewrite /kadd /=. -rewrite -/(measure_add (k1 x) (k2 x)). -by rewrite measure_addE EFinD; exact: lte_add. -Qed. - -HB.instance Definition _ t := - isFiniteFam.Build _ _ _ _ R (kadd k1 k2) kadd_finite_uub. -End fkadd. - Section sfkadd. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). Variables (R : realType) (k1 k2 : R.-sfker X ~> Y). -Let sfinite_kadd : exists k_ : (R.-fker _ ~> _)^nat, +Let sfinite_kadd : exists2 k_ : (R.-ker _ ~> _)^nat, forall n, measure_fam_uub (k_ n) & forall x U, measurable U -> kadd k1 k2 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. Proof. have [f1 hk1] := sfinite k1. have [f2 hk2] := sfinite k2. -exists (fun n => [the finite_kernel _ _ _ of kadd (f1 n) (f2 n)]) => x U mU. +exists (fun n => [the _.-ker _ ~> _ of kadd (f1 n) (f2 n)]). + move=> n. + have [r1 f1r1] := measure_uub (f1 n). + have [r2 f2r2] := measure_uub (f2 n). + exists (r1 + r2)%R => x/=. + by rewrite /msum !big_ord_recr/= big_ord0 add0e EFinD lte_add. +move=> x U mU. rewrite /kadd/=. rewrite -/(measure_add (k1 x) (k2 x)) measure_addE. rewrite /mseries. @@ -873,9 +928,25 @@ by rewrite -/(measure_add (f1 n x) (f2 n x)) measure_addE. Qed. HB.instance Definition _ t := - isSFinite.Build _ _ _ _ R (kadd k1 k2) sfinite_kadd. + Kernel_isSFinite_subdef.Build _ _ _ _ R (kadd k1 k2) sfinite_kadd. End sfkadd. +Section fkadd. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k1 k2 : R.-fker X ~> Y). + +Let kadd_finite_uub : measure_fam_uub (kadd k1 k2). +Proof. +have [f1 hk1] := measure_uub k1; have [f2 hk2] := measure_uub k2. +exists (f1 + f2)%R => x; rewrite /kadd /=. +rewrite -/(measure_add (k1 x) (k2 x)). +by rewrite measure_addE EFinD; exact: lte_add. +Qed. + +HB.instance Definition _ t := + Kernel_isFinite.Build _ _ _ _ R (kadd k1 k2) kadd_finite_uub. +End fkadd. + Section kernel_measurable_preimage. Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). Variable R : realType. @@ -1021,7 +1092,7 @@ by rewrite -EFinM divrr// ?lte_fin ?ltr1n// ?unitfE fine_eq0. Qed. HB.instance Definition _ := - @isProbabilityKernel.Build _ _ _ _ _ (knormalize P) knormalize1. + @Kernel_isProbability.Build _ _ _ _ _ (knormalize P) knormalize1. End knormalize. @@ -1112,7 +1183,7 @@ by rewrite integral_cst//= EFinM lte_pmul2l. Qed. HB.instance Definition _ := - isFiniteFam.Build _ _ X Z R (l \; k) mkcomp_finite. + Kernel_isFinite.Build _ _ X Z R (l \; k) mkcomp_finite. End kcomp_finite_kernel_finite. End KCOMP_FINITE_KERNEL. @@ -1174,7 +1245,7 @@ HB.instance Definition _ := #[export] HB.instance Definition _ := - isSFinite.Build _ _ X Z R (l \; k) (mkcomp_sfinite l k). + Kernel_isSFinite.Build _ _ X Z R (l \; k) (mkcomp_sfinite l k). End kcomp_sfinite_kernel. End KCOMP_SFINITE_KERNEL. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 2bc2e68b11..bc0e9b5350 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -193,7 +193,7 @@ rewrite (_ : [set tt] == set0 = false); last first. by case: ifPn => // /andP[]. Qed. -HB.instance Definition _ i := @isFiniteFam.Build _ _ _ _ R (mk i) (mk_uub i). +HB.instance Definition _ i := @Kernel_isFinite.Build _ _ _ _ R (mk i) (mk_uub i). End score. End SCORE. @@ -245,7 +245,7 @@ move: jk; rewrite neq_ltn/= => /orP[|] jr. by rewrite -floor_lt_int. Qed. -HB.instance Definition _ := @isSFinite.Build _ _ _ _ _ (kscore mr) sfinite_kscore. +HB.instance Definition _ := @Kernel_isSFinite.Build _ _ _ _ _ (kscore mr) sfinite_kscore. End kscore. @@ -269,28 +269,29 @@ apply: (@measurable_fun_if_pair _ _ _ _ (k ^~ U) (fun=> mzero U)). exact: measurable_fun_cst. Qed. +#[export] HB.instance Definition _ := isKernel.Build _ _ _ _ R kiteT measurable_fun_kiteT. End kiteT. -Section fkiteT. +Section sfkiteT. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k : R.-fker X ~> Y). +Variables (R : realType) (k : R.-sfker X ~> Y). -Let kiteT_uub : measure_fam_uub (kiteT k). +Let sfinite_kiteT : exists2 k_ : (R.-ker _ ~> _)^nat, + forall n, measure_fam_uub (k_ n) & + forall x U, measurable U -> + kiteT k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. Proof. -have /measure_fam_uubP[M hM] := measure_uub k. -exists M%:num => /= -[]; rewrite /kiteT => t [|]/=; first exact: hM. -by rewrite /= /mzero. +have [k_ hk /=] := sfinite k. +exists (fun n => [the _.-ker _ ~> _ of kiteT (k_ n)]) => /=. + move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). + by exists r%:num => /= -[x []]; rewrite /kiteT//= /mzero//. +move=> [x b] U mU; rewrite /kiteT; case: ifPn => hb. + by rewrite hk. +by rewrite /mseries nneseries0. Qed. -HB.instance Definition _ t := isFiniteFam.Build _ _ _ _ R (kiteT k) kiteT_uub. -End fkiteT. - -Section sfkiteT. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k : R.-sfker X ~> Y). - -Let sfinite_kiteT : exists k_ : (R.-fker _ ~> _)^nat, +(*Let sfinite_kiteT : exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> kiteT k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. Proof. @@ -302,12 +303,29 @@ rewrite /kiteT; case: ifPn => hb. by rewrite /kiteT hb. rewrite /= /mseries nneseries0// => n _. by rewrite /kiteT (negbTE hb). -Qed. - -HB.instance Definition _ t := @isSFinite.Build _ _ _ _ _ (kiteT k) sfinite_kiteT. +Qed.*) +(* NB: we could also want to use Kernel_isSFinite *) +#[export] +HB.instance Definition _ t := @Kernel_isSFinite_subdef.Build _ _ _ _ _ + (kiteT k) sfinite_kiteT. End sfkiteT. +Section fkiteT. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k : R.-fker X ~> Y). + +Let kiteT_uub : measure_fam_uub (kiteT k). +Proof. +have /measure_fam_uubP[M hM] := measure_uub k. +exists M%:num => /= -[]; rewrite /kiteT => t [|]/=; first exact: hM. +by rewrite /= /mzero. +Qed. + +#[export] +HB.instance Definition _ t := Kernel_isFinite.Build _ _ _ _ R (kiteT k) kiteT_uub. +End fkiteT. + Section kiteF. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). Variables (R : realType) (k : R.-ker X ~> Y). @@ -326,30 +344,30 @@ apply: (@measurable_fun_if_pair _ _ _ _ (fun=> mzero U) (k ^~ U)). exact/measurable_kernel. Qed. +#[export] HB.instance Definition _ := isKernel.Build _ _ _ _ R kiteF measurable_fun_kiteF. End kiteF. -Section fkiteF. +Section sfkiteF. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k : R.-fker X ~> Y). +Variables (R : realType) (k : R.-sfker X ~> Y). -Let kiteF_uub : measure_fam_uub (kiteF k). +Let sfinite_kiteF : exists2 k_ : (R.-ker _ ~> _)^nat, + forall n, measure_fam_uub (k_ n) & + forall x U, measurable U -> + kiteF k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. Proof. -have /measure_fam_uubP[M hM] := measure_uub k. -exists M%:num => /= -[]; rewrite /kiteF/= => t. -by case => //=; rewrite /mzero. +have [k_ hk /=] := sfinite k. +exists (fun n => [the _.-ker _ ~> _ of kiteF (k_ n)]) => /=. + move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). + by exists r%:num => /= -[x []]; rewrite /kiteF//= /mzero//. +move=> [x b] U mU; rewrite /kiteF; case: ifPn => hb. + by rewrite hk. +by rewrite /mseries nneseries0. Qed. -HB.instance Definition _ := isFiniteFam.Build _ _ _ _ R (kiteF k) kiteF_uub. - -End fkiteF. - -Section sfkiteF. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k : R.-sfker X ~> Y). - -Let sfinite_kiteF : exists k_ : (R.-fker _ ~> _)^nat, +(*Let sfinite_kiteF : exists k_ : (R.-fker _ ~> _)^nat, forall x U, measurable U -> kiteF k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. Proof. @@ -359,11 +377,35 @@ rewrite /= /kiteF /=; case: ifPn => hb. by rewrite /mseries hk//= /mseries/=. by rewrite /= /mseries nneseries0. Qed. +*) -HB.instance Definition _ := @isSFinite.Build _ _ _ _ _ (kiteF k) sfinite_kiteF. +#[export] +HB.instance Definition _ := @Kernel_isSFinite_subdef.Build _ _ _ _ _ + (kiteF k) sfinite_kiteF. End sfkiteF. + +Section fkiteF. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (k : R.-fker X ~> Y). + +Let kiteF_uub : measure_fam_uub (kiteF k). +Proof. +have /measure_fam_uubP[M hM] := measure_uub k. +exists M%:num => /= -[]; rewrite /kiteF/= => t. +by case => //=; rewrite /mzero. +Qed. + +#[export] +HB.instance Definition _ := Kernel_isFinite.Build _ _ _ _ R (kiteF k) kiteF_uub. + +End fkiteF. + +(*Module Exports. +HB.reexport. +End Exports.*) End ITE. +(*Export ITE.Exports.*) Section ite. Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). From 51900a1ea9ee09022dff929c1724ea3a4e95e2ab Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Sun, 18 Sep 2022 08:19:51 +0900 Subject: [PATCH 19/54] subprob kernel --- theories/kernel.v | 60 +++++++++++++++++++++++++++++++++++++---------- 1 file changed, 47 insertions(+), 13 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index a94d7db6ea..008887b582 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -15,8 +15,9 @@ Require Import lebesgue_measure fsbigop numfun lebesgue_integral. (* sfinite_measure mu == the measure mu is s-finite *) (* R.-ker X ~> Y == kernel *) (* kseries == countable sum of kernels *) -(* R.-fker X ~> Y == finite kernel *) (* R.-sfker X ~> Y == s-finite kernel *) +(* R.-fker X ~> Y == finite kernel *) +(* R.-spker X ~> Y == subprobability kernel *) (* R.-pker X ~> Y == probability kernel *) (* kprobability m == kernel defined by a probability measure *) (* kdirac mf == kernel defined by a measurable function *) @@ -387,8 +388,9 @@ End sfinite_fubini. Arguments sfinite_fubini {d d' X Y R m1} _ {m2} _ f. Reserved Notation "R .-ker X ~> Y" (at level 42, format "R .-ker X ~> Y"). -Reserved Notation "R .-fker X ~> Y" (at level 42, format "R .-fker X ~> Y"). Reserved Notation "R .-sfker X ~> Y" (at level 42, format "R .-sfker X ~> Y"). +Reserved Notation "R .-fker X ~> Y" (at level 42, format "R .-fker X ~> Y"). +Reserved Notation "R .-spker X ~> Y" (at level 42, format "R .-spker X ~> Y"). Reserved Notation "R .-pker X ~> Y" (at level 42, format "R .-pker X ~> Y"). HB.mixin Record isKernel d d' (X : measurableType d) (Y : measurableType d') @@ -415,7 +417,7 @@ Lemma measurable_fun_kseries (U : set Y) : measurable U -> measurable_fun setT (kseries ^~ U). Proof. -move=> mU; rewrite /kseries /= /mseries. +move=> mU. by apply: ge0_emeasurable_fun_sum => // n; exact/measurable_kernel. Qed. @@ -453,7 +455,8 @@ End measure_fam_uub. HB.mixin Record Kernel_isSFinite_subdef d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) := { - sfinite_subdef : exists2 s : (R.-ker X ~> Y)^nat, forall n, measure_fam_uub (s n) & + sfinite_subdef : exists2 s : (R.-ker X ~> Y)^nat, + forall n, measure_fam_uub (s n) & forall x U, measurable U -> k x U = kseries s x U }. #[short(type=sfinite_kernel)] @@ -595,7 +598,40 @@ HB.instance Definition _ := (*@isSFinite0.Build d d' X Y R k*) sfinite_subdef. HB.end. -HB.mixin Record FiniteKernel_isProbability +HB.mixin Record FiniteKernel_isSubProbability + d d' (X : measurableType d) (Y : measurableType d') + (R : realType) (k : X -> {measure set Y -> \bar R}) := + { sprob_kernel : ereal_sup [set k x [set: Y] | x in setT] <= 1}. + +#[short(type=sprobability_kernel)] +HB.structure Definition SubProbabilityKernel + (d d' : _) (X : measurableType d) (Y : measurableType d') + (R : realType) := + {k of FiniteKernel_isSubProbability _ _ X Y R k & + @FiniteKernel _ _ X Y R k}. +Notation "R .-spker X ~> Y" := (sprobability_kernel X Y R). + +HB.factory Record Kernel_isSubProbability + d d' (X : measurableType d) (Y : measurableType d') + (R : realType) (k : X -> {measure set Y -> \bar R}) of isKernel _ _ X Y R k := + { sprob_kernel : ereal_sup [set k x [set: Y] | x in setT] <= 1}. + +HB.builders Context d d' (X : measurableType d) (Y : measurableType d') + (R : realType) k of Kernel_isSubProbability d d' X Y R k. + +Let finite : @Kernel_isFinite d d' X Y R k. +Proof. +split; exists 2%R => /= ?; rewrite (@le_lt_trans _ _ 1%:E) ?lte_fin ?ltr1n//. +by rewrite (le_trans _ sprob_kernel)//; exact: ereal_sup_ub. +Qed. + +HB.instance Definition _ := finite. + +HB.instance Definition _ := @FiniteKernel_isSubProbability.Build _ _ _ _ _ k sprob_kernel. + +HB.end. + +HB.mixin Record SubProbability_isProbability d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) := { prob_kernel : forall x, k x [set: Y] = 1}. @@ -604,8 +640,8 @@ HB.mixin Record FiniteKernel_isProbability HB.structure Definition ProbabilityKernel (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType) := - {k of FiniteKernel_isProbability _ _ X Y R k & - @FiniteKernel _ _ X Y R k}. + {k of SubProbability_isProbability _ _ X Y R k & + @SubProbabilityKernel _ _ X Y R k}. Notation "R .-pker X ~> Y" := (probability_kernel X Y R). HB.factory Record Kernel_isProbability @@ -616,16 +652,14 @@ HB.factory Record Kernel_isProbability HB.builders Context d d' (X : measurableType d) (Y : measurableType d') (R : realType) k of Kernel_isProbability d d' X Y R k. -Let finite : @Kernel_isFinite d d' X Y R k. +Let sprob_kernel : @Kernel_isSubProbability d d' X Y R k. Proof. -split. -exists 2%R => /= ?. -by rewrite (@le_lt_trans _ _ 1%:E) ?lte_fin ?ltr1n// prob_kernel. +by split; apply: ub_ereal_sup => x [y _ <-{x}]; rewrite prob_kernel. Qed. -HB.instance Definition _ := finite. +HB.instance Definition _ := sprob_kernel. -HB.instance Definition _ := @FiniteKernel_isProbability.Build _ _ _ _ _ k prob_kernel. +HB.instance Definition _ := @SubProbability_isProbability.Build _ _ _ _ _ k prob_kernel. HB.end. From 613ccd7a9dfce1bd4014f6b4af08c3289644eb64 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 21 Sep 2022 09:36:09 +0900 Subject: [PATCH 20/54] cleaning --- theories/kernel.v | 314 +++++++++++++++++++------------------------ theories/prob_lang.v | 129 ++++++++---------- theories/wip.v | 19 +-- 3 files changed, 207 insertions(+), 255 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 008887b582..d84168a0d0 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -10,6 +10,8 @@ Require Import lebesgue_measure fsbigop numfun lebesgue_integral. (* *) (* This file provides a formation of kernels and extends the theory of *) (* measures with, e.g., Tonelli-Fubini's theorem for s-finite measures. *) +(* The main result is the fact that s-finite kernels are stable by *) +(* composition. *) (* *) (* finite_measure mu == the measure mu is finite *) (* sfinite_measure mu == the measure mu is s-finite *) @@ -58,7 +60,7 @@ Qed. End probability_lemmas. (* /PR 516 in progress *) -(* TODO: PR *) +(* TODO: PR*) Lemma setT0 (T : pointedType) : setT != set0 :> set T. Proof. by apply/eqP => /seteqP[] /(_ point) /(_ Logic.I). Qed. @@ -93,6 +95,10 @@ have -> : B = set0. by apply/or4P; rewrite eqxx/= !orbT. Qed. +Lemma xsection_preimage_snd (X Y Z : Type) (f : Y -> Z) (A : set Z) (x : X) : + xsection ((f \o snd) @^-1` A) x = f @^-1` A. +Proof. by apply/seteqP; split; move=> y/=; rewrite /xsection/= inE. Qed. + Canonical unit_pointedType := PointedType unit tt. Section discrete_measurable_unit. @@ -269,28 +275,22 @@ apply: continuous_measurable_fun. by have := (@opp_continuous R [the normedModType R of R^o]). Qed. -Section integralM_0ifneg. -Local Open Scope ereal_scope. -Variables (d : _) (T : measurableType d) (R : realType). -Variables (m : {measure set T -> \bar R}) (D : set T) (mD : measurable D). - -Lemma integralM_0ifneg (f : R -> T -> \bar R) (k : R) - (f0 : forall r t, D t -> 0 <= f r t) : - ((k < 0)%R -> f k = cst 0%E) -> measurable_fun setT (f k) -> - \int[m]_(x in D) (k%:E * (f k) x) = k%:E * \int[m]_(x in D) ((f k) x). +Lemma integral_eq0 d (T : measurableType d) (R : realType) + (mu : {measure set T -> \bar R}) (D : set T) f : + (forall x, D x -> f x = 0) -> \int[mu]_(x in D) f x = 0. Proof. -move=> fk0 mfk; have [k0|k0] := ltP k 0%R. - rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0; last first. - by move=> x _; rewrite fk0// mule0. - rewrite (eq_integral (cst 0%E)) ?integral0 ?mule0// => x _. - by rewrite fk0// indic0. -rewrite ge0_integralM//. -- by apply/(@measurable_funS _ _ _ _ setT) => //. -- by move=> y Dy; rewrite f0. +move=> f0; under eq_integral. + by move=> x /[1!inE] /f0 ->; over. +by rewrite integral0. Qed. -End integralM_0ifneg. -Arguments integralM_0ifneg {d T R} m {D} mD f. +Lemma dirac0 d (T : measurableType d) (R : realFieldType) (a : T) : + \d_a set0 = 0%E :> \bar R. +Proof. by rewrite /dirac indic0. Qed. + +Lemma diracT d (T : measurableType d) (R : realFieldType) (a : T) : + \d_a setT = 1%E :> \bar R. +Proof. by rewrite /dirac indicT. Qed. Section fubini_tonelli. Local Open Scope ereal_scope. @@ -765,14 +765,13 @@ Qed. End measurable_fun_xsection_finite_kernel. -(* pollard? *) Section measurable_fun_integral_finite_sfinite. Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). +Variable k : X * Y -> \bar R. Lemma measurable_fun_xsection_integral (l : X -> {measure set Y -> \bar R}) - (k : X * Y -> \bar R) (k_ : ({nnsfun [the measurableType _ of (X * Y)%type] >-> R})^nat) (ndk_ : nondecreasing_seq (k_ : (X * Y -> R)^nat)) (k_k : forall z, EFin \o (k_ ^~ z) --> k z) : @@ -799,11 +798,11 @@ rewrite (_ : (fun x => _) = - by move=> y _ m n mn; rewrite lee_fin; exact/lefP/ndk_. apply: measurable_fun_elim_sup => n. rewrite [X in measurable_fun _ X](_ : _ = (fun x => \int[l x]_y - (\sum_(r <- fset_set (range (k_ n)))(*TODO: upd when the PR 743 is merged*) + (\sum_(r <- fset_set (range (k_ n)))(*TODO: upd when PR 743 is merged*) r * \1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. rewrite [X in measurable_fun _ X](_ : _ = (fun x => - \sum_(r <- fset_set (range (k_ n)))(*TODO: upd when the PR 743 is merged*) + \sum_(r <- fset_set (range (k_ n)))(*TODO: upd when PR 743 is merged*) (\int[l x]_y (r * \1_(k_ n @^-1` [set r]) (x, y))%:E))); last first. apply/funext => x; rewrite -ge0_integral_sum//. - by apply: eq_integral => y _; rewrite sumEFin. @@ -815,14 +814,15 @@ rewrite [X in measurable_fun _ X](_ : _ = (fun x => apply emeasurable_fun_sum => r. rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * \int[l x]_y (\1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. - apply/funext => x. - under eq_integral do rewrite EFinM. - rewrite (integralM_0ifneg _ _ (fun k y => (\1_(k_ n @^-1` [set r]) (x, y))%:E))//. - - by move=> _ y _; rewrite lee_fin. - - by move=> r0; apply/funext => y; rewrite preimage_nnfun0// indicE in_set0. - - apply/EFin_measurable_fun/measurable_fun_prod1 => /=. + apply/funext => x; under eq_integral do rewrite EFinM. + have [r0|r0] := leP 0%R r. + rewrite ge0_integralM//; last by move=> y _; rewrite lee_fin. + apply/EFin_measurable_fun/measurable_fun_prod1 => /=. rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r))//. exact/measurable_funP. + rewrite integral_eq0; last first. + by move=> y _; rewrite preimage_nnfun0// indic0 mule0. + by rewrite integral_eq0 ?mule0// => y _; rewrite preimage_nnfun0// indic0. apply/measurable_funeM. rewrite (_ : (fun x => _) = (fun x => l x (xsection (k_ n @^-1` [set r]) x))). exact/h. @@ -834,9 +834,8 @@ congr (l x _); apply/funext => y1/=; rewrite /xsection/= inE. by apply/propext; tauto. Qed. -Lemma measurable_fun_integral_finite_kernel - (l : R.-fker X ~> Y) - (k : X * Y -> \bar R) (k0 : forall z, 0 <= k z) (mk : measurable_fun setT k) : +Lemma measurable_fun_integral_finite_kernel (l : R.-fker X ~> Y) + (k0 : forall z, 0 <= k z) (mk : measurable_fun setT k) : measurable_fun setT (fun x => \int[l x]_y k (x, y)). Proof. have [k_ [ndk_ k_k]] := approximation measurableT mk (fun x _ => k0 x). @@ -845,9 +844,8 @@ have [l_ hl_] := measure_uub l. by apply: measurable_fun_xsection_finite_kernel => // /[!inE]. Qed. -Lemma measurable_fun_integral_sfinite_kernel - (l : R.-sfker X ~> Y) - (k : X * Y -> \bar R) (k0 : forall t, 0 <= k t) (mk : measurable_fun setT k) : +Lemma measurable_fun_integral_sfinite_kernel (l : R.-sfker X ~> Y) + (k0 : forall t, 0 <= k t) (mk : measurable_fun setT k) : measurable_fun setT (fun x => \int[l x]_y k (x, y)). Proof. have [k_ [ndk_ k_k]] := approximation measurableT mk (fun xy _ => k0 xy). @@ -861,9 +859,9 @@ by apply: measurable_fun_xsection_finite_kernel => // /[!inE]. Qed. End measurable_fun_integral_finite_sfinite. -Arguments measurable_fun_xsection_integral {_ _ _ _ _} l k. -Arguments measurable_fun_integral_finite_kernel {_ _ _ _ _} l k. -Arguments measurable_fun_integral_sfinite_kernel {_ _ _ _ _} l k. +Arguments measurable_fun_xsection_integral {_ _ _ _ _} k l. +Arguments measurable_fun_integral_finite_kernel {_ _ _ _ _} k l. +Arguments measurable_fun_integral_sfinite_kernel {_ _ _ _ _} k l. Section kprobability. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). @@ -907,7 +905,7 @@ HB.instance Definition _ := isKernel.Build _ _ _ _ _ (kdirac mf) measurable_fun_kdirac. Let kdirac_prob x : kdirac mf x setT = 1. -Proof. by rewrite /kdirac/= diracE in_setT. Qed. +Proof. by rewrite /kdirac/= diracT. Qed. HB.instance Definition _ := Kernel_isProbability.Build _ _ _ _ _ (kdirac mf) kdirac_prob. @@ -981,6 +979,7 @@ HB.instance Definition _ t := Kernel_isFinite.Build _ _ _ _ R (kadd k1 k2) kadd_finite_uub. End fkadd. +(* TODO: move *) Section kernel_measurable_preimage. Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). Variable R : realType. @@ -1005,6 +1004,7 @@ Qed. End kernel_measurable_preimage. +(* TODO: move *) Lemma measurable_fun_eq_cst (d d' : _) (T : measurableType d) (T' : measurableType d') (R : realType) (f : R.-ker T ~> T') k : measurable_fun setT (fun t => f t setT == k). @@ -1080,36 +1080,29 @@ Proof. move=> mU; rewrite /knormalize/= /mnormalize /=. rewrite (_ : (fun _ => _) = (fun x => if f x setT == 0 then P U else if f x setT == +oo then P U - else f x U * ((fine (f x setT))^-1)%:E)); last first. - apply/funext => x; case: ifPn => [/orP[->//|->]|]. - by case: ifPn. + else f x U * (fine (f x setT))^-1%:E)); last first. + apply/funext => x; case: ifPn => [/orP[->//|->]|]; first by case: ifPn. by rewrite negb_or=> /andP[/negbTE -> /negbTE ->]. +apply: measurable_fun_if => //; + [exact: measurable_fun_eq_cst|exact: measurable_fun_cst|]. apply: measurable_fun_if => //. +- rewrite setTI [X in measurable X](_ : _ = [set t | f t setT != 0]). + exact: measurable_neq_cst. + by apply/seteqP; split => [x /negbT//|x /negbTE]. - exact: measurable_fun_eq_cst. - exact: measurable_fun_cst. -- apply: measurable_fun_if => //. - + rewrite setTI [X in measurable X](_ : _ = [set t | f t setT != 0]); last first. - by apply/seteqP; split => [x /negbT//|x /negbTE]. - exact: measurable_neq_cst. - + exact: measurable_fun_eq_cst. - + exact: measurable_fun_cst. - + apply: emeasurable_funM. - by have := measurable_kernel f U mU; exact: measurable_funS. - apply/EFin_measurable_fun. - apply: (measurable_fun_comp' (F := [set r : R | r != 0%R])) => //. - * exact: open_measurable. - * move=> /= r [t] [] [_ H1] H2 H3. - apply/eqP => H4; subst r. - move/eqP : H4. - rewrite fine_eq0 ?H1//. - rewrite ge0_fin_numE//. - by rewrite lt_neqAle leey H2. - * apply: open_continuous_measurable_fun => //. - apply/in_setP => x /= x0. - by apply: inv_continuous. - * apply: measurable_fun_comp => /=. - exact: measurable_fun_fine. - by have := measurable_kernel f _ measurableT; exact: measurable_funS. +- apply: emeasurable_funM. + by have := measurable_kernel f U mU; exact: measurable_funS. + apply/EFin_measurable_fun. + apply: (@measurable_fun_comp' _ _ _ _ _ _ [set r : R | r != 0%R]) => //. + + exact: open_measurable. + + move=> /= r [t] [] [_ ft0] ftoo ftr; apply/eqP => r0. + move: (ftr); rewrite r0 => /eqP; rewrite fine_eq0 ?ft0//. + by rewrite ge0_fin_numE// lt_neqAle leey ftoo. + + apply: open_continuous_measurable_fun => //; apply/in_setP => x /= x0. + exact: inv_continuous. + + apply: measurable_fun_comp => /=; first exact: measurable_fun_fine. + by have := measurable_kernel f _ measurableT; exact: measurable_funS. Qed. HB.instance Definition _ := isKernel.Build _ _ _ _ R (knormalize P) @@ -1158,13 +1151,13 @@ Let kcomp_ge0 x U : 0 <= (l \; k) x U. Proof. exact: integral_ge0. Qed. Let kcomp_sigma_additive x : semi_sigma_additive ((l \; k) x). Proof. move=> U mU tU mUU; rewrite [X in _ --> X](_ : _ = - \int[l x]_y (\sum_(n V _. by apply/esym/cvg_lim => //; exact/measure_semi_sigma_additive. apply/cvg_closeP; split. by apply: is_cvg_nneseries => n _; exact: integral_ge0. rewrite closeE// integral_sum// => n. -by have /measurable_fun_prod1 := measurable_kernel k (U n) (mU n). +by have /measurable_fun_prod1 := measurable_kernel k _ (mU n). Qed. HB.instance Definition _ x := isMeasure.Build _ R _ @@ -1187,7 +1180,7 @@ Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') Lemma measurable_fun_kcomp_finite U : measurable U -> measurable_fun setT ((l \; k) ^~ U). Proof. -move=> mU; apply: (measurable_fun_integral_finite_kernel _ (k ^~ U)) => //=. +move=> mU; apply: (measurable_fun_integral_finite_kernel (k ^~ U)) => //=. exact/measurable_kernel. Qed. @@ -1209,7 +1202,7 @@ have /measure_fam_uubP[s hs] := measure_uub l. apply/measure_fam_uubP; exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x /=. apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). apply: ge0_le_integral => //. - - have /measurable_fun_prod1 := measurable_kernel k setT measurableT. + - have /measurable_fun_prod1 := measurable_kernel k _ measurableT. exact. - exact/measurable_fun_cst. - by move=> y _; exact/ltW/hr. @@ -1261,7 +1254,7 @@ Qed. Lemma measurable_fun_mkcomp_sfinite U : measurable U -> measurable_fun setT ((l \; k) ^~ U). Proof. -move=> mU; apply: (measurable_fun_integral_sfinite_kernel _ (k ^~ U)) => //. +move=> mU; apply: (measurable_fun_integral_sfinite_kernel (k ^~ U)) => //. exact/measurable_kernel. Qed. @@ -1285,119 +1278,97 @@ End kcomp_sfinite_kernel. End KCOMP_SFINITE_KERNEL. HB.export KCOMP_SFINITE_KERNEL. -(* pollard? *) -Section measurable_fun_integral_kernel'. +Section measurable_fun_preimage_integral. Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). -Variables (l : X -> {measure set Y -> \bar R}) - (k : Y -> \bar R) +Variables (k : Y -> \bar R) (k_ : ({nnsfun Y >-> R}) ^nat) (ndk_ : nondecreasing_seq (k_ : (Y -> R)^nat)) (k_k : forall z, setT z -> EFin \o (k_ ^~ z) --> k z). -Let p : (X * Y -> R)^nat := fun n xy => k_ n xy.2. +Let k_2 : (X * Y -> R)^nat := fun n => k_ n \o snd. -Let p_ge0 n x : (0 <= p n x)%R. Proof. by []. Qed. +Let k_2_ge0 n x : (0 <= k_2 n x)%R. Proof. by []. Qed. -HB.instance Definition _ n := @IsNonNegFun.Build _ R (p n) (p_ge0 n). +HB.instance Definition _ n := @IsNonNegFun.Build _ _ _ (k_2_ge0 n). -Let mp n : measurable_fun setT (p n). -Proof. -rewrite /p => _ /= B mB; rewrite setTI. -have mk_n : measurable_fun setT (k_ n) by []. -rewrite (_ : _ @^-1` _ = setT `*` (k_ n @^-1` B)); last first. - by apply/seteqP; split => xy /=; tauto. -apply: measurableM => //. -have := mk_n measurableT _ mB. -by rewrite setTI. -Qed. +Let mk_2 n : measurable_fun setT (k_2 n). +Proof. by apply: measurable_fun_comp => //; exact: measurable_fun_snd. Qed. -HB.instance Definition _ n := @IsMeasurableFun.Build _ _ R (p n) (mp n). +HB.instance Definition _ n := @IsMeasurableFun.Build _ _ _ _ (mk_2 n). -Let fp n : finite_set (range (p n)). +Let fk_2 n : finite_set (range (k_2 n)). Proof. have := @fimfunP _ _ (k_ n). -suff : range (k_ n) = range (p n) by move=> <-. +suff : range (k_ n) = range (k_2 n) by move=> <-. by apply/seteqP; split => r [y ?] <-; [exists (point, y)|exists y.2]. Qed. -HB.instance Definition _ n := @FiniteImage.Build _ _ (p n) (fp n). +HB.instance Definition _ n := @FiniteImage.Build _ _ _ (fk_2 n). -Lemma measurable_fun_preimage_integral : - (forall n r, measurable_fun setT (fun x => l x (k_ n @^-1` [set r]))) -> +Lemma measurable_fun_preimage_integral (l : X -> {measure set Y -> \bar R}) : + (forall n r, measurable_fun setT (l ^~ (k_ n @^-1` [set r]))) -> measurable_fun setT (fun x => \int[l x]_z k z). Proof. -move=> h. -apply: (measurable_fun_xsection_integral l (fun xy => k xy.2) - (fun n => [the {nnsfun _ >-> _} of p n])) => /=. -- by rewrite /p => m n mn; apply/lefP => -[x y] /=; exact/lefP/ndk_. +move=> h; apply: (measurable_fun_xsection_integral (k \o snd) l + (fun n => [the {nnsfun _ >-> _} of k_2 n])) => /=. +- by rewrite /k_2 => m n mn; apply/lefP => -[x y] /=; exact/lefP/ndk_. - by move=> [x y]; exact: k_k. - move=> n r _ /= B mB. - have := h n r measurableT B mB. - rewrite !setTI. - suff : ((fun x => l x (k_ n @^-1` [set r])) @^-1` B) = - ((fun x => l x (xsection (p n @^-1` [set r]) x)) @^-1` B) by move=> ->. - apply/seteqP; split => x/=. - suff : (k_ n @^-1` [set r]) = (xsection (p n @^-1` [set r]) x) by move=> ->. - by apply/seteqP; split; move=> y/=; - rewrite /xsection/= /p /preimage/= inE/=. - suff : (k_ n @^-1` [set r]) = (xsection (p n @^-1` [set r]) x) by move=> ->. - by apply/seteqP; split; move=> y/=; rewrite /xsection/= /p /preimage/= inE/=. + have := h n r measurableT B mB; rewrite !setTI. + suff : (l ^~ (k_ n @^-1` [set r])) @^-1` B = + (fun x => l x (xsection (k_2 n @^-1` [set r]) x)) @^-1` B by move=> ->. + by apply/seteqP; split => x/=; rewrite xsection_preimage_snd. Qed. -End measurable_fun_integral_kernel'. +End measurable_fun_preimage_integral. Lemma measurable_fun_integral_kernel - (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) - (l : R.-ker [the measurableType _ of (X * Y)%type] ~> Z) c - (k : Z -> \bar R) (k0 : forall z, True -> 0 <= k z) (mk : measurable_fun setT k) : - measurable_fun setT (fun y => \int[l (c, y)]_z k z). + d d' (X : measurableType d) (Y : measurableType d') (R : realType) + (l : X -> {measure set Y -> \bar R}) + (ml : forall U, measurable U -> measurable_fun setT (l ^~ U)) + (* NB: l is really just a kernel *) + (k : Y -> \bar R) (k0 : forall z, 0 <= k z) (mk : measurable_fun setT k) : + measurable_fun setT (fun x => \int[l x]_y k y). Proof. -have [k_ [ndk_ k_k]] := approximation measurableT mk k0. -apply: (measurable_fun_preimage_integral ndk_ k_k) => n r. -have := measurable_kernel l (k_ n @^-1` [set r]) (measurable_sfunP (k_ n) r). -by move=> /measurable_fun_prod1; exact. +have [k_ [ndk_ k_k]] := approximation measurableT mk (fun x _ => k0 x). +by apply: (measurable_fun_preimage_integral ndk_ k_k) => n r; exact/ml. Qed. Section integral_kcomp. +Variables (d d2 d3 : _) (X : measurableType d) (Y : measurableType d2) + (Z : measurableType d3) (R : realType). +Variable l : R.-sfker X ~> Y. +Variables k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. -Let integral_kcomp_indic d d' d3 (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) - x (E : set _) (mE : measurable E) : +Let integral_kcomp_indic x E (mE : measurable E) : \int[(l \; k) x]_z (\1_E z)%:E = \int[l x]_y (\int[k (x, y)]_z (\1_E z)%:E). Proof. rewrite integral_indic//= /kcomp. by apply eq_integral => y _; rewrite integral_indic. Qed. -Let integral_kcomp_nnsfun d d' d3 (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) - x (f : {nnsfun Z >-> R}) : +Let integral_kcomp_nnsfun x (f : {nnsfun Z >-> R}) : \int[(l \; k) x]_z (f z)%:E = \int[l x]_y (\int[k (x, y)]_z (f z)%:E). Proof. under [in LHS]eq_integral do rewrite fimfunE -sumEFin. rewrite ge0_integral_sum//; last 2 first. - move=> r; apply/EFin_measurable_fun/measurable_funrM. - have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. - by rewrite (_ : \1__ = mindic R fr). - by move=> r z _; rewrite EFinM nnfun_muleindic_ge0. + - move=> r; apply/EFin_measurable_fun/measurable_funrM. + have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). + - by move=> r z _; rewrite EFinM nnfun_muleindic_ge0. under [in RHS]eq_integral. move=> y _. under eq_integral. - move=> z _. - rewrite fimfunE -sumEFin. - over. + by move=> z _; rewrite fimfunE -sumEFin; over. rewrite /= ge0_integral_sum//; last 2 first. - move=> r; apply/EFin_measurable_fun/measurable_funrM. - have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. - by rewrite (_ : \1__ = mindic R fr). - by move=> r z _; rewrite EFinM nnfun_muleindic_ge0. + - move=> r; apply/EFin_measurable_fun/measurable_funrM. + have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. + by rewrite (_ : \1__ = mindic R fr). + - by move=> r z _; rewrite EFinM nnfun_muleindic_ge0. under eq_bigr. move=> r _. - rewrite (@integralM_indic _ _ _ _ _ _ (fun r => f @^-1` [set r]))//; last first. + rewrite (integralM_indic _ (fun r => f @^-1` [set r]))//; last first. by move=> r0; rewrite preimage_nnfun0. rewrite integral_indic// setIT. over. @@ -1407,64 +1378,55 @@ rewrite /= ge0_integral_sum//; last 2 first. have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). by move=> /measurable_fun_prod1; exact. - move=> n y _. - have := @mulemu_ge0 _ _ _ (k (x, y)) n (fun n => f @^-1` [set n]). + have := mulemu_ge0 (fun n => f @^-1` [set n]). by apply; exact: preimage_nnfun0. apply eq_bigr => r _. -rewrite (@integralM_indic _ _ _ _ _ _ (fun r => f @^-1` [set r]))//; last first. +rewrite (integralM_indic _ (fun r => f @^-1` [set r]))//; last first. exact: preimage_nnfun0. rewrite /= integral_kcomp_indic; last exact/measurable_sfunP. -rewrite (@integralM_0ifneg _ _ _ _ _ _ (fun r t => k (x, t) (f @^-1` [set r])))//; last 2 first. - move=> r0. - apply/funext => y. - by rewrite preimage_nnfun0// measure0. - have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). - by move/measurable_fun_prod1; exact. -congr (_ * _); apply eq_integral => y _. -by rewrite integral_indic// setIT. +have [r0|r0] := leP 0%R r. + rewrite ge0_integralM//; last first. + have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). + by move/measurable_fun_prod1; exact. + by congr (_ * _); apply eq_integral => y _; rewrite integral_indic// setIT. +rewrite integral_eq0 ?mule0; last first. + by move=> y _; rewrite integral_eq0// => z _; rewrite preimage_nnfun0// indic0. +by rewrite integral_eq0// => y _; rewrite preimage_nnfun0// measure0 mule0. Qed. -Lemma integral_kcomp d d' d3 (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) - x f : (forall z, 0 <= f z) -> measurable_fun setT f -> +Lemma integral_kcomp x f : (forall z, 0 <= f z) -> measurable_fun setT f -> \int[(l \; k) x]_z f z = \int[l x]_y (\int[k (x, y)]_z f z). Proof. move=> f0 mf. have [f_ [ndf_ f_f]] := approximation measurableT mf (fun z _ => f0 z). -transitivity (\int[(l \; k) x]_z (lim (EFin \o (f_^~ z)))). - apply/eq_integral => z _. - apply/esym/cvg_lim => //=. - exact: f_f. +transitivity (\int[(l \; k) x]_z (lim (EFin \o f_^~ z))). + by apply/eq_integral => z _; apply/esym/cvg_lim => //=; exact: f_f. rewrite monotone_convergence//; last 3 first. - by move=> n; apply/EFin_measurable_fun. + by move=> n; exact/EFin_measurable_fun. by move=> n z _; rewrite lee_fin. by move=> z _ a b /ndf_ /lefP ab; rewrite lee_fin. -rewrite (_ : (fun _ => _) = (fun n => \int[l x]_y (\int[k (x, y)]_z (f_ n z)%:E)))//; last first. +rewrite (_ : (fun _ => _) = + (fun n => \int[l x]_y (\int[k (x, y)]_z (f_ n z)%:E)))//; last first. by apply/funext => n; rewrite integral_kcomp_nnsfun. transitivity (\int[l x]_y lim (fun n => \int[k (x, y)]_z (f_ n z)%:E)). rewrite -monotone_convergence//; last 3 first. - move=> n. - apply: measurable_fun_integral_kernel => //. - - by move=> z; rewrite lee_fin. - - by apply/EFin_measurable_fun. - - move=> n y _. - by apply integral_ge0 => // z _; rewrite lee_fin. - - move=> y _ a b ab. - apply: ge0_le_integral => //. + - move=> n; apply: measurable_fun_integral_kernel => //. + + move=> U mU; have := measurable_kernel k _ mU. + by move=> /measurable_fun_prod1; exact. + + by move=> z; rewrite lee_fin. + + exact/EFin_measurable_fun. + - by move=> n y _; apply integral_ge0 => // z _; rewrite lee_fin. + - move=> y _ a b ab; apply: ge0_le_integral => //. + by move=> z _; rewrite lee_fin. + exact/EFin_measurable_fun. + by move=> z _; rewrite lee_fin. + exact/EFin_measurable_fun. - + move: ab => /ndf_ /lefP ab z _. - by rewrite lee_fin. -apply eq_integral => y _. -rewrite -monotone_convergence//; last 3 first. - move=> n; exact/EFin_measurable_fun. - by move=> n z _; rewrite lee_fin. - by move=> z _ a b /ndf_ /lefP; rewrite lee_fin. -apply eq_integral => z _. -apply/cvg_lim => //. -exact: f_f. + + by move: ab => /ndf_ /lefP ab z _; rewrite lee_fin. +apply eq_integral => y _; rewrite -monotone_convergence//; last 3 first. + - by move=> n; exact/EFin_measurable_fun. + - by move=> n z _; rewrite lee_fin. + - by move=> z _ a b /ndf_ /lefP; rewrite lee_fin. +by apply eq_integral => z _; apply/cvg_lim => //; exact: f_f. Qed. End integral_kcomp. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index bc0e9b5350..ccae7124bb 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -42,11 +42,12 @@ Local Open Scope ereal_scope. Lemma onem1' (R : numDomainType) (p : R) : (p + `1- p = 1)%R. Proof. by rewrite /onem addrCA subrr addr0. Qed. -Lemma onem_nonneg_proof (R : numDomainType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R) : - (0 <= `1-(p%:num))%R. +Lemma onem_nonneg_proof (R : numDomainType) (p : {nonneg R}) : + (p%:num <= 1 -> 0 <= `1-(p%:num))%R. Proof. by rewrite /onem/= subr_ge0. Qed. -Definition onem_nonneg (R : numDomainType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R) := +Definition onem_nonneg (R : numDomainType) (p : {nonneg R}) + (p1 : (p%:num <= 1)%R) := NngNum (onem_nonneg_proof p1). Lemma expR_ge0 (R : realType) (x : R) : (0 <= expR x)%R. @@ -69,10 +70,11 @@ Local Close Scope ring_scope. Let mbernoulli_setT : mbernoulli [set: _] = 1. Proof. rewrite /mbernoulli/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. -by rewrite /mscale/= !diracE !in_setT !mule1 -EFinD onem1'. +by rewrite /mscale/= !diracT !mule1 -EFinD onem1'. Qed. -HB.instance Definition _ := @isProbability.Build _ _ R mbernoulli mbernoulli_setT. +HB.instance Definition _ := + @isProbability.Build _ _ R mbernoulli mbernoulli_setT. Definition bernoulli := [the probability _ _ of mbernoulli]. @@ -89,8 +91,8 @@ Definition mscore t : {measure set _ -> \bar R} := Lemma mscoreE t U : mscore t U = if U == set0 then 0 else `| (f t)%:E |. Proof. rewrite /mscore/= /mscale/=; have [->|->] := set_unit U. - by rewrite eqxx diracE in_set0 mule0. -by rewrite diracE in_setT mule1 (negbTE (setT0 _)). + by rewrite eqxx dirac0 mule0. +by rewrite diracT mule1 (negbTE (setT0 _)). Qed. Lemma measurable_fun_mscore U : measurable_fun setT f -> @@ -164,18 +166,19 @@ HB.instance Definition _ i t := isMeasure.Build _ _ _ Lemma measurable_fun_k i U : measurable U -> measurable_fun setT (k mr i ^~ U). Proof. move=> /= mU; rewrite /k /=. -rewrite (_ : (fun x : T => _) = (fun x => if (i%:R)%:E <= x < (i.+1%:R)%:E then x else 0) \o - (mscore r ^~ U)) //. +rewrite (_ : (fun x : T => _) = + (fun x => if i%:R%:E <= x < i.+1%:R%:E then x else 0) \o (mscore r ^~ U)) //. apply: measurable_fun_comp => /=; last exact/measurable_fun_mscore. -pose A : _ -> \bar R := (fun x => x * (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set (\bar R)) x)%:E). +pose A : _ -> \bar R := + fun x => x * (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set (\bar R)) x)%:E. rewrite (_ : (fun x => _) = A); last first. apply/funext => x; rewrite /A; case: ifPn => ix. - by rewrite indicE/= mem_set ?mule1//. + by rewrite indicE/= mem_set ?mule1. by rewrite indicE/= memNset ?mule0// /= in_itv/=; exact/negP. rewrite {}/A. apply emeasurable_funM => /=; first exact: measurable_fun_id. apply/EFin_measurable_fun. -have mi : measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set (\bar R)). +have mi : measurable (`[i%:R%:E, i.+1%:R%:E[%classic : set (\bar R)). exact: emeasurable_itv. by rewrite (_ : \1__ = mindic R mi). Qed. @@ -188,12 +191,11 @@ HB.instance Definition _ i := Lemma mk_uub (i : nat) : measure_fam_uub (mk i). Proof. exists i.+1%:R => /= t; rewrite /k mscoreE setT_unit. -rewrite (_ : [set tt] == set0 = false); last first. - by apply/eqP => /seteqP[] /(_ tt) /(_ erefl). -by case: ifPn => // /andP[]. +by case: ifPn => //; case: ifPn => // _ /andP[]. Qed. -HB.instance Definition _ i := @Kernel_isFinite.Build _ _ _ _ R (mk i) (mk_uub i). +HB.instance Definition _ i := + @Kernel_isFinite.Build _ _ _ _ R (mk i) (mk_uub i). End score. End SCORE. @@ -207,7 +209,8 @@ Definition kscore (mr : measurable_fun setT r) Variable (mr : measurable_fun setT r). -Let measurable_fun_kscore U : measurable U -> measurable_fun setT (kscore mr ^~ U). +Let measurable_fun_kscore U : measurable U -> + measurable_fun setT (kscore mr ^~ U). Proof. by move=> /= _; exact: measurable_fun_mscore. Qed. HB.instance Definition _ := isKernel.Build _ _ T _ R @@ -228,11 +231,13 @@ apply/esym/cvg_lim => //. rewrite -(cvg_shiftn `|floor (fine `|(r t)%:E|)|%N.+1)/=. rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. apply/funext => n. -pose floor_r := widen_ord (leq_addl n `|floor `|r t| |.+1) (Ordinal (ltnSn `|floor `|r t| |)). +pose floor_r := widen_ord (leq_addl n `|floor `|r t| |.+1) + (Ordinal (ltnSn `|floor `|r t| |)). rewrite big_mkord (bigD1 floor_r)//= ifT; last first. rewrite lee_fin lte_fin; apply/andP; split. by rewrite natr_absz (@ger0_norm _ (floor `|r t|)) ?floor_ge0 ?floor_le. - by rewrite -addn1 natrD natr_absz (@ger0_norm _ (floor `|r t|)) ?floor_ge0 ?lt_succ_floor. + rewrite -addn1 natrD natr_absz. + by rewrite (@ger0_norm _ (floor `|r t|)) ?floor_ge0 ?lt_succ_floor. rewrite big1 ?adde0//= => j jk. rewrite ifF// lte_fin lee_fin. move: jk; rewrite neq_ltn/= => /orP[|] jr. @@ -241,11 +246,12 @@ move: jk; rewrite neq_ltn/= => /orP[|] jr. move: jr; rewrite -lez_nat => /le_trans; apply. by rewrite -[leRHS](@ger0_norm _ (floor `|r t|)) ?floor_ge0. - suff : (`|r t| < j%:R)%R by rewrite ltNge => /negbTE ->. - move: jr; rewrite -ltz_nat -(@ltr_int R) (@gez0_abs (floor `|r t|)) ?floor_ge0// ltr_int. - by rewrite -floor_lt_int. + move: jr; rewrite -ltz_nat -(@ltr_int R) (@gez0_abs (floor `|r t|)) ?floor_ge0//. + by rewrite ltr_int -floor_lt_int. Qed. -HB.instance Definition _ := @Kernel_isSFinite.Build _ _ _ _ _ (kscore mr) sfinite_kscore. +HB.instance Definition _ := + @Kernel_isSFinite.Build _ _ _ _ _ (kscore mr) sfinite_kscore. End kscore. @@ -507,12 +513,9 @@ Lemma iteE (f : X -> bool) (mf : measurable_fun setT f) Proof. apply/eq_measure/funext => U. rewrite /ite; unlock => /=. -rewrite /kcomp/=. -rewrite integral_dirac//=. -rewrite indicT. -rewrite mul1e. -rewrite -/(measure_add (ITE.kiteT k1 (x, f x)) - (ITE.kiteF k2 (x, f x))). +rewrite /kcomp/= integral_dirac//=. +rewrite indicT mul1e. +rewrite -/(measure_add (ITE.kiteT k1 (x, f x)) (ITE.kiteF k2 (x, f x))). rewrite measure_addE. rewrite /ITE.kiteT /ITE.kiteF/=. by case: ifPn => fx /=; rewrite /mzero ?(adde0,add0e). @@ -566,8 +569,7 @@ Lemma letin_retk x U : measurable U -> letin (ret mf) k x U = k (x, f x) U. Proof. -move=> mU; rewrite letinE retE integral_dirac//. - by rewrite indicE mem_set// mul1e. +move=> mU; rewrite letinE retE integral_dirac ?indicT ?mul1e//. have /measurable_fun_prod1 := measurable_kernel k _ mU. exact. Qed. @@ -584,13 +586,13 @@ End insn1. Module Notations. -Notation var1_of2 := (@measurable_fun_fst _ _ _ _). -Notation var2_of2 := (@measurable_fun_snd _ _ _ _). -Notation var1_of3 := (measurable_fun_comp (@measurable_fun_fst _ _ _ _) - (@measurable_fun_fst _ _ _ _)). -Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) - (@measurable_fun_fst _ _ _ _)). -Notation var3_of3 := (@measurable_fun_snd _ _ _ _). +Notation var1of2 := (@measurable_fun_fst _ _ _ _). +Notation var2of2 := (@measurable_fun_snd _ _ _ _). +Notation var1of3 := (measurable_fun_comp (@measurable_fun_fst _ _ _ _) + (@measurable_fun_fst _ _ _ _)). +Notation var2of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) + (@measurable_fun_fst _ _ _ _)). +Notation var3of3 := (@measurable_fun_snd _ _ _ _). Notation mR := Real_sort__canonical__measure_Measurable. Notation munit := Datatypes_unit__canonical__measure_Measurable. @@ -608,13 +610,13 @@ Let kcomp_scoreE d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) (score mf \; g) r U = `|f r|%:E * g (r, tt) U. Proof. rewrite /= /kcomp /kscore /= ge0_integral_mscale//=. -by rewrite integral_dirac// indicE in_setT mul1e. +by rewrite integral_dirac// indicT 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 (measurable_fun_comp mf var2_of2) + score (measurable_fun_comp mf var2of2) (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. @@ -625,8 +627,7 @@ Lemma score_score (f : R -> R) (g : R * unit -> R) letin (score mf) (score mg) x U = score (measurable_funM mf (measurable_fun_prod2 tt mg)) x U. Proof. -rewrite {1}/letin. -unlock. +rewrite {1}/letin; unlock. by rewrite kcomp_scoreE/= /mscale/= diracE normrM muleA EFinM. Qed. @@ -661,9 +662,7 @@ Section letinC. Variables (d d1 : _) (X : measurableType d) (Y : measurableType d1). Variables (R : realType) (d' : _) (Z : measurableType d'). -Notation var2_of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) - (@measurable_fun_fst _ _ _ _)). -Notation var3_of3 := (@measurable_fun_snd _ _ _ _). +Import Notations. Variables (t : R.-sfker Z ~> X) (t' : R.-sfker [the measurableType _ of (Z * Y)%type] ~> X) @@ -675,10 +674,10 @@ Variables (t : R.-sfker Z ~> X) Lemma letinC z A : measurable A -> letin t (letin u' - (ret (measurable_fun_pair var2_of3 var3_of3))) z A = + (ret (measurable_fun_pair var2of3 var3of3))) z A = letin u (letin t' - (ret (measurable_fun_pair var3_of3 var2_of3))) z A. + (ret (measurable_fun_pair var3of3 var2of3))) z A. Proof. move=> mA. rewrite !letinE. @@ -788,11 +787,8 @@ Lemma letin_sample_bernoulli (R : realType) (d d' : _) (T : measurableType d) r%:num%:E * u (x, true) y + (`1- (r%:num : R))%:E * u (x, false) y. Proof. rewrite letinE/= sampleE. -rewrite ge0_integral_measure_sum//. -rewrite 2!big_ord_recl/= big_ord0 adde0/=. -rewrite !ge0_integral_mscale//=. -rewrite !integral_dirac//=. -by rewrite indicE in_setT mul1e indicE in_setT mul1e. +rewrite ge0_integral_measure_sum// 2!big_ord_recl/= big_ord0 adde0/=. +by rewrite !ge0_integral_mscale//= !integral_dirac//= indicT 2!mul1e. Qed. Section sample_and_return. @@ -802,7 +798,7 @@ Variables (R : realType) (d : _) (T : measurableType d). Definition sample_and_return : R.-sfker T ~> _ := letin (sample (bernoulli p27)) (* T -> B *) - (ret var2_of2) (* T * B -> B *). + (ret var2of2) (* T * B -> B *). Lemma sample_and_returnE t U : sample_and_return t U = (2 / 7)%:E * \d_true U + (5 / 7)%:E * \d_false U. @@ -828,7 +824,7 @@ Definition sample_and_branch : R.-sfker T ~> mR R := letin (sample (bernoulli p27)) (* T -> B *) - (ite var2_of2 (ret k3) (ret k10)). + (ite var2of2 (ret k3) (ret k10)). Lemma sample_and_branchE t U : sample_and_branch t U = (2 / 7)%:E * \d_(3 : R) U + @@ -848,9 +844,9 @@ Hypothesis mh : measurable_fun setT h. Definition kstaton_bus : R.-sfker T ~> mbool := letin (sample (bernoulli p27)) (letin - (letin (ite var2_of2 (ret k3) (ret k10)) - (score (measurable_fun_comp mh var3_of3))) - (ret var2_of3)). + (letin (ite var2of2 (ret k3) (ret k10)) + (score (measurable_fun_comp mh var3of3))) + (ret var2of3)). Definition staton_bus := normalize kstaton_bus. @@ -897,14 +893,9 @@ Lemma staton_busE P (t : R) U : ((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. -rewrite normalizeE /=. -rewrite !kstaton_bus_poissonE. -rewrite diracE mem_set// mule1. -rewrite diracE mem_set// mule1. -rewrite ifF //. -apply/negbTE. -by rewrite gt_eqF// lte_fin addr_gt0// mulr_gt0//= ?divr_gt0// ?ltr0n// poisson_gt0// ltr0n. +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. Qed. End staton_bus_poisson. @@ -953,13 +944,9 @@ Lemma staton_bus_exponentialE P (t : R) U : (5 / 7)%:E * (exp1560 10)%:E * \d_false U) * N^-1%:E. Proof. rewrite /staton_bus. -rewrite normalizeE /=. -rewrite !kstaton_bus_exponentialE. -rewrite diracE mem_set// mule1. -rewrite diracE mem_set// mule1. -rewrite ifF //. -apply/negbTE. -by rewrite gt_eqF// lte_fin addr_gt0// mulr_gt0//= ?divr_gt0// ?ltr0n// exp_density_gt0 ?ltr0n. +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. diff --git a/theories/wip.v b/theories/wip.v index 334697b692..c31538faac 100644 --- a/theories/wip.v +++ b/theories/wip.v @@ -6,6 +6,11 @@ Require Import reals ereal topology normedtype sequences esum measure. Require Import lebesgue_measure fsbigop numfun lebesgue_integral exp kernel. Require Import trigo prob_lang. +(******************************************************************************) +(* Semantics of a programming language PPL using s-finite kernels (wip) *) +(* *) +(******************************************************************************) + Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -42,11 +47,6 @@ Proof. by rewrite /gauss01_density /gauss_density mul1r subr0 divr1. Qed. Definition mgauss01 (V : set R) := \int[lebesgue_measure]_(x in V) (gauss01_density x)%:E. -Lemma integral_gauss01_density : - \int[lebesgue_measure]_x (gauss01_density x)%:E = 1%E. -Proof. -Admitted. - Lemma measurable_fun_gauss_density m s : measurable_fun setT (gauss_density m s). Proof. @@ -69,6 +69,9 @@ Proof. by rewrite /mgauss01 integral_ge0//= => x _; rewrite lee_fin gauss_density_ge0. Qed. +Axiom integral_gauss01_density : + \int[lebesgue_measure]_x (gauss01_density x)%:E = 1%E. + Let mgauss01_sigma_additive : semi_sigma_additive mgauss01. Proof. move=> /= F mF tF mUF. @@ -121,8 +124,8 @@ Variable mu : {measure set mR R -> \bar R}. Definition staton_lebesgue : R.-sfker T ~> _ := letin (sample (@gauss01 R)) (letin - (score (measurable_fun_comp mf1 var2_of2)) - (ret var2_of3)). + (score (measurable_fun_comp mf1 var2of2)) + (ret var2of3)). Lemma staton_lebesgueE x U : measurable U -> staton_lebesgue x U = lebesgue_measure U. @@ -137,7 +140,7 @@ transitivity (\int[@mgauss01 R]_(y in U) (f1 y)%:E). apply: eq_integral => /= r _. rewrite letinE/= ge0_integral_mscale//= ger0_norm//; last first. by rewrite invr_ge0// gauss_density_ge0. - by rewrite integral_dirac// indicE in_setT mul1e retE/= diracE indicE. + by rewrite integral_dirac// indicT mul1e retE/= diracE indicE. transitivity (\int[lebesgue_measure]_(x in U) (gauss01_density x * f1 x)%:E). admit. transitivity (\int[lebesgue_measure]_(x in U) (\1_U x)%:E). From 527660b04e9cffcc2d8e4e5c1a1ae020eb593124 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Thu, 22 Sep 2022 00:47:42 +0900 Subject: [PATCH 21/54] hard constraint example --- theories/kernel.v | 40 ++++++++++++++++------------- theories/prob_lang.v | 61 ++++++++++++++++++++++++++++++++++---------- 2 files changed, 69 insertions(+), 32 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index d84168a0d0..205c373aee 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -405,6 +405,16 @@ Notation "R .-ker X ~> Y" := (kernel X Y R). Arguments measurable_kernel {_ _ _ _ _} _. +Lemma eq_kernel d d' (T : measurableType d) (T' : measurableType d') (R : realType) + (k1 k2 : R.-ker T ~> T') : + (forall x U, k1 x U = k2 x U) -> k1 = k2. +Proof. +move: k1 k2 => [m1 [[?]]] [m2 [[?]]] /= k12. +have ? : m1 = m2. + by apply/funext => t; apply/eq_measure; apply/funext => U; rewrite k12. +by subst m1; f_equal; f_equal; f_equal; apply/Prop_irrelevance. +Qed. + Section kseries. Variables (d d' : measure_display) (R : realType). Variables (X : measurableType d) (Y : measurableType d'). @@ -468,6 +478,16 @@ Notation "R .-sfker X ~> Y" := (sfinite_kernel X Y R). Arguments sfinite_subdef {_ _ _ _ _} _. +Lemma eq_sfkernel d d' (T : measurableType d) (T' : measurableType d') (R : realType) + (k1 k2 : R.-sfker T ~> T') : + (forall x U, k1 x U = k2 x U) -> k1 = k2. +Proof. +move: k1 k2 => [m1 [[?] [?]]] [m2 [[?] [?]]] /= k12. +have ? : m1 = m2. + by apply/funext => t; apply/eq_measure; apply/funext => U; rewrite k12. +by subst m1; f_equal; f_equal; f_equal; apply/Prop_irrelevance. +Qed. + HB.mixin Record SFiniteKernel_isFinite d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) := @@ -483,7 +503,8 @@ Notation "R .-fker X ~> Y" := (finite_kernel X Y R). Arguments measure_uub {_ _ _ _ _} _. HB.factory Record Kernel_isFinite d d' (X : measurableType d) - (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) of isKernel _ _ _ _ _ k := { + (Y : measurableType d') (R : realType) (k : X -> {measure set Y -> \bar R}) + of isKernel _ _ _ _ _ k := { measure_uub : measure_fam_uub k }. Section kzero. @@ -500,26 +521,9 @@ Proof. by move=> ?/=; exact: measurable_fun_cst. Qed. HB.instance Definition _ := @isKernel.Build _ _ X Y R kzero measurable_fun_kzero. -(*Let kernel_from_mzero_sfinite0 : exists2 s : (R.-ker T' ~> T)^nat, forall n, measure_fam_uub (s n) & - forall x U, measurable U -> kernel_from_mzero x U = kseries s x U. -Proof. -exists (fun=> [the _.-ker _ ~> _ of kernel_from_mzero]). - move=> _. - by exists 1%R => y; rewrite /= /mzero. -by move=> t U mU/=; rewrite /mseries nneseries0. -Qed. - -HB.instance Definition _ := - @isSFinite0.Build _ _ _ T R kernel_from_mzero - kernel_from_mzero_sfinite0.*) - Lemma kzero_uub : measure_fam_uub kzero. Proof. by exists 1%R => /= t; rewrite /mzero/=. Qed. -(*HB.instance Definition _ := - @SFiniteKernel_isFinite.Build _ _ _ T R kernel_from_mzero - kernel_from_mzero_uub.*) - End kzero. HB.builders Context d d' (X : measurableType d) (Y : measurableType d') diff --git a/theories/prob_lang.v b/theories/prob_lang.v index ccae7124bb..c66be7f257 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -584,6 +584,20 @@ Definition score (f : X -> R) (mf : measurable_fun setT f) := End insn1. +Section hard_constraint. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variable R : realType. + +Definition fail := + letin (score (@measurable_fun_cst _ _ X _ setT (0%R : R))) + (ret (@measurable_fun_cst _ _ _ Y setT point)). + +Lemma failE x U : fail x U = 0. +Proof. by rewrite /fail letinE ge0_integral_mscale//= normr0 mul0e. Qed. + +End hard_constraint. +Arguments fail {d d' X Y R}. + Module Notations. Notation var1of2 := (@measurable_fun_fst _ _ _ _). @@ -600,6 +614,20 @@ Notation mbool := Datatypes_bool__canonical__measure_Measurable. End Notations. +Section cst_fun. +Variables (R : realType) (d : _) (T : measurableType d). + +Definition kr (r : R) := @measurable_fun_cst _ _ T _ setT r. +Definition k3 : measurable_fun _ _ := kr 3%:R. +Definition k10 : measurable_fun _ _ := kr 10%:R. +Definition ktt := @measurable_fun_cst _ _ T _ setT tt. + +End cst_fun. +Arguments kr {R d T}. +Arguments k3 {R d T}. +Arguments k10 {R d T}. +Arguments ktt {d T}. + Section insn1_lemmas. Import Notations. Variables (R : realType) (d : _) (T : measurableType d). @@ -623,14 +651,30 @@ 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) x U : - letin (score mf) (score mg) x U = - score (measurable_funM mf (measurable_fun_prod2 tt mg)) x U. + (mg : measurable_fun setT g) : + letin (score mf) (score mg) = + score (measurable_funM mf (measurable_fun_prod2 tt mg)). Proof. +apply/eq_sfkernel => x U. rewrite {1}/letin; unlock. by rewrite kcomp_scoreE/= /mscale/= diracE normrM muleA EFinM. Qed. +Import Notations. + +(* hard constraints to express score below 1 *) +Lemma score_fail (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : + score (kr r%:num) = + letin (sample (bernoulli r1) : R.-pker T ~> _) + (ite var2of2 (ret ktt) fail). +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//= !indicT/= !mul1e. +by rewrite iteE//= iteE//= /mscale/= failE retE//= mule0 adde0 ger0_norm. +Qed. + End insn1_lemmas. Section letin_ite. @@ -769,17 +813,6 @@ Qed. End exponential. -Section cst_fun. -Variables (R : realType) (d : _) (T : measurableType d). - -Definition kn (n : nat) := @measurable_fun_cst _ _ T _ setT (n%:R : R). -Definition k3 : measurable_fun _ _ := kn 3. -Definition k10 : measurable_fun _ _ := kn 10. - -End cst_fun. -Arguments k3 {R d T}. -Arguments k10 {R d T}. - Lemma letin_sample_bernoulli (R : realType) (d d' : _) (T : measurableType d) (T' : measurableType d') (r : {nonneg R}) (r1 : (r%:num <= 1)%R) (u : R.-sfker [the measurableType _ of (T * bool)%type] ~> T') x y : From 0eff8f18ef4bbe4d9e1fc9cecb65d01655ee1cdd Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Thu, 22 Sep 2022 17:06:57 +0900 Subject: [PATCH 22/54] minor cleaning --- theories/kernel.v | 109 ++++++++++++++++----------- theories/prob_lang.v | 171 ++++++++++++++----------------------------- theories/wip.v | 4 +- 3 files changed, 124 insertions(+), 160 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 205c373aee..1c4a52ddfa 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -314,8 +314,8 @@ Definition finite_measure d (T : measurableType d) (R : realType) Definition sfinite_measure d (T : measurableType d) (R : realType) (mu : set T -> \bar R) := - exists2 mu_ : {measure set T -> \bar R}^nat, - forall n, finite_measure (mu_ n) & forall U, measurable U -> mu U = mseries mu_ 0 U. + exists2 s : {measure set T -> \bar R}^nat, + forall n, finite_measure (s n) & forall U, measurable U -> mu U = mseries s 0 U. Lemma finite_measure_sigma_finite d (T : measurableType d) (R : realType) (mu : {measure set T -> \bar R}) : @@ -337,18 +337,17 @@ Variable (mf : measurable_fun setT f). Lemma sfinite_fubini : \int[m1]_x \int[m2]_y f (x, y) = \int[m2]_y \int[m1]_x f (x, y). Proof. -have [m1_ fm1 m1E] := sfm1. -have [m2_ fm2 m2E] := sfm2. -rewrite [LHS](eq_measure_integral [the measure _ _ of mseries m1_ 0]); last first. +have [s1 fm1 m1E] := sfm1. +have [s2 fm2 m2E] := sfm2. +rewrite [LHS](eq_measure_integral [the measure _ _ of mseries s1 0]); last first. by move=> A mA _; rewrite m1E. -transitivity (\int[[the measure _ _ of mseries m1_ 0]]_x - \int[[the measure _ _ of mseries m2_ 0]]_y f (x, y)). - by apply eq_integral => x _; apply: eq_measure_integral => U mA _; rewrite m2E. -transitivity (\sum_(n x _; apply: eq_measure_integral => ? ? _; rewrite m2E. +transitivity (\sum_(n t _; exact: integral_ge0. rewrite [X in measurable_fun _ X](_ : _ = - fun x => \sum_(n \sum_(n x. by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. apply: ge0_emeasurable_fun_sum; first by move=> k x; exact: integral_ge0. @@ -356,30 +355,29 @@ transitivity (\sum_(n n _; apply eq_integral => x _. by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. -transitivity (\sum_(n n _. rewrite integral_sum//. move=> m; apply: measurable_fun_fubini_tonelli_F => //=. exact: finite_measure_sigma_finite. by move=> m x _; exact: integral_ge0. -transitivity (\sum_(n n _; apply eq_nneseries => m _. by rewrite fubini_tonelli//; exact: finite_measure_sigma_finite. -transitivity (\sum_(n n _ /=. rewrite ge0_integral_measure_series//. by move=> y _; exact: integral_ge0. apply: measurable_fun_fubini_tonelli_G => //=. by apply: finite_measure_sigma_finite; exact: fm1. -transitivity (\int[[the measure _ _ of mseries m2_ 0]]_y \sum_(n n; apply: measurable_fun_fubini_tonelli_G => //=. by apply: finite_measure_sigma_finite; exact: fm1. by move=> n y _; exact: integral_ge0. -transitivity (\int[[the measure _ _ of mseries m2_ 0]]_y - \int[[the measure _ _ of mseries m1_ 0]]_x f (x, y)). +transitivity (\int[mseries s2 0]_y \int[mseries s1 0]_x f (x, y)). apply eq_integral => y _. by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod2. -transitivity (\int[m2]_y \int[mseries m1_ 0]_x f (x, y)). +transitivity (\int[m2]_y \int[mseries s1 0]_x f (x, y)). by apply eq_measure_integral => A mA _ /=; rewrite m2E. by apply eq_integral => y _; apply eq_measure_integral => A mA _ /=; rewrite m1E. Qed. @@ -867,26 +865,13 @@ Arguments measurable_fun_xsection_integral {_ _ _ _ _} k l. Arguments measurable_fun_integral_finite_kernel {_ _ _ _ _} k l. Arguments measurable_fun_integral_sfinite_kernel {_ _ _ _ _} k l. -Section kprobability. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (P : probability Y R). - -Definition kprobability : X -> {measure set Y -> \bar R} := fun=> P. - -Let measurable_fun_kprobability U : measurable U -> - measurable_fun setT (kprobability ^~ U). -Proof. by move=> mU; exact: measurable_fun_cst. Qed. - -HB.instance Definition _ := - @isKernel.Build _ _ X Y R kprobability measurable_fun_kprobability. +Section pdirac. +Variables (d : _) (T : measurableType d) (R : realType). -Let kprobability_prob x : kprobability x setT = 1. -Proof. by rewrite /kprobability/= probability_setT. Qed. - -HB.instance Definition _ := - @Kernel_isProbability.Build _ _ X Y R kprobability kprobability_prob. +HB.instance Definition _ x := + isProbability.Build _ _ _ (@dirac _ T x R) (diracT R x). -End kprobability. +End pdirac. Section kdirac. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). @@ -894,7 +879,7 @@ Variables (R : realType) (f : X -> Y). Definition kdirac (mf : measurable_fun setT f) : X -> {measure set Y -> \bar R} := - fun x : X => [the measure _ _ of dirac (f x)]. + fun x => [the measure _ _ of dirac (f x)]. Hypothesis mf : measurable_fun setT f. @@ -917,6 +902,49 @@ HB.instance Definition _ := Kernel_isProbability.Build _ _ _ _ _ End kdirac. Arguments kdirac {d d' X Y R f}. +Section dist_salgebra_instance. +Variables (d : measure_display) (T : measurableType d) (R : realType). + +Let p0 : probability T R := [the probability T R of @dirac d T point R]. + +Definition prob_pointed := Pointed.Class + (Choice.Class gen_eqMixin (Choice.Class gen_eqMixin gen_choiceMixin)) p0. + +Canonical probability_eqType := EqType (probability T R) prob_pointed. +Canonical probability_choiceType := ChoiceType (probability T R) prob_pointed. +Canonical probability_ptType := PointedType (probability T R) prob_pointed. + +Definition mset (U : set T) (r : R) := [set mu : probability T R | mu U < r%:E]. + +Definition pset : set (set (probability T R)) := + [set mset U r | r in `[0%R,1%R]%classic & U in @measurable d T]. + +Definition pprobability := [the measurableType pset.-sigma of salgebraType pset]. + +End dist_salgebra_instance. + +Section kprobability. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Variables (R : realType) (P : probability Y R). + +Definition kprobability + : X -> {measure set Y -> \bar R} := fun=> P. + +Let measurable_fun_kprobability U : measurable U -> + measurable_fun setT (kprobability ^~ U). +Proof. by move=> mU; exact: measurable_fun_cst. Qed. + +HB.instance Definition _ := + @isKernel.Build _ _ X Y R kprobability measurable_fun_kprobability. + +Let kprobability_prob x : kprobability x setT = 1. +Proof. by rewrite /kprobability/= probability_setT. Qed. + +HB.instance Definition _ := + @Kernel_isProbability.Build _ _ X Y R kprobability kprobability_prob. + +End kprobability. + Section kadd. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). Variables (R : realType) (k1 k2 : R.-ker X ~> Y). @@ -1041,12 +1069,11 @@ Qed. Let mnormalize_ge0 x U : 0 <= mnormalize x U. Proof. by rewrite /mnormalize; case: ifPn => //; case: ifPn. Qed. -Lemma mnormalize_sigma_additive x : semi_sigma_additive (mnormalize x). +Let mnormalize_sigma_additive x : semi_sigma_additive (mnormalize x). Proof. move=> F mF tF mUF; rewrite /mnormalize/=. -case: ifPn => [_|_]. - exact: measure_semi_sigma_additive. -rewrite (_ : (fun n => _) = ((fun n => \sum_(0 <= i < n) f x (F i)) \* +case: ifPn => [_|_]; first exact: measure_semi_sigma_additive. +rewrite (_ : (fun _ => _) = ((fun n => \sum_(0 <= i < n) f x (F i)) \* cst ((fine (f x setT))^-1)%:E)); last first. by apply/funext => n; rewrite -ge0_sume_distrl. by apply: ereal_cvgMr => //; exact: measure_semi_sigma_additive. @@ -1055,7 +1082,7 @@ Qed. HB.instance Definition _ x := isMeasure.Build _ _ _ (mnormalize x) (mnormalize0 x) (mnormalize_ge0 x) (@mnormalize_sigma_additive x). -Lemma mnormalize1 x : mnormalize x setT = 1. +Let mnormalize1 x : mnormalize x setT = 1. Proof. rewrite /mnormalize; case: ifPn; first by rewrite probability_setT. rewrite negb_or => /andP[ft0 ftoo]. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index c66be7f257..6281d2a8a2 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -6,7 +6,7 @@ Require Import reals ereal topology normedtype sequences esum measure. Require Import lebesgue_measure fsbigop numfun lebesgue_integral exp kernel. (******************************************************************************) -(* Semantics of a programming language PPL using s-finite kernels *) +(* Semantics of a probabilistic programming language using s-finite kernels *) (* *) (* bernoulli r1 == Bernoulli probability with r1 a proof that *) (* r : {nonneg R} is smaller than 1 *) @@ -108,38 +108,35 @@ End mscore. (* decomposition of score into finite kernels *) Module SCORE. Section score. -Variables (R : realType) (d : _) (T : measurableType d). -Variables (r : T -> R). +Variables (d : _) (T : measurableType d) (R : realType) (f : T -> R). -Definition k (mr : measurable_fun setT r) (i : nat) : T -> set unit -> \bar R := - fun t U => - if i%:R%:E <= mscore r t U < i.+1%:R%:E then - mscore r t U +Definition k (mf : measurable_fun setT f) i t U := + if i%:R%:E <= mscore f t U < i.+1%:R%:E then + mscore f t U else 0. -Hypothesis mr : measurable_fun setT r. +Hypothesis mf : measurable_fun setT f. -Lemma k0 i t : k mr i t (set0 : set unit) = 0 :> \bar R. +Lemma k0 i t : k mf i t (set0 : set unit) = 0 :> \bar R. Proof. by rewrite /k measure0; case: ifP. Qed. -Lemma k_ge0 i t B : 0 <= k mr i t B. +Lemma k_ge0 i t B : 0 <= k mf i t B. Proof. by rewrite /k; case: ifP. Qed. -Lemma k_sigma_additive i t : semi_sigma_additive (k mr i t). +Lemma k_sigma_additive i t : semi_sigma_additive (k mf i t). Proof. move=> /= F mF tF mUF; rewrite /k /=. -have [F0|] := eqVneq (\bigcup_n F n) set0. +have [F0|UF0] := eqVneq (\bigcup_n F n) set0. rewrite F0 measure0 (_ : (fun _ => _) = cst 0). by case: ifPn => _; exact: cvg_cst. apply/funext => k; rewrite big1// => n _. by move: F0 => /bigcup0P -> //; rewrite measure0; case: ifPn. -move=> UF0; move: (UF0). -move=> /eqP/bigcup0P/existsNP[m /not_implyP[_ /eqP Fm0]]. +move: (UF0) => /eqP/bigcup0P/existsNP[m /not_implyP[_ /eqP Fm0]]. rewrite [in X in _ --> X]mscoreE (negbTE UF0). rewrite -(cvg_shiftn m.+1)/=. case: ifPn => ir. - rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. + rewrite (_ : (fun _ => _) = cst `|(f t)%:E|); first exact: cvg_cst. apply/funext => n. rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn m))))//=. rewrite [in X in X + _]mscoreE (negbTE Fm0) ir big1 ?adde0// => /= j jk. @@ -152,8 +149,7 @@ rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. apply/funext => n. rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn m))))//=. rewrite [in X in if X then _ else _]mscoreE (negbTE Fm0) (negbTE ir) add0e. -rewrite big1//= => j jm. -rewrite mscoreE; have /eqP -> : F j == set0. +rewrite big1//= => j jm; rewrite mscoreE; have /eqP -> : F j == set0. have [/eqP//|Fjtt] := set_unit (F j). move/trivIsetP : tF => /(_ j m Logic.I Logic.I jm). by rewrite Fjtt setTI => /eqP; rewrite (negbTE Fm0). @@ -161,41 +157,35 @@ by rewrite eqxx; case: ifP. Qed. HB.instance Definition _ i t := isMeasure.Build _ _ _ - (k mr i t) (k0 i t) (k_ge0 i t) (@k_sigma_additive i t). + (k mf i t) (k0 i t) (k_ge0 i t) (@k_sigma_additive i t). -Lemma measurable_fun_k i U : measurable U -> measurable_fun setT (k mr i ^~ U). +Lemma measurable_fun_k i U : measurable U -> measurable_fun setT (k mf i ^~ U). Proof. -move=> /= mU; rewrite /k /=. -rewrite (_ : (fun x : T => _) = - (fun x => if i%:R%:E <= x < i.+1%:R%:E then x else 0) \o (mscore r ^~ U)) //. +move=> /= mU; rewrite /k /= (_ : (fun x => _) = + (fun x => if i%:R%:E <= x < i.+1%:R%:E then x else 0) \o (mscore f ^~ U)) //. apply: measurable_fun_comp => /=; last exact/measurable_fun_mscore. -pose A : _ -> \bar R := - fun x => x * (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set (\bar R)) x)%:E. -rewrite (_ : (fun x => _) = A); last first. - apply/funext => x; rewrite /A; case: ifPn => ix. - by rewrite indicE/= mem_set ?mule1. +rewrite (_ : (fun x => _) = (fun x => x * + (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set _) x)%:E)); last first. + apply/funext => x; case: ifPn => ix; first by rewrite indicE/= mem_set ?mule1. by rewrite indicE/= memNset ?mule0// /= in_itv/=; exact/negP. -rewrite {}/A. apply emeasurable_funM => /=; first exact: measurable_fun_id. apply/EFin_measurable_fun. -have mi : measurable (`[i%:R%:E, i.+1%:R%:E[%classic : set (\bar R)). - exact: emeasurable_itv. -by rewrite (_ : \1__ = mindic R mi). +by rewrite (_ : \1__ = mindic R (emeasurable_itv R i)). Qed. -Definition mk i t := [the measure _ _ of k mr i t]. +Definition mk i t := [the measure _ _ of k mf i t]. HB.instance Definition _ i := - isKernel.Build _ _ _ _ R (mk i) (measurable_fun_k i). + isKernel.Build _ _ _ _ _ (mk i) (measurable_fun_k i). -Lemma mk_uub (i : nat) : measure_fam_uub (mk i). +Lemma mk_uub i : measure_fam_uub (mk i). Proof. exists i.+1%:R => /= t; rewrite /k mscoreE setT_unit. by case: ifPn => //; case: ifPn => // _ /andP[]. Qed. HB.instance Definition _ i := - @Kernel_isFinite.Build _ _ _ _ R (mk i) (mk_uub i). + Kernel_isFinite.Build _ _ _ _ _ (mk i) (mk_uub i). End score. End SCORE. @@ -257,9 +247,12 @@ End kscore. (* decomposition of ite into s-finite kernels *) Module ITE. -Section kiteT. +Section ite. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k : R.-ker X ~> Y). +Variable R : realType. + +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]. @@ -268,7 +261,7 @@ Let measurable_fun_kiteT U : measurable U -> measurable_fun setT (kiteT ^~ U). Proof. move=> /= mcU; rewrite /kiteT. rewrite (_ : (fun _ => _) = (fun x => if x.2 then k x.1 U - else [the {measure set Y -> \bar R} of mzero] U)); last first. + else [the {measure set Y -> \bar R} of mzero] U)); last first. by apply/funext => -[t b]/=; case: ifPn. apply: (@measurable_fun_if_pair _ _ _ _ (k ^~ U) (fun=> mzero U)). exact/measurable_kernel. @@ -276,12 +269,12 @@ exact: measurable_fun_cst. Qed. #[export] -HB.instance Definition _ := isKernel.Build _ _ _ _ R kiteT measurable_fun_kiteT. +HB.instance Definition _ := isKernel.Build _ _ _ _ _ + kiteT measurable_fun_kiteT. End kiteT. Section sfkiteT. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k : R.-sfker X ~> Y). +Variable k : R.-sfker X ~> Y. Let sfinite_kiteT : exists2 k_ : (R.-ker _ ~> _)^nat, forall n, measure_fam_uub (k_ n) & @@ -292,34 +285,17 @@ have [k_ hk /=] := sfinite k. exists (fun n => [the _.-ker _ ~> _ of kiteT (k_ n)]) => /=. move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). by exists r%:num => /= -[x []]; rewrite /kiteT//= /mzero//. -move=> [x b] U mU; rewrite /kiteT; case: ifPn => hb. - by rewrite hk. +move=> [x b] U mU; rewrite /kiteT; case: ifPn => hb; first by rewrite hk. by rewrite /mseries nneseries0. Qed. -(*Let sfinite_kiteT : exists k_ : (R.-fker _ ~> _)^nat, - forall x U, measurable U -> - kiteT k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. -have [k_ hk /=] := sfinite k. -exists (fun n => [the _.-fker _ ~> _ of kiteT (k_ n)]) => b U mU. -rewrite /kiteT; case: ifPn => hb. - rewrite /mseries hk//= /mseries. - apply: eq_nneseries => n _. - by rewrite /kiteT hb. -rewrite /= /mseries nneseries0// => n _. -by rewrite /kiteT (negbTE hb). -Qed.*) - -(* NB: we could also want to use Kernel_isSFinite *) #[export] HB.instance Definition _ t := @Kernel_isSFinite_subdef.Build _ _ _ _ _ (kiteT k) sfinite_kiteT. End sfkiteT. Section fkiteT. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k : R.-fker X ~> Y). +Variable k : R.-fker X ~> Y. Let kiteT_uub : measure_fam_uub (kiteT k). Proof. @@ -329,12 +305,12 @@ by rewrite /= /mzero. Qed. #[export] -HB.instance Definition _ t := Kernel_isFinite.Build _ _ _ _ R (kiteT k) kiteT_uub. +HB.instance Definition _ t := Kernel_isFinite.Build _ _ _ _ _ + (kiteT k) kiteT_uub. End fkiteT. Section kiteF. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k : R.-ker X ~> Y). +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]. @@ -342,22 +318,22 @@ Definition kiteF : X * bool -> {measure set Y -> \bar R} := Let measurable_fun_kiteF U : measurable U -> measurable_fun setT (kiteF ^~ U). Proof. move=> /= mcU; rewrite /kiteF. -rewrite (_ : (fun x => _) = (fun x => if x.2 then [the measure _ _ of mzero] U else k x.1 U)); last first. - apply/funext => -[t b]/=. - by rewrite if_neg//; case: ifPn. +rewrite (_ : (fun x => _) = (fun x => if x.2 then + [the measure _ _ of mzero] U else k x.1 U)); last first. + by apply/funext => -[t b]/=; rewrite if_neg//; case: ifPn. apply: (@measurable_fun_if_pair _ _ _ _ (fun=> mzero U) (k ^~ U)). exact: measurable_fun_cst. exact/measurable_kernel. Qed. #[export] -HB.instance Definition _ := isKernel.Build _ _ _ _ R kiteF measurable_fun_kiteF. +HB.instance Definition _ := isKernel.Build _ _ _ _ _ + kiteF measurable_fun_kiteF. End kiteF. Section sfkiteF. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k : R.-sfker X ~> Y). +Variable k : R.-sfker X ~> Y. Let sfinite_kiteF : exists2 k_ : (R.-ker _ ~> _)^nat, forall n, measure_fam_uub (k_ n) & @@ -368,23 +344,10 @@ have [k_ hk /=] := sfinite k. exists (fun n => [the _.-ker _ ~> _ of kiteF (k_ n)]) => /=. move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). by exists r%:num => /= -[x []]; rewrite /kiteF//= /mzero//. -move=> [x b] U mU; rewrite /kiteF; case: ifPn => hb. - by rewrite hk. +move=> [x b] U mU; rewrite /kiteF; case: ifPn => hb; first by rewrite hk. by rewrite /mseries nneseries0. Qed. -(*Let sfinite_kiteF : exists k_ : (R.-fker _ ~> _)^nat, - forall x U, measurable U -> - kiteF k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. -Proof. -have [k_ hk] := sfinite k. -exists (fun n => [the finite_kernel _ _ _ of kiteF (k_ n)]) => b U mU. -rewrite /= /kiteF /=; case: ifPn => hb. - by rewrite /mseries hk//= /mseries/=. -by rewrite /= /mseries nneseries0. -Qed. -*) - #[export] HB.instance Definition _ := @Kernel_isSFinite_subdef.Build _ _ _ _ _ (kiteF k) sfinite_kiteF. @@ -392,26 +355,21 @@ HB.instance Definition _ := @Kernel_isSFinite_subdef.Build _ _ _ _ _ End sfkiteF. Section fkiteF. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k : R.-fker X ~> Y). +Variable k : R.-fker X ~> Y. Let kiteF_uub : measure_fam_uub (kiteF k). Proof. have /measure_fam_uubP[M hM] := measure_uub k. -exists M%:num => /= -[]; rewrite /kiteF/= => t. -by case => //=; rewrite /mzero. +by exists M%:num => /= -[]; rewrite /kiteF/= => t; case => //=; rewrite /mzero. Qed. #[export] -HB.instance Definition _ := Kernel_isFinite.Build _ _ _ _ R (kiteF k) kiteF_uub. +HB.instance Definition _ := Kernel_isFinite.Build _ _ _ _ _ + (kiteF k) kiteF_uub. End fkiteF. - -(*Module Exports. -HB.reexport. -End Exports.*) +End ite. End ITE. -(*Export ITE.Exports.*) Section ite. Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). @@ -423,10 +381,10 @@ Definition mite (mf : measurable_fun setT f) : T -> set T' -> \bar R := Variables mf : measurable_fun setT f. Let mite0 t : mite mf t set0 = 0. -Proof. by rewrite /mite; case: ifPn => //. Qed. +Proof. by rewrite /mite; case: ifPn. Qed. -Let mite_ge0 t (U : set _) : 0 <= mite mf t U. -Proof. by rewrite /mite; case: ifPn => //. Qed. +Let mite_ge0 t U : 0 <= mite mf t U. +Proof. by rewrite /mite; case: ifPn. Qed. Let mite_sigma_additive t : semi_sigma_additive (mite mf t). Proof. @@ -446,27 +404,6 @@ Definition kite := End ite. -(* wip *) -Section dist_salgebra_instance. -Variables (d : measure_display) (T : measurableType d) (R : realType). -Variables p0 : probability T R. - -Definition prob_pointed := Pointed.Class - (Choice.Class gen_eqMixin (Choice.Class gen_eqMixin gen_choiceMixin)) p0. - -Canonical probability_eqType := EqType (probability T R) prob_pointed. -Canonical probability_choiceType := ChoiceType (probability T R) prob_pointed. -Canonical probability_ptType := PointedType (probability T R) prob_pointed. - -Definition mset (U : set T) (r : R) := [set mu : probability T R | mu U < r%:E]. - -Definition pset : set (set (probability T R)) := - [set mset U r | r in `[0%R,1%R]%classic & U in @measurable d T]. - -Definition sset := [the measurableType pset.-sigma of salgebraType pset]. - -End dist_salgebra_instance. - Section insn2. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). Variable R : realType. diff --git a/theories/wip.v b/theories/wip.v index c31538faac..3b8bd5be75 100644 --- a/theories/wip.v +++ b/theories/wip.v @@ -7,8 +7,8 @@ Require Import lebesgue_measure fsbigop numfun lebesgue_integral exp kernel. Require Import trigo prob_lang. (******************************************************************************) -(* Semantics of a programming language PPL using s-finite kernels (wip) *) -(* *) +(* Semantics of a probabilistic programming language using s-finite kernels *) +(* (wip) *) (******************************************************************************) Set Implicit Arguments. From 64040c823fa15cba1d894ec0403cbba78695a2b6 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Fri, 7 Oct 2022 20:47:08 +0900 Subject: [PATCH 23/54] gen sample --- theories/kernel.v | 65 ++++++++++++++++++++++++++++++++++++++------ theories/prob_lang.v | 4 +-- 2 files changed, 59 insertions(+), 10 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 1c4a52ddfa..4f0221289e 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -60,6 +60,30 @@ Qed. End probability_lemmas. (* /PR 516 in progress *) +(* PR 765 in progress *) +Require Import set_interval. + +Module ErealGenInftyO. +Section erealgeninftyo. +Variable R : realType. + +Definition G := [set A : set \bar R | exists x, A = `]-oo, x[%classic]. + +Lemma measurableE : emeasurable (R.-ocitv.-measurable) = G.-sigma.-measurable. +Proof. +rewrite ErealGenCInfty.measurableE eqEsubset; split => A. + apply: smallest_sub; first exact: smallest_sigma_algebra. + move=> _ [x ->]; rewrite -[X in _.-measurable X]setCK; apply: measurableC. + by apply: sub_sigma_algebra; exists x; rewrite setCitvr. +apply: smallest_sub; first exact: smallest_sigma_algebra. +move=> x Gx; rewrite -(setCK x); apply: measurableC; apply: sub_sigma_algebra. +by case: Gx => y ->; exists y; rewrite setCitvl. +Qed. + +End erealgeninftyo. +End ErealGenInftyO. +(* /PR 765 in progress *) + (* TODO: PR*) Lemma setT0 (T : pointedType) : setT != set0 :> set T. Proof. by apply/eqP => /seteqP[] /(_ point) /(_ Logic.I). Qed. @@ -925,23 +949,48 @@ End dist_salgebra_instance. Section kprobability. Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (P : probability Y R). +Variables (R : realType) (P : X -> pprobability Y R). + +Definition kprobability (mP : measurable_fun setT P) + : X -> {measure set Y -> \bar R} := P. -Definition kprobability - : X -> {measure set Y -> \bar R} := fun=> P. +Hypothesis mP : measurable_fun setT P. Let measurable_fun_kprobability U : measurable U -> - measurable_fun setT (kprobability ^~ U). -Proof. by move=> mU; exact: measurable_fun_cst. Qed. + measurable_fun setT (kprobability mP ^~ U). +Proof. +move=> mU. +apply: (measurability (ErealGenInftyO.measurableE R)) => A /= -[B [x ->]]. +rewrite setTI => <-; case: x => [r| |]; last 2 first. + - rewrite (_ : _ @^-1` _ = setT)//; apply/seteqP; split => // x _ /=. + by rewrite in_itv/= (le_lt_trans (probability_le1 _ _)) ?ltey. + - rewrite (_ : _ @^-1` _ = set0)//; apply/seteqP; split => // x /=. + by rewrite in_itv/=; apply/negP; rewrite -leNgt leNye. +rewrite (_ : _ @^-1` _ = (fun x => P x U < r%:E)); last first. + by apply/funext => x; rewrite /= in_itv. +rewrite [X in measurable X](_ : _ = P @^-1` [set mu | mu U < r%:E]) //. +have [r0|r0] := leP 0%R r; last first. + rewrite [X in _ @^-1` X](_ : _ = set0) ?preimage_set0//. + apply/seteqP; split => // x/=. + by apply/negP; rewrite -leNgt (@le_trans _ _ 0)// lee_fin ltW. +have [r1|r1] := leP r 1%R; last first. + rewrite [X in _ @^-1` X](_ : _ = setT) ?preimage_setT//. + apply/seteqP; split => // x/= _. + by rewrite (le_lt_trans (probability_le1 _ _)). +move: mP => /(_ measurableT)/(_ [set mu | mu U < r%:E]). +rewrite setTI; apply; apply: sub_sigma_algebra; exists r => /=. + by rewrite in_itv/= r0. +by exists U. +Qed. HB.instance Definition _ := - @isKernel.Build _ _ X Y R kprobability measurable_fun_kprobability. + @isKernel.Build _ _ X Y R (kprobability mP) measurable_fun_kprobability. -Let kprobability_prob x : kprobability x setT = 1. +Let kprobability_prob x : kprobability mP x setT = 1. Proof. by rewrite /kprobability/= probability_setT. Qed. HB.instance Definition _ := - @Kernel_isProbability.Build _ _ X Y R kprobability kprobability_prob. + @Kernel_isProbability.Build _ _ X Y R (kprobability mP) kprobability_prob. End kprobability. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 6281d2a8a2..640afcaedc 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -411,8 +411,8 @@ Variable R : realType. Definition ret (f : X -> Y) (mf : measurable_fun setT f) := locked [the R.-sfker X ~> Y of kdirac mf]. -Definition sample (P : probability Y R) := - locked [the R.-pker X ~> Y of kprobability P] . +Definition sample (P : pprobability Y R) := + locked [the R.-pker X ~> Y of kprobability (measurable_fun_cst P)] . Definition normalize (k : R.-sfker X ~> Y) P x := locked [the probability _ _ of mnormalize k P x]. From 6dd1dc2c2d9871a8a1b80537f588cb771404cf75 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 26 Oct 2022 11:46:22 +0900 Subject: [PATCH 24/54] upd wrt master --- theories/kernel.v | 46 +++++++++++++++++++++----------------------- theories/prob_lang.v | 6 +++--- theories/wip.v | 4 ++-- 3 files changed, 27 insertions(+), 29 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 4f0221289e..950805905c 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -377,19 +377,18 @@ transitivity (\sum_(n k x; exact: integral_ge0. move=> k; apply: measurable_fun_fubini_tonelli_F => //=. exact: finite_measure_sigma_finite. - apply: eq_nneseries => n _; apply eq_integral => x _. + apply: eq_eseries => n _; apply eq_integral => x _. by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. transitivity (\sum_(n n _. - rewrite integral_sum//. + apply eq_eseries => n _; rewrite integral_sum//. move=> m; apply: measurable_fun_fubini_tonelli_F => //=. exact: finite_measure_sigma_finite. by move=> m x _; exact: integral_ge0. transitivity (\sum_(n n _; apply eq_nneseries => m _. + apply eq_eseries => n _; apply eq_eseries => m _. by rewrite fubini_tonelli//; exact: finite_measure_sigma_finite. transitivity (\sum_(n n _ /=. rewrite ge0_integral_measure_series//. + apply eq_eseries => n _ /=. rewrite ge0_integral_measure_series//. by move=> y _; exact: integral_ge0. apply: measurable_fun_fubini_tonelli_G => //=. by apply: finite_measure_sigma_finite; exact: fm1. @@ -560,8 +559,8 @@ exists (fun n => if n is O then [the _.-ker _ ~> _ of k] else by case => [|_]; [exact: measure_uub|exact: kzero_uub]. move=> t U mU/=; rewrite /mseries. rewrite (nneseries_split 1%N)// big_ord_recl/= big_ord0 adde0. -rewrite ereal_series (@eq_nneseries _ _ (fun=> 0%E)); last by case. -by rewrite nneseries0// adde0. +rewrite ereal_series (@eq_eseries _ _ (fun=> 0%E)); last by case. +by rewrite eseries0// adde0. Qed. HB.instance Definition _ := @Kernel_isSFinite_subdef.Build d d' X Y R k sfinite_finite. @@ -824,20 +823,19 @@ rewrite (_ : (fun x => _) = - by move=> y _ m n mn; rewrite lee_fin; exact/lefP/ndk_. apply: measurable_fun_elim_sup => n. rewrite [X in measurable_fun _ X](_ : _ = (fun x => \int[l x]_y - (\sum_(r <- fset_set (range (k_ n)))(*TODO: upd when PR 743 is merged*) - r * \1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. + (\sum_(r \in range (k_ n)) + r * \1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. by apply/funext => x; apply: eq_integral => y _; rewrite fimfunE. -rewrite [X in measurable_fun _ X](_ : _ = (fun x => - \sum_(r <- fset_set (range (k_ n)))(*TODO: upd when PR 743 is merged*) +rewrite [X in measurable_fun _ X](_ : _ = (fun x => \sum_(r \in range (k_ n)) (\int[l x]_y (r * \1_(k_ n @^-1` [set r]) (x, y))%:E))); last first. - apply/funext => x; rewrite -ge0_integral_sum//. - - by apply: eq_integral => y _; rewrite sumEFin. + apply/funext => x; rewrite -ge0_integral_fsum//. + - by apply: eq_integral => y _; rewrite -fsumEFin. - move=> r. apply/EFin_measurable_fun/measurable_funrM/measurable_fun_prod1 => /=. rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r))//. exact/measurable_funP. - by move=> m y _; rewrite nnfun_muleindic_ge0. -apply emeasurable_fun_sum => r. +apply: emeasurable_fun_fsum => // r. rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * \int[l x]_y (\1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. apply/funext => x; under eq_integral do rewrite EFinM. @@ -1036,7 +1034,7 @@ rewrite -/(measure_add (k1 x) (k2 x)) measure_addE. rewrite /mseries. rewrite hk1//= hk2//= /mseries. rewrite -nneseriesD//. -apply: eq_nneseries => n _. +apply: eq_eseries => n _. by rewrite -/(measure_add (f1 n x) (f2 n x)) measure_addE. Qed. @@ -1248,7 +1246,7 @@ Definition mkcomp : X -> {measure set Z -> \bar R} := End kcomp_is_measure. -Notation "l \; k" := (mkcomp l k). +Notation "l \; k" := (mkcomp l k) : ereal_scope. Module KCOMP_FINITE_KERNEL. @@ -1322,7 +1320,7 @@ transitivity (([the _.-ker _ ~> _ of kseries l_] \; rewrite /= /kcomp/= integral_sum//=; last first. by move=> n; have /measurable_fun_prod1 := measurable_kernel (k_ n) _ mU; exact. transitivity (\sum_(i i _; rewrite integral_kseries//. + apply: eq_eseries => i _; rewrite integral_kseries//. by have /measurable_fun_prod1 := measurable_kernel (k_ i) _ mU; exact. rewrite /mseries -hkl/=. rewrite (_ : setT = setT `*`` (fun=> setT)); last by apply/seteqP; split. @@ -1431,8 +1429,8 @@ Qed. Let integral_kcomp_nnsfun x (f : {nnsfun Z >-> R}) : \int[(l \; k) x]_z (f z)%:E = \int[l x]_y (\int[k (x, y)]_z (f z)%:E). Proof. -under [in LHS]eq_integral do rewrite fimfunE -sumEFin. -rewrite ge0_integral_sum//; last 2 first. +under [in LHS]eq_integral do rewrite fimfunE -fsumEFin//. +rewrite ge0_integral_fsum//; last 2 first. - move=> r; apply/EFin_measurable_fun/measurable_funrM. have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. by rewrite (_ : \1__ = mindic R fr). @@ -1440,27 +1438,27 @@ rewrite ge0_integral_sum//; last 2 first. under [in RHS]eq_integral. move=> y _. under eq_integral. - by move=> z _; rewrite fimfunE -sumEFin; over. - rewrite /= ge0_integral_sum//; last 2 first. + by move=> z _; rewrite fimfunE -fsumEFin//; over. + rewrite /= ge0_integral_fsum//; last 2 first. - move=> r; apply/EFin_measurable_fun/measurable_funrM. have fr : measurable (f @^-1` [set r]) by exact/measurable_sfunP. by rewrite (_ : \1__ = mindic R fr). - by move=> r z _; rewrite EFinM nnfun_muleindic_ge0. - under eq_bigr. + under eq_fsbigr. move=> r _. rewrite (integralM_indic _ (fun r => f @^-1` [set r]))//; last first. by move=> r0; rewrite preimage_nnfun0. rewrite integral_indic// setIT. over. over. -rewrite /= ge0_integral_sum//; last 2 first. +rewrite /= ge0_integral_fsum//; last 2 first. - move=> r; apply: measurable_funeM. have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). by move=> /measurable_fun_prod1; exact. - move=> n y _. have := mulemu_ge0 (fun n => f @^-1` [set n]). by apply; exact: preimage_nnfun0. -apply eq_bigr => r _. +apply eq_fsbigr => r _. rewrite (integralM_indic _ (fun r => f @^-1` [set r]))//; last first. exact: preimage_nnfun0. rewrite /= integral_kcomp_indic; last exact/measurable_sfunP. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 640afcaedc..fe4ae3a454 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -215,7 +215,7 @@ Proof. rewrite /=. exists (fun i => [the R.-fker _ ~> _ of mk mr i]) => /= t U mU. rewrite /mseries /kscore/= mscoreE; case: ifPn => [/eqP U0|U0]. - by apply/esym/nneseries0 => i _; rewrite U0 measure0. + by apply/esym/eseries0 => i _; rewrite U0 measure0. rewrite /mk /= /k /= mscoreE (negbTE U0). apply/esym/cvg_lim => //. rewrite -(cvg_shiftn `|floor (fine `|(r t)%:E|)|%N.+1)/=. @@ -286,7 +286,7 @@ exists (fun n => [the _.-ker _ ~> _ of kiteT (k_ n)]) => /=. move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). by exists r%:num => /= -[x []]; rewrite /kiteT//= /mzero//. move=> [x b] U mU; rewrite /kiteT; case: ifPn => hb; first by rewrite hk. -by rewrite /mseries nneseries0. +by rewrite /mseries eseries0. Qed. #[export] @@ -345,7 +345,7 @@ exists (fun n => [the _.-ker _ ~> _ of kiteF (k_ n)]) => /=. move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). by exists r%:num => /= -[x []]; rewrite /kiteF//= /mzero//. move=> [x b] U mU; rewrite /kiteF; case: ifPn => hb; first by rewrite hk. -by rewrite /mseries nneseries0. +by rewrite /mseries eseries0. Qed. #[export] diff --git a/theories/wip.v b/theories/wip.v index 3b8bd5be75..22a13a661d 100644 --- a/theories/wip.v +++ b/theories/wip.v @@ -45,7 +45,7 @@ Lemma gauss01_densityE x : Proof. by rewrite /gauss01_density /gauss_density mul1r subr0 divr1. Qed. Definition mgauss01 (V : set R) := - \int[lebesgue_measure]_(x in V) (gauss01_density x)%:E. + (\int[lebesgue_measure]_(x in V) (gauss01_density x)%:E)%E. Lemma measurable_fun_gauss_density m s : measurable_fun setT (gauss_density m s). @@ -70,7 +70,7 @@ by rewrite /mgauss01 integral_ge0//= => x _; rewrite lee_fin gauss_density_ge0. Qed. Axiom integral_gauss01_density : - \int[lebesgue_measure]_x (gauss01_density x)%:E = 1%E. + (\int[lebesgue_measure]_x (gauss01_density x)%:E = 1%E)%E. Let mgauss01_sigma_additive : semi_sigma_additive mgauss01. Proof. From e60793caa858086505de2396235f688f809c053e Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 26 Oct 2022 14:53:53 +0900 Subject: [PATCH 25/54] shorten measurable_fun_kprobability --- theories/kernel.v | 68 +++++++++++++++-------------------------------- 1 file changed, 22 insertions(+), 46 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 950805905c..fbf289e385 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -21,6 +21,9 @@ Require Import lebesgue_measure fsbigop numfun lebesgue_integral. (* R.-fker X ~> Y == finite kernel *) (* R.-spker X ~> Y == subprobability kernel *) (* R.-pker X ~> Y == probability kernel *) +(* mset U r == the set probability measures mu such that mu U < r *) +(* pset == the sets mset U r with U measurable and r \in [0,1] *) +(* pprobability == the measurable type generated by pset *) (* kprobability m == kernel defined by a probability measure *) (* kdirac mf == kernel defined by a measurable function *) (* kadd k1 k2 == lifting of the addition of measures to kernels *) @@ -60,30 +63,6 @@ Qed. End probability_lemmas. (* /PR 516 in progress *) -(* PR 765 in progress *) -Require Import set_interval. - -Module ErealGenInftyO. -Section erealgeninftyo. -Variable R : realType. - -Definition G := [set A : set \bar R | exists x, A = `]-oo, x[%classic]. - -Lemma measurableE : emeasurable (R.-ocitv.-measurable) = G.-sigma.-measurable. -Proof. -rewrite ErealGenCInfty.measurableE eqEsubset; split => A. - apply: smallest_sub; first exact: smallest_sigma_algebra. - move=> _ [x ->]; rewrite -[X in _.-measurable X]setCK; apply: measurableC. - by apply: sub_sigma_algebra; exists x; rewrite setCitvr. -apply: smallest_sub; first exact: smallest_sigma_algebra. -move=> x Gx; rewrite -(setCK x); apply: measurableC; apply: sub_sigma_algebra. -by case: Gx => y ->; exists y; rewrite setCitvl. -Qed. - -End erealgeninftyo. -End ErealGenInftyO. -(* /PR 765 in progress *) - (* TODO: PR*) Lemma setT0 (T : pointedType) : setT != set0 :> set T. Proof. by apply/eqP => /seteqP[] /(_ point) /(_ Logic.I). Qed. @@ -925,7 +904,7 @@ End kdirac. Arguments kdirac {d d' X Y R f}. Section dist_salgebra_instance. -Variables (d : measure_display) (T : measurableType d) (R : realType). +Variables (d : _) (T : measurableType d) (R : realType). Let p0 : probability T R := [the probability T R of @dirac d T point R]. @@ -938,6 +917,18 @@ Canonical probability_ptType := PointedType (probability T R) prob_pointed. Definition mset (U : set T) (r : R) := [set mu : probability T R | mu U < r%:E]. +Lemma lt0_mset (U : set T) (r : R) : (r < 0)%R -> mset U r = set0. +Proof. +move=> r0; apply/seteqP; split => // x/=. +by apply/negP; rewrite -leNgt (@le_trans _ _ 0)// lee_fin ltW. +Qed. + +Lemma gt1_mset (U : set T) (r : R) : measurable U -> (1 < r)%R -> mset U r = setT. +Proof. +move=> mU r1; apply/seteqP; split => // x/= _. +by rewrite /mset/= (le_lt_trans (probability_le1 _ _)). +Qed. + Definition pset : set (set (probability T R)) := [set mset U r | r in `[0%R,1%R]%classic & U in @measurable d T]. @@ -958,27 +949,12 @@ Let measurable_fun_kprobability U : measurable U -> measurable_fun setT (kprobability mP ^~ U). Proof. move=> mU. -apply: (measurability (ErealGenInftyO.measurableE R)) => A /= -[B [x ->]]. -rewrite setTI => <-; case: x => [r| |]; last 2 first. - - rewrite (_ : _ @^-1` _ = setT)//; apply/seteqP; split => // x _ /=. - by rewrite in_itv/= (le_lt_trans (probability_le1 _ _)) ?ltey. - - rewrite (_ : _ @^-1` _ = set0)//; apply/seteqP; split => // x /=. - by rewrite in_itv/=; apply/negP; rewrite -leNgt leNye. -rewrite (_ : _ @^-1` _ = (fun x => P x U < r%:E)); last first. - by apply/funext => x; rewrite /= in_itv. -rewrite [X in measurable X](_ : _ = P @^-1` [set mu | mu U < r%:E]) //. -have [r0|r0] := leP 0%R r; last first. - rewrite [X in _ @^-1` X](_ : _ = set0) ?preimage_set0//. - apply/seteqP; split => // x/=. - by apply/negP; rewrite -leNgt (@le_trans _ _ 0)// lee_fin ltW. -have [r1|r1] := leP r 1%R; last first. - rewrite [X in _ @^-1` X](_ : _ = setT) ?preimage_setT//. - apply/seteqP; split => // x/= _. - by rewrite (le_lt_trans (probability_le1 _ _)). -move: mP => /(_ measurableT)/(_ [set mu | mu U < r%:E]). -rewrite setTI; apply; apply: sub_sigma_algebra; exists r => /=. - by rewrite in_itv/= r0. -by exists U. +apply: (measurability (ErealGenInftyO.measurableE R)) => _ /= -[_ [r ->] <-]. +rewrite setTI preimage_itv_infty_o -/(P @^-1` mset U r). +have [r0|r0] := leP 0%R r; last by rewrite lt0_mset// preimage_set0. +have [r1|r1] := leP r 1%R; last by rewrite gt1_mset// preimage_setT. +move: mP => /(_ measurableT (mset U r)); rewrite setTI; apply. +by apply: sub_sigma_algebra; exists r => /=; [rewrite in_itv/= r0|exists U]. Qed. HB.instance Definition _ := From a2adf9615079c22092d8a9787d7b2decfad2f3ce Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Tue, 15 Nov 2022 10:11:02 +0900 Subject: [PATCH 26/54] upd with recent PRs --- theories/kernel.v | 2 +- theories/prob_lang.v | 34 +++++++++++++++++----------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index fbf289e385..a21bdb454e 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -800,7 +800,7 @@ rewrite (_ : (fun x => _) = - by move=> n; exact/EFin_measurable_fun/measurable_fun_prod1. - by move=> n y _; rewrite lee_fin. - by move=> y _ m n mn; rewrite lee_fin; exact/lefP/ndk_. -apply: measurable_fun_elim_sup => n. +apply: measurable_fun_lim_esup => n. rewrite [X in measurable_fun _ X](_ : _ = (fun x => \int[l x]_y (\sum_(r \in range (k_ n)) r * \1_(k_ n @^-1` [set r]) (x, y))%:E)); last first. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index fe4ae3a454..ec18f67d0a 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -721,8 +721,8 @@ apply: measurable_fun_comp; last exact: measurable_fun_opp. by apply: continuous_measurable_fun; exact: continuous_expR. Qed. -Definition poisson3 := poisson 4 3. (* 0.168 *) -Definition poisson10 := poisson 4 10. (* 0.019 *) +Definition poisson3 := poisson 4 3%:R. (* 0.168 *) +Definition poisson10 := poisson 4 10%:R. (* 0.019 *) End poisson. @@ -771,7 +771,7 @@ Definition sample_and_return : R.-sfker T ~> _ := (ret var2of2) (* T * B -> B *). Lemma sample_and_returnE t U : sample_and_return t U = - (2 / 7)%:E * \d_true U + (5 / 7)%:E * \d_false U. + (2 / 7%:R)%:E * \d_true U + (5%:R / 7%:R)%:E * \d_false U. Proof. rewrite /sample_and_return. rewrite letin_sample_bernoulli/=. @@ -797,8 +797,8 @@ Definition sample_and_branch : (ite var2of2 (ret k3) (ret k10)). Lemma sample_and_branchE t U : sample_and_branch t U = - (2 / 7)%:E * \d_(3 : R) U + - (5 / 7)%:E * \d_(10 : R) U. + (2 / 7%:R)%:E * \d_(3%:R : R) U + + (5%:R / 7%:R)%:E * \d_(10%:R : R) U. Proof. rewrite /sample_and_branch letin_sample_bernoulli/=. rewrite !iteE/= !retE. @@ -836,8 +836,8 @@ Definition kstaton_bus_poisson : R.-sfker (mR R) ~> mbool := kstaton_bus _ mpoisson4. Let kstaton_bus_poissonE t U : kstaton_bus_poisson t U = - (2 / 7)%:E * (poisson4 3)%:E * \d_true U + - (5 / 7)%:E * (poisson4 10)%:E * \d_false U. + (2 / 7%:R)%:E * (poisson4 3%:R)%:E * \d_true U + + (5%:R / 7%:R)%:E * (poisson4 10%:R)%:E * \d_false U. Proof. rewrite /kstaton_bus. rewrite letin_sample_bernoulli. @@ -857,11 +857,11 @@ Qed. (* false -> 5/7 * 0.019 = 5/7 * 10^4 e^-10 / 4! *) Lemma staton_busE P (t : R) U : - let N := ((2 / 7) * poisson4 3 + - (5 / 7) * poisson4 10)%R in + let N := ((2 / 7%:R) * poisson4 3%:R + + (5%:R / 7%:R) * poisson4 10%:R)%R in staton_bus mpoisson4 P t U = - ((2 / 7)%:E * (poisson4 3)%:E * \d_true U + - (5 / 7)%:E * (poisson4 10)%:E * \d_false U) * N^-1%:E. + ((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. Proof. rewrite /staton_bus normalizeE /= !kstaton_bus_poissonE !diracT !mule1 ifF //. apply/negbTE; rewrite gt_eqF// lte_fin. @@ -886,8 +886,8 @@ Definition kstaton_bus_exponential : R.-sfker (mR R) ~> mbool := kstaton_bus _ mexp1560. Let kstaton_bus_exponentialE t U : kstaton_bus_exponential t U = - (2 / 7)%:E * (exp1560 3)%:E * \d_true U + - (5 / 7)%:E * (exp1560 10)%:E * \d_false 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. @@ -907,11 +907,11 @@ Qed. (* false -> 2/7 * 0.168 = 2/7 * 3^4 e^-3 / 4! *) Lemma staton_bus_exponentialE P (t : R) U : - let N := ((2 / 7) * exp1560 3 + - (5 / 7) * exp1560 10)%R in + 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)%:E * (exp1560 3)%:E * \d_true U + - (5 / 7)%:E * (exp1560 10)%:E * \d_false U) * N^-1%:E. + ((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 //. From 1410fce6eb5122fb5fda96fb2c65af4833c152b5 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Tue, 13 Dec 2022 05:05:47 +0900 Subject: [PATCH 27/54] use reversible coercions --- theories/kernel.v | 303 ++++++++++++++++--------------------------- theories/prob_lang.v | 231 +++++++++++++++------------------ theories/wip.v | 9 +- 3 files changed, 221 insertions(+), 322 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index a21bdb454e..4f08ec2a60 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -1,4 +1,4 @@ -(* mathcomp analysis (c) 2017 Inria and AIST. License: CeCILL-C. *) +(* mathcomp analysis (c) 2022 Inria and AIST. License: CeCILL-C. *) From HB Require Import structures. From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval finmap. Require Import mathcomp_extra boolp classical_sets signed functions cardinality. @@ -42,17 +42,16 @@ Local Open Scope ring_scope. Local Open Scope ereal_scope. (* PR 516 in progress *) -HB.mixin Record isProbability (d : measure_display) (T : measurableType d) +HB.mixin Record isProbability d (T : measurableType d) (R : realType) (P : set T -> \bar R) of isMeasure d R T P := { probability_setT : P setT = 1%E }. #[short(type=probability)] -HB.structure Definition Probability (d : measure_display) (T : measurableType d) - (R : realType) := +HB.structure Definition Probability d (T : measurableType d) (R : realType) := {P of isProbability d T R P & isMeasure d R T P }. Section probability_lemmas. -Variables (d : _) (T : measurableType d) (R : realType) (P : probability T R). +Context d (T : measurableType d) (R : realType) (P : probability T R). Lemma probability_le1 (A : set T) : measurable A -> (P A <= 1)%E. Proof. @@ -125,28 +124,7 @@ HB.instance Definition _ := @isMeasurable.Build default_measure_display unit End discrete_measurable_unit. -Section discrete_measurable_bool. - -Definition discrete_measurable_bool : set (set bool) := [set: set bool]. - -Let discrete_measurable0 : discrete_measurable_bool set0. Proof. by []. Qed. - -Let discrete_measurableC X : - discrete_measurable_bool X -> discrete_measurable_bool (~` X). -Proof. by []. Qed. - -Let discrete_measurableU (F : (set bool)^nat) : - (forall i, discrete_measurable_bool (F i)) -> - discrete_measurable_bool (\bigcup_i F i). -Proof. by []. Qed. - -HB.instance Definition _ := @isMeasurable.Build default_measure_display bool - (Pointed.class _) discrete_measurable_bool discrete_measurable0 - discrete_measurableC discrete_measurableU. - -End discrete_measurable_bool. - -Lemma measurable_curry (T1 T2 : Type) (d : _) (T : semiRingOfSetsType d) +Lemma measurable_curry (T1 T2 : Type) d (T : semiRingOfSetsType d) (G : T1 * T2 -> set T) (x : T1 * T2) : measurable (G x) <-> measurable (curry G x.1 x.2). Proof. by case: x. Qed. @@ -162,18 +140,16 @@ apply: measurableU. exact: emeasurable_itv_bnd_pinfty. Qed. -Lemma measurable_fun_fst (d1 d2 : _) (T1 : measurableType d1) +Lemma measurable_fun_fst d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) : measurable_fun setT (@fst T1 T2). Proof. -have := @measurable_fun_id _ [the measurableType _ of (T1 * T2)%type] setT. -by move=> /prod_measurable_funP[]. +by have /prod_measurable_funP[] := @measurable_fun_id _ (T1 * T2)%type setT. Qed. -Lemma measurable_fun_snd (d1 d2 : _) (T1 : measurableType d1) +Lemma measurable_fun_snd d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) : measurable_fun setT (@snd T1 T2). Proof. -have := @measurable_fun_id _ [the measurableType _ of (T1 * T2)%type] setT. -by move=> /prod_measurable_funP[]. +by have /prod_measurable_funP[] := @measurable_fun_id _ (T1 * T2)%type setT. Qed. Definition swap (T1 T2 : Type) (x : T1 * T2) := (x.2, x.1). @@ -186,7 +162,7 @@ by apply/prod_measurable_funP => /=; split; Qed. Section measurable_fun_pair. -Variables (d d2 d3 : _) (X : measurableType d) (Y : measurableType d2) +Context d d2 d3 (X : measurableType d) (Y : measurableType d2) (Z : measurableType d3). Lemma measurable_fun_pair (f : X -> Y) (g : X -> Z) : @@ -197,10 +173,8 @@ Proof. by move=> mf mg; apply/prod_measurable_funP. Qed. End measurable_fun_pair. Section measurable_fun_comp. -Variables (d1 d2 d3 : measure_display). -Variables (T1 : measurableType d1). -Variables (T2 : measurableType d2). -Variables (T3 : measurableType d3). +Context d1 d2 d3 (T1 : measurableType d1) + (T2 : measurableType d2) (T3 : measurableType d3). (* NB: this generalizes MathComp-Analysis' measurable_fun_comp *) Lemma measurable_fun_comp' F (f : T2 -> T3) E (g : T1 -> T2) : @@ -218,48 +192,7 @@ Qed. End measurable_fun_comp. -Lemma measurable_fun_if (d d' : _) (X : measurableType d) - (Y : measurableType d') (x y : X -> Y) D (md : measurable D) - (f : X -> bool) (mf : measurable_fun setT f) : - measurable_fun (D `&` (f @^-1` [set true])) x -> - measurable_fun (D `&` (f @^-1` [set false])) y -> - measurable_fun D (fun t => if f t then x t else y t). -Proof. -move=> mx my /= _ B mB. -have mDf : measurable (D `&` [set b | f b]). - apply: measurableI => //. - rewrite [X in measurable X](_ : _ = f @^-1` [set true])//. - by have := mf measurableT [set true]; rewrite setTI; exact. -have := mx mDf _ mB. -have mDNf : measurable (D `&` f @^-1` [set false]). - apply: measurableI => //. - by have := mf measurableT [set false]; rewrite setTI; exact. -have := my mDNf _ mB. -move=> yB xB. -rewrite (_ : _ @^-1` B = - ((f @^-1` [set true]) `&` (x @^-1` B) `&` (f @^-1` [set true])) `|` - ((f @^-1` [set false]) `&` (y @^-1` B) `&` (f @^-1` [set false]))); last first. - apply/seteqP; split=> [t /=| t]. - by case: ifPn => ft; [left|right]. - by move=> /= [|]; case: ifPn => ft; case=> -[]. -rewrite setIUr; apply: measurableU. -- rewrite -(setIid D) -(setIA D) setICA setIA. - by apply: measurableI => //; rewrite setIA. -- rewrite -(setIid D) -(setIA D) setICA setIA. - by apply: measurableI => //; rewrite setIA. -Qed. - -Lemma measurable_fun_ifT (d d' : _) (X : measurableType d) - (Y : measurableType d') (x y : X -> Y) (f : X -> bool) - (mf : measurable_fun setT f) : - measurable_fun setT x -> measurable_fun setT y -> - measurable_fun setT (fun t => if f t then x t else y t). -Proof. -by move=> mx my; apply: measurable_fun_if => //; - [exact: measurable_funS mx|exact: measurable_funS my]. -Qed. - -Lemma measurable_fun_if_pair (d d' : _) (X : measurableType d) +Lemma measurable_fun_if_pair d d' (X : measurableType d) (Y : measurableType d') (x y : X -> Y) : measurable_fun setT x -> measurable_fun setT y -> measurable_fun setT (fun tb => if tb.2 then x tb.1 else y tb.1). @@ -275,7 +208,7 @@ Qed. Lemma measurable_fun_opp (R : realType) : measurable_fun [set: R] -%R. Proof. apply: continuous_measurable_fun. -by have := (@opp_continuous R [the normedModType R of R^o]). +by have := @opp_continuous R [the normedModType R of R^o]. Qed. Lemma integral_eq0 d (T : measurableType d) (R : realType) @@ -297,8 +230,7 @@ Proof. by rewrite /dirac indicT. Qed. Section fubini_tonelli. Local Open Scope ereal_scope. -Variables (d1 d2 : measure_display). -Variables (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). +Context d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). Variables (m1 : {measure set T1 -> \bar R}) (m2 : {measure set T2 -> \bar R}). Hypotheses (sm1 : sigma_finite setT m1) (sm2 : sigma_finite setT m2). Variables (f : T1 * T2 -> \bar R) (f0 : forall xy, 0 <= f xy). @@ -331,18 +263,18 @@ by case: ifPn => // _; rewrite ?measure0//; exact: finite_measure. Qed. Section sfinite_fubini. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d') (R : realType). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Variables (m1 : {measure set X -> \bar R}) (sfm1 : sfinite_measure m1). Variables (m2 : {measure set Y -> \bar R}) (sfm2 : sfinite_measure m2). Variables (f : X * Y -> \bar R) (f0 : forall xy, 0 <= f xy). -Variable (mf : measurable_fun setT f). +Hypothesis mf : measurable_fun setT f. Lemma sfinite_fubini : \int[m1]_x \int[m2]_y f (x, y) = \int[m2]_y \int[m1]_x f (x, y). Proof. have [s1 fm1 m1E] := sfm1. have [s2 fm2 m2E] := sfm2. -rewrite [LHS](eq_measure_integral [the measure _ _ of mseries s1 0]); last first. +rewrite [LHS](eq_measure_integral (mseries s1 0)); last first. by move=> A mA _; rewrite m1E. transitivity (\int[mseries s1 0]_x \int[mseries s2 0]_y f (x, y)). by apply eq_integral => x _; apply: eq_measure_integral => ? ? _; rewrite m2E. @@ -359,7 +291,7 @@ transitivity (\sum_(n n _; apply eq_integral => x _. by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. transitivity (\sum_(n n _; rewrite integral_sum//. + apply eq_eseries => n _; rewrite integral_nneseries//. move=> m; apply: measurable_fun_fubini_tonelli_F => //=. exact: finite_measure_sigma_finite. by move=> m x _; exact: integral_ge0. @@ -372,7 +304,7 @@ transitivity (\sum_(n //=. by apply: finite_measure_sigma_finite; exact: fm1. transitivity (\int[mseries s2 0]_y \sum_(n n; apply: measurable_fun_fubini_tonelli_G => //=. by apply: finite_measure_sigma_finite; exact: fm1. by move=> n y _; exact: integral_ge0. @@ -416,12 +348,11 @@ by subst m1; f_equal; f_equal; f_equal; apply/Prop_irrelevance. Qed. Section kseries. -Variables (d d' : measure_display) (R : realType). -Variables (X : measurableType d) (Y : measurableType d'). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Variable k : (R.-ker X ~> Y)^nat. Definition kseries : X -> {measure set Y -> \bar R} := - fun x => [the measure _ _ of mseries (k ^~ x) 0]. + fun x => mseries (k ^~ x) 0. Lemma measurable_fun_kseries (U : set Y) : measurable U -> @@ -436,8 +367,7 @@ HB.instance Definition _ := End kseries. -Lemma integral_kseries - (d d' : _) (X : measurableType d) (Y : measurableType d') +Lemma integral_kseries d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : (R.-ker X ~> Y)^nat) (f : Y -> \bar R) x : (forall y, 0 <= f y) -> measurable_fun setT f -> @@ -447,8 +377,8 @@ by move=> f0 mf; rewrite /kseries/= ge0_integral_measure_series. Qed. Section measure_fam_uub. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : numFieldType) (k : X -> {measure set Y -> \bar R}). +Context d d' (X : measurableType d) (Y : measurableType d') (R : numFieldType). +Variable k : X -> {measure set Y -> \bar R}. Definition measure_fam_uub := exists r, forall x, k x [set: Y] < r%:E. @@ -473,7 +403,7 @@ HB.mixin Record Kernel_isSFinite_subdef HB.structure Definition SFiniteKernel d d' (X : measurableType d) (Y : measurableType d') (R : realType) := - {k of Kernel_isSFinite_subdef _ _ X Y R k & isKernel d d' X Y R k }. + {k of @Kernel _ _ _ _ R k & Kernel_isSFinite_subdef _ _ X Y R k }. Notation "R .-sfker X ~> Y" := (sfinite_kernel X Y R). Arguments sfinite_subdef {_ _ _ _ _} _. @@ -497,7 +427,8 @@ HB.mixin Record SFiniteKernel_isFinite HB.structure Definition FiniteKernel d d' (X : measurableType d) (Y : measurableType d') (R : realType) := - {k of SFiniteKernel_isFinite _ _ X Y R k & @SFiniteKernel _ _ X Y R k }. + {k of @SFiniteKernel _ _ _ _ _ k & + SFiniteKernel_isFinite _ _ X Y R k }. Notation "R .-fker X ~> Y" := (finite_kernel X Y R). Arguments measure_uub {_ _ _ _ _} _. @@ -508,11 +439,9 @@ HB.factory Record Kernel_isFinite d d' (X : measurableType d) measure_uub : measure_fam_uub k }. Section kzero. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variable R : realType. +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Definition kzero : X -> {measure set Y -> \bar R} := - fun _ : X => [the measure _ _ of mzero]. +Definition kzero : X -> {measure set Y -> \bar R} := fun _ : X => mzero. Let measurable_fun_kzero U : measurable U -> measurable_fun setT (kzero ^~ U). @@ -527,14 +456,14 @@ Proof. by exists 1%R => /= t; rewrite /mzero/=. Qed. End kzero. HB.builders Context d d' (X : measurableType d) (Y : measurableType d') - (R : realType) k of Kernel_isFinite d d' X Y R k. + (R : realType) k of Kernel_isFinite d d' X Y R k. Lemma sfinite_finite : exists2 k_ : (R.-ker _ ~> _)^nat, forall n, measure_fam_uub (k_ n) & - forall x U, measurable U -> k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. + forall x U, measurable U -> k x U = mseries (k_ ^~ x) 0 U. Proof. exists (fun n => if n is O then [the _.-ker _ ~> _ of k] else - [the _.-ker _ ~> _ of @kzero _ _ X Y R]). + @kzero _ _ X Y R). by case => [|_]; [exact: measure_uub|exact: kzero_uub]. move=> t U mU/=; rewrite /mseries. rewrite (nneseries_split 1%N)// big_ord_recl/= big_ord0 adde0. @@ -542,14 +471,16 @@ rewrite ereal_series (@eq_eseries _ _ (fun=> 0%E)); last by case. by rewrite eseries0// adde0. Qed. -HB.instance Definition _ := @Kernel_isSFinite_subdef.Build d d' X Y R k sfinite_finite. +HB.instance Definition _ := + @Kernel_isSFinite_subdef.Build d d' X Y R k sfinite_finite. -HB.instance Definition _ := @SFiniteKernel_isFinite.Build d d' X Y R k measure_uub. +HB.instance Definition _ := + @SFiniteKernel_isFinite.Build d d' X Y R k measure_uub. HB.end. Section sfinite. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). +Context d d' (X : measurableType d) (Y : measurableType d'). Variables (R : realType) (k : R.-sfker X ~> Y). Let s : (X -> {measure set Y -> \bar R})^nat := @@ -572,13 +503,12 @@ HB.instance Definition _ n := Lemma sfinite : exists s : (R.-fker X ~> Y)^nat, forall x U, measurable U -> k x U = kseries s x U. Proof. -exists (fun n => [the _.-fker _ ~> _ of s n]) => x U mU. -by rewrite /s /= /s; by case: cid2 => ? ? ->. +by exists s => x U mU; rewrite /s /= /s; by case: cid2 => ? ? ->. Qed. End sfinite. -HB.instance Definition _ (d d' : _) (X : measurableType d) +HB.instance Definition _ d d' (X : measurableType d) (Y : measurableType d') (R : realType) := @Kernel_isFinite.Build _ _ _ _ R (@kzero _ _ X Y R) (@kzero_uub _ _ X Y R). @@ -609,10 +539,10 @@ HB.mixin Record FiniteKernel_isSubProbability #[short(type=sprobability_kernel)] HB.structure Definition SubProbabilityKernel - (d d' : _) (X : measurableType d) (Y : measurableType d') + d d' (X : measurableType d) (Y : measurableType d') (R : realType) := - {k of FiniteKernel_isSubProbability _ _ X Y R k & - @FiniteKernel _ _ X Y R k}. + {k of @FiniteKernel _ _ _ _ _ k & + FiniteKernel_isSubProbability _ _ X Y R k }. Notation "R .-spker X ~> Y" := (sprobability_kernel X Y R). HB.factory Record Kernel_isSubProbability @@ -642,10 +572,10 @@ HB.mixin Record SubProbability_isProbability #[short(type=probability_kernel)] HB.structure Definition ProbabilityKernel - (d d' : _) (X : measurableType d) (Y : measurableType d') + d d' (X : measurableType d) (Y : measurableType d') (R : realType) := - {k of SubProbability_isProbability _ _ X Y R k & - @SubProbabilityKernel _ _ X Y R k}. + {k of @SubProbabilityKernel _ _ _ _ _ k & + SubProbability_isProbability _ _ X Y R k }. Notation "R .-pker X ~> Y" := (probability_kernel X Y R). HB.factory Record Kernel_isProbability @@ -667,7 +597,7 @@ HB.instance Definition _ := @SubProbability_isProbability.Build _ _ _ _ _ k prob HB.end. -Lemma finite_kernel_measure (d d' : _) (X : measurableType d) +Lemma finite_kernel_measure d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : R.-fker X ~> Y) (x : X) : finite_measure (k x). Proof. @@ -675,7 +605,7 @@ have [r k_r] := measure_uub k. by rewrite /finite_measure (@lt_trans _ _ r%:E) ?ltey. Qed. -Lemma sfinite_kernel_measure (d d' : _) (X : measurableType d) +Lemma sfinite_kernel_measure d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : R.-sfker X ~> Y) (x : X) : sfinite_measure (k x). Proof. @@ -691,8 +621,7 @@ Qed. measurability of each measure of the family) - as a consequence, m2D_bounded holds for all x *) Section measurable_prod_subset_kernel. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d') - (R : realType). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Implicit Types A : set (X * Y). Section xsection_kernel. @@ -747,9 +676,8 @@ End measurable_prod_subset_kernel. the difference is that this section uses a finite kernel m2 instead of a sigma-finite measure m2 *) Section measurable_fun_xsection_finite_kernel. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d') - (R : realType). -Variables (k : R.-fker X ~> Y). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). +Variable k : R.-fker X ~> Y. Implicit Types A : set (X * Y). Let phi A := fun x => k x (xsection A x). @@ -770,13 +698,12 @@ Qed. End measurable_fun_xsection_finite_kernel. Section measurable_fun_integral_finite_sfinite. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d') - (R : realType). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). 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)%type] >-> R})^nat) + (k_ : ({nnsfun (X * Y)%type >-> R})^nat) (ndk_ : nondecreasing_seq (k_ : (X * Y -> R)^nat)) (k_k : forall z, EFin \o (k_ ^~ z) --> k z) : (forall n r, measurable_fun setT (fun x => l x (xsection (k_ n @^-1` [set r]) x))) -> @@ -811,8 +738,7 @@ rewrite [X in measurable_fun _ X](_ : _ = (fun x => \sum_(r \in range (k_ n)) - by apply: eq_integral => y _; rewrite -fsumEFin. - move=> r. apply/EFin_measurable_fun/measurable_funrM/measurable_fun_prod1 => /=. - rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r))//. - exact/measurable_funP. + by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). - by move=> m y _; rewrite nnfun_muleindic_ge0. apply: emeasurable_fun_fsum => // r. rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * @@ -821,8 +747,7 @@ rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * have [r0|r0] := leP 0%R r. rewrite ge0_integralM//; last by move=> y _; rewrite lee_fin. apply/EFin_measurable_fun/measurable_fun_prod1 => /=. - rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r))//. - exact/measurable_funP. + by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). rewrite integral_eq0; last first. by move=> y _; rewrite preimage_nnfun0// indic0 mule0. by rewrite integral_eq0 ?mule0// => y _; rewrite preimage_nnfun0// indic0. @@ -867,7 +792,7 @@ Arguments measurable_fun_integral_finite_kernel {_ _ _ _ _} k l. Arguments measurable_fun_integral_sfinite_kernel {_ _ _ _ _} k l. Section pdirac. -Variables (d : _) (T : measurableType d) (R : realType). +Context d (T : measurableType d) (R : realType). HB.instance Definition _ x := isProbability.Build _ _ _ (@dirac _ T x R) (diracT R x). @@ -875,12 +800,12 @@ HB.instance Definition _ x := End pdirac. Section kdirac. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (f : X -> Y). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). +Variable f : X -> Y. Definition kdirac (mf : measurable_fun setT f) : X -> {measure set Y -> \bar R} := - fun x => [the measure _ _ of dirac (f x)]. + fun x => dirac (f x). Hypothesis mf : measurable_fun setT f. @@ -904,9 +829,9 @@ End kdirac. Arguments kdirac {d d' X Y R f}. Section dist_salgebra_instance. -Variables (d : _) (T : measurableType d) (R : realType). +Context d (T : measurableType d) (R : realType). -Let p0 : probability T R := [the probability T R of @dirac d T point R]. +Let p0 : probability T R := dirac point. Definition prob_pointed := Pointed.Class (Choice.Class gen_eqMixin (Choice.Class gen_eqMixin gen_choiceMixin)) p0. @@ -930,15 +855,15 @@ by rewrite /mset/= (le_lt_trans (probability_le1 _ _)). Qed. Definition pset : set (set (probability T R)) := - [set mset U r | r in `[0%R,1%R]%classic & U in @measurable d T]. + [set mset U r | r in `[0%R,1%R] & U in measurable]. -Definition pprobability := [the measurableType pset.-sigma of salgebraType pset]. +Definition pprobability : measurableType pset.-sigma := salgebraType pset. End dist_salgebra_instance. Section kprobability. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (P : X -> pprobability Y R). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). +Variable P : X -> pprobability Y R. Definition kprobability (mP : measurable_fun setT P) : X -> {measure set Y -> \bar R} := P. @@ -969,11 +894,11 @@ HB.instance Definition _ := End kprobability. Section kadd. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k1 k2 : R.-ker X ~> Y). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). +Variables k1 k2 : R.-ker X ~> Y. Definition kadd : X -> {measure set Y -> \bar R} := - fun x => [the measure _ _ of measure_add (k1 x) (k2 x)]. + fun x => measure_add (k1 x) (k2 x). Let measurable_fun_kadd U : measurable U -> measurable_fun setT (kadd ^~ U). @@ -989,16 +914,15 @@ HB.instance Definition _ := End kadd. Section sfkadd. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k1 k2 : R.-sfker X ~> Y). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). +Variables k1 k2 : R.-sfker X ~> Y. Let sfinite_kadd : exists2 k_ : (R.-ker _ ~> _)^nat, forall n, measure_fam_uub (k_ n) & forall x U, measurable U -> - kadd k1 k2 x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. + kadd k1 k2 x U = mseries (k_ ^~ x) 0 U. Proof. -have [f1 hk1] := sfinite k1. -have [f2 hk2] := sfinite k2. -exists (fun n => [the _.-ker _ ~> _ of kadd (f1 n) (f2 n)]). +have [f1 hk1] := sfinite k1; have [f2 hk2] := sfinite k2. +exists (fun n => kadd (f1 n) (f2 n)). move=> n. have [r1 f1r1] := measure_uub (f1 n). have [r2 f2r2] := measure_uub (f2 n). @@ -1019,8 +943,8 @@ HB.instance Definition _ t := End sfkadd. Section fkadd. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (k1 k2 : R.-fker X ~> Y). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). +Variables k1 k2 : R.-fker X ~> Y. Let kadd_finite_uub : measure_fam_uub (kadd k1 k2). Proof. @@ -1036,8 +960,7 @@ End fkadd. (* TODO: move *) Section kernel_measurable_preimage. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). -Variable R : realType. +Context d d' (T : measurableType d) (T' : measurableType d') (R : realType). Lemma measurable_eq_cst (f : R.-ker T ~> T') k : measurable [set t | f t setT == k]. @@ -1060,7 +983,7 @@ Qed. End kernel_measurable_preimage. (* TODO: move *) -Lemma measurable_fun_eq_cst (d d' : _) (T : measurableType d) +Lemma measurable_fun_eq_cst d d' (T : measurableType d) (T' : measurableType d') (R : realType) (f : R.-ker T ~> T') k : measurable_fun setT (fun t => f t setT == k). Proof. @@ -1075,9 +998,8 @@ have [/eqP->|/eqP->|/eqP->|/eqP->] := set_boolE B. Qed. Section mnormalize. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (f : X -> {measure set Y -> \bar R}). -Variable P : probability Y R. +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). +Variables (f : X -> {measure set Y -> \bar R}) (P : probability Y R). Definition mnormalize x U := let evidence := f x [set: Y] in @@ -1120,11 +1042,11 @@ HB.instance Definition _ x := End mnormalize. Section knormalize. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variables (R : realType) (f : R.-ker X ~> Y). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). +Variable f : R.-ker X ~> Y. -Definition knormalize (P : probability Y R) := - fun t => [the measure _ _ of mnormalize f P t]. +Definition knormalize (P : probability Y R) : X -> {measure set Y -> \bar R} := + mnormalize f P. Variable P : probability Y R. @@ -1143,7 +1065,7 @@ apply: measurable_fun_if => //. - rewrite setTI [X in measurable X](_ : _ = [set t | f t setT != 0]). exact: measurable_neq_cst. by apply/seteqP; split => [x /negbT//|x /negbTE]. -- exact: measurable_fun_eq_cst. +- by apply: (@measurable_funS _ _ _ _ setT) => //; exact: measurable_fun_eq_cst. - exact: measurable_fun_cst. - apply: emeasurable_funM. by have := measurable_kernel f U mU; exact: measurable_funS. @@ -1178,8 +1100,8 @@ HB.instance Definition _ := End knormalize. Section kcomp_def. -Variables (d1 d2 d3 : _) (X : measurableType d1) (Y : measurableType d2) - (Z : measurableType d3) (R : realType). +Context d1 d2 d3 (X : measurableType d1) (Y : measurableType d2) + (Z : measurableType d3) (R : realType). Variable l : X -> {measure set Y -> \bar R}. Variable k : (X * Y)%type -> {measure set Z -> \bar R}. @@ -1188,10 +1110,10 @@ Definition kcomp x U := \int[l x]_y k (x, y) U. End kcomp_def. Section kcomp_is_measure. -Variables (d1 d2 d3 : _) (X : measurableType d1) (Y : measurableType d2) - (Z : measurableType d3) (R : realType). +Context d1 d2 d3 (X : measurableType d1) (Y : measurableType d2) + (Z : measurableType d3) (R : realType). Variable l : R.-ker X ~> Y. -Variable k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z. +Variable k : R.-ker (X * Y)%type ~> Z. Local Notation "l \; k" := (kcomp l k). @@ -1210,15 +1132,14 @@ move=> U mU tU mUU; rewrite [X in _ --> X](_ : _ = by apply/esym/cvg_lim => //; exact/measure_semi_sigma_additive. apply/cvg_closeP; split. by apply: is_cvg_nneseries => n _; exact: integral_ge0. -rewrite closeE// integral_sum// => n. +rewrite closeE// integral_nneseries// => n. by have /measurable_fun_prod1 := measurable_kernel k _ (mU n). Qed. HB.instance Definition _ x := isMeasure.Build _ R _ ((l \; k) x) (kcomp0 x) (kcomp_ge0 x) (@kcomp_sigma_additive x). -Definition mkcomp : X -> {measure set Z -> \bar R} := - fun x => [the measure _ _ of (l \; k) x]. +Definition mkcomp : X -> {measure set Z -> \bar R} := l \; k. End kcomp_is_measure. @@ -1227,9 +1148,9 @@ Notation "l \; k" := (mkcomp l k) : ereal_scope. Module KCOMP_FINITE_KERNEL. Section kcomp_finite_kernel_kernel. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) (l : R.-fker X ~> Y) - (k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z). +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) (l : R.-fker X ~> Y) + (k : R.-ker (X * Y)%type ~> Z). Lemma measurable_fun_kcomp_finite U : measurable U -> measurable_fun setT ((l \; k) ^~ U). @@ -1244,10 +1165,10 @@ HB.instance Definition _ := End kcomp_finite_kernel_kernel. Section kcomp_finite_kernel_finite. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). Variable l : R.-fker X ~> Y. -Variable k : R.-fker [the measurableType _ of (X * Y)%type] ~> Z. +Variable k : R.-fker (X * Y)%type ~> Z. Let mkcomp_finite : measure_fam_uub (l \; k). Proof. @@ -1270,10 +1191,10 @@ End kcomp_finite_kernel_finite. End KCOMP_FINITE_KERNEL. Section kcomp_sfinite_kernel. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). Variable l : R.-sfker X ~> Y. -Variable k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. +Variable k : R.-sfker (X * Y)%type ~> Z. Import KCOMP_FINITE_KERNEL. @@ -1285,15 +1206,14 @@ have [kl hkl] : exists kl : (R.-fker X ~> Z) ^nat, forall x U, \esum_(i in setT) (l_ i.2 \; k_ i.1) x U = \sum_(i [the _.-fker _ ~> _ of l_ (f i).2 \; k_ (f i).1]) => x U. + exists (fun i => l_ (f i).2 \; k_ (f i).1) => x U. by rewrite (reindex_esum [set: nat] _ f)// nneseries_esum// fun_true. exists kl => x U mU. -transitivity (([the _.-ker _ ~> _ of kseries l_] \; - [the _.-ker _ ~> _ of kseries k_]) x U). +transitivity ((kseries l_ \; kseries k_) x U). rewrite /= /kcomp [in RHS](eq_measure_integral (l x)); last first. by move=> *; rewrite hl_. by apply: eq_integral => y _; rewrite hk_. -rewrite /= /kcomp/= integral_sum//=; last first. +rewrite /= /kcomp/= integral_nneseries//=; last first. by move=> n; have /measurable_fun_prod1 := measurable_kernel (k_ n) _ mU; exact. transitivity (\sum_(i i _; rewrite integral_kseries//. @@ -1316,10 +1236,10 @@ End kcomp_sfinite_kernel. Module KCOMP_SFINITE_KERNEL. Section kcomp_sfinite_kernel. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). Variable l : R.-sfker X ~> Y. -Variable k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. +Variable k : R.-sfker (X * Y)%type ~> Z. HB.instance Definition _ := isKernel.Build _ _ X Z R (l \; k) (measurable_fun_mkcomp_sfinite l k). @@ -1333,8 +1253,7 @@ End KCOMP_SFINITE_KERNEL. HB.export KCOMP_SFINITE_KERNEL. Section measurable_fun_preimage_integral. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d') - (R : realType). +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Variables (k : Y -> \bar R) (k_ : ({nnsfun Y >-> R}) ^nat) (ndk_ : nondecreasing_seq (k_ : (Y -> R)^nat)) @@ -1364,8 +1283,7 @@ Lemma measurable_fun_preimage_integral (l : X -> {measure set Y -> \bar R}) : (forall n r, measurable_fun setT (l ^~ (k_ n @^-1` [set r]))) -> measurable_fun setT (fun x => \int[l x]_z k z). Proof. -move=> h; apply: (measurable_fun_xsection_integral (k \o snd) l - (fun n => [the {nnsfun _ >-> _} of k_2 n])) => /=. +move=> h; apply: (measurable_fun_xsection_integral (k \o snd) l k_2) => /=. - by rewrite /k_2 => m n mn; apply/lefP => -[x y] /=; exact/lefP/ndk_. - by move=> [x y]; exact: k_k. - move=> n r _ /= B mB. @@ -1390,10 +1308,9 @@ by apply: (measurable_fun_preimage_integral ndk_ k_k) => n r; exact/ml. Qed. Section integral_kcomp. -Variables (d d2 d3 : _) (X : measurableType d) (Y : measurableType d2) +Context d d2 d3 (X : measurableType d) (Y : measurableType d2) (Z : measurableType d3) (R : realType). -Variable l : R.-sfker X ~> Y. -Variables k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. +Variables (l : R.-sfker X ~> Y) (k : R.-sfker (X * Y)%type ~> Z). Let integral_kcomp_indic x E (mE : measurable E) : \int[(l \; k) x]_z (\1_E z)%:E = \int[l x]_y (\int[k (x, y)]_z (\1_E z)%:E). diff --git a/theories/prob_lang.v b/theories/prob_lang.v index ec18f67d0a..4a76560f7b 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -1,3 +1,4 @@ +(* mathcomp analysis (c) 2022 Inria and AIST. License: CeCILL-C. *) From HB Require Import structures. From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval finmap. From mathcomp Require Import rat. @@ -58,35 +59,31 @@ Section bernoulli. Variables (R : realType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R). Local Open Scope ring_scope. -Definition mbernoulli : set _ -> \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]]. +Definition bernoulli := measure_add + (mscale p (dirac true)) + (mscale (onem_nonneg p1) (dirac false)). -HB.instance Definition _ := Measure.on mbernoulli. +HB.instance Definition _ := Measure.on bernoulli. Local Close Scope ring_scope. -Let mbernoulli_setT : mbernoulli [set: _] = 1. +Let bernoulli_setT : bernoulli [set: _] = 1. Proof. -rewrite /mbernoulli/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. +rewrite /bernoulli/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. by rewrite /mscale/= !diracT !mule1 -EFinD onem1'. Qed. -HB.instance Definition _ := - @isProbability.Build _ _ R mbernoulli mbernoulli_setT. - -Definition bernoulli := [the probability _ _ of mbernoulli]. +HB.instance Definition _ := @isProbability.Build _ _ R bernoulli bernoulli_setT. End bernoulli. Section mscore. -Variables (d : _) (T : measurableType d). -Variables (R : realType) (f : T -> R). +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. @@ -108,7 +105,8 @@ End mscore. (* decomposition of score into finite kernels *) Module SCORE. Section score. -Variables (d : _) (T : measurableType d) (R : realType) (f : T -> R). +Context d (T : measurableType d) (R : realType). +Variable f : T -> R. Definition k (mf : measurable_fun setT f) i t U := if i%:R%:E <= mscore f t U < i.+1%:R%:E then @@ -173,7 +171,7 @@ apply/EFin_measurable_fun. by rewrite (_ : \1__ = mindic R (emeasurable_itv R i)). Qed. -Definition mk i t := [the measure _ _ of k mf i t]. +Definition mk i t : {measure set unit -> \bar R} := k mf i t. HB.instance Definition _ i := isKernel.Build _ _ _ _ _ (mk i) (measurable_fun_k i). @@ -191,77 +189,76 @@ End score. End SCORE. Section kscore. -Variables (R : realType) (d : _) (T : measurableType d) (r : T -> R). +Context d (T : measurableType d) (R : realType). +Variable f : T -> R. -Definition kscore (mr : measurable_fun setT r) - : T -> {measure set _ -> \bar R} := - fun t => [the measure _ _ of mscore r t]. +Definition kscore (mf : measurable_fun setT f) + : T -> {measure set unit -> \bar R} := + mscore f. -Variable (mr : measurable_fun setT r). +Variable mf : measurable_fun setT f. Let measurable_fun_kscore U : measurable U -> - measurable_fun setT (kscore mr ^~ U). + measurable_fun setT (kscore mf ^~ U). Proof. by move=> /= _; exact: measurable_fun_mscore. Qed. HB.instance Definition _ := isKernel.Build _ _ T _ R - (kscore mr) measurable_fun_kscore. + (kscore mf) measurable_fun_kscore. Import SCORE. -Let sfinite_kscore : exists k : (R.-fker T ~> _)^nat, - forall x U, measurable U -> - kscore mr x U = [the measure _ _ of mseries (k ^~ x) 0] U. +Let sfinite_kscore : exists k : (R.-fker T ~> unit)^nat, + forall x U, measurable U -> + kscore mf x U = mseries (k ^~ x) 0 U. Proof. -rewrite /=. -exists (fun i => [the R.-fker _ ~> _ of mk mr i]) => /= t U mU. +rewrite /=; exists (mk mf) => /= t U mU. rewrite /mseries /kscore/= mscoreE; case: ifPn => [/eqP U0|U0]. by apply/esym/eseries0 => i _; rewrite U0 measure0. rewrite /mk /= /k /= mscoreE (negbTE U0). apply/esym/cvg_lim => //. -rewrite -(cvg_shiftn `|floor (fine `|(r t)%:E|)|%N.+1)/=. -rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. +rewrite -(cvg_shiftn `|floor (fine `|(f t)%:E|)|%N.+1)/=. +rewrite (_ : (fun _ => _) = cst `|(f t)%:E|); first exact: cvg_cst. apply/funext => n. -pose floor_r := widen_ord (leq_addl n `|floor `|r t| |.+1) - (Ordinal (ltnSn `|floor `|r t| |)). -rewrite big_mkord (bigD1 floor_r)//= ifT; last first. +pose floor_f := widen_ord (leq_addl n `|floor `|f t| |.+1) + (Ordinal (ltnSn `|floor `|f t| |)). +rewrite big_mkord (bigD1 floor_f)//= ifT; last first. rewrite lee_fin lte_fin; apply/andP; split. - by rewrite natr_absz (@ger0_norm _ (floor `|r t|)) ?floor_ge0 ?floor_le. + by rewrite natr_absz (@ger0_norm _ (floor `|f t|)) ?floor_ge0 ?floor_le. rewrite -addn1 natrD natr_absz. - by rewrite (@ger0_norm _ (floor `|r t|)) ?floor_ge0 ?lt_succ_floor. + by rewrite (@ger0_norm _ (floor `|f t|)) ?floor_ge0 ?lt_succ_floor. rewrite big1 ?adde0//= => j jk. rewrite ifF// lte_fin lee_fin. move: jk; rewrite neq_ltn/= => /orP[|] jr. -- suff : (j.+1%:R <= `|r t|)%R by rewrite leNgt => /negbTE ->; rewrite andbF. +- suff : (j.+1%:R <= `|f t|)%R by rewrite leNgt => /negbTE ->; rewrite andbF. rewrite (_ : j.+1%:R = j.+1%:~R)// floor_ge_int. move: jr; rewrite -lez_nat => /le_trans; apply. - by rewrite -[leRHS](@ger0_norm _ (floor `|r t|)) ?floor_ge0. -- suff : (`|r t| < j%:R)%R by rewrite ltNge => /negbTE ->. - move: jr; rewrite -ltz_nat -(@ltr_int R) (@gez0_abs (floor `|r t|)) ?floor_ge0//. + by rewrite -[leRHS](@ger0_norm _ (floor `|f t|)) ?floor_ge0. +- suff : (`|f t| < j%:R)%R by rewrite ltNge => /negbTE ->. + move: jr; rewrite -ltz_nat -(@ltr_int R) (@gez0_abs (floor `|f t|)) ?floor_ge0//. by rewrite ltr_int -floor_lt_int. Qed. HB.instance Definition _ := - @Kernel_isSFinite.Build _ _ _ _ _ (kscore mr) sfinite_kscore. + @Kernel_isSFinite.Build _ _ _ _ _ (kscore mf) sfinite_kscore. End kscore. (* decomposition of ite into s-finite kernels *) Module ITE. Section ite. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variable R : realType. +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). 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. move=> /= mcU; rewrite /kiteT. -rewrite (_ : (fun _ => _) = (fun x => if x.2 then k x.1 U - else [the {measure set Y -> \bar R} of mzero] U)); last first. +rewrite (_ : (fun _ => _) = + (fun x => if x.2 then k x.1 U else mzero U)); last first. by apply/funext => -[t b]/=; case: ifPn. apply: (@measurable_fun_if_pair _ _ _ _ (k ^~ U) (fun=> mzero U)). exact/measurable_kernel. @@ -278,11 +275,10 @@ Variable k : R.-sfker X ~> Y. Let sfinite_kiteT : exists2 k_ : (R.-ker _ ~> _)^nat, forall n, measure_fam_uub (k_ n) & - forall x U, measurable U -> - kiteT k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. + forall x U, measurable U -> kiteT k x U = mseries (k_ ^~ x) 0 U. Proof. have [k_ hk /=] := sfinite k. -exists (fun n => [the _.-ker _ ~> _ of kiteT (k_ n)]) => /=. +exists (kiteT \o k_) => /=. move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). by exists r%:num => /= -[x []]; rewrite /kiteT//= /mzero//. move=> [x b] U mU; rewrite /kiteT; case: ifPn => hb; first by rewrite hk. @@ -313,13 +309,13 @@ 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. move=> /= mcU; rewrite /kiteF. -rewrite (_ : (fun x => _) = (fun x => if x.2 then - [the measure _ _ of mzero] U else k x.1 U)); last first. +rewrite (_ : (fun x => _) = + (fun x => if x.2 then mzero U else k x.1 U)); last first. by apply/funext => -[t b]/=; rewrite if_neg//; case: ifPn. apply: (@measurable_fun_if_pair _ _ _ _ (fun=> mzero U) (k ^~ U)). exact: measurable_fun_cst. @@ -337,11 +333,10 @@ Variable k : R.-sfker X ~> Y. Let sfinite_kiteF : exists2 k_ : (R.-ker _ ~> _)^nat, forall n, measure_fam_uub (k_ n) & - forall x U, measurable U -> - kiteF k x U = [the measure _ _ of mseries (k_ ^~ x) 0] U. + forall x U, measurable U -> kiteF k x U = mseries (k_ ^~ x) 0 U. Proof. have [k_ hk /=] := sfinite k. -exists (fun n => [the _.-ker _ ~> _ of kiteF (k_ n)]) => /=. +exists (kiteF \o k_) => /=. move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). by exists r%:num => /= -[x []]; rewrite /kiteF//= /mzero//. move=> [x b] U mU; rewrite /kiteF; case: ifPn => hb; first by rewrite hk. @@ -372,8 +367,8 @@ End ite. End ITE. Section ite. -Variables (d d' : _) (T : measurableType d) (T' : measurableType d'). -Variables (R : realType) (f : T -> bool) (u1 u2 : R.-sfker T ~> T'). +Context d d' (T : measurableType d) (T' : measurableType d') (R : realType). +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. @@ -396,53 +391,46 @@ HB.instance Definition _ t := isMeasure.Build _ _ _ (mite mf t) Import ITE. -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. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variable R : realType. +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Definition ret (f : X -> Y) (mf : measurable_fun setT f) := - locked [the R.-sfker X ~> Y of kdirac mf]. +Definition ret (f : X -> Y) (mf : measurable_fun setT f) + : R.-sfker X ~> Y := kdirac mf. -Definition sample (P : pprobability Y R) := - locked [the R.-pker X ~> Y of kprobability (measurable_fun_cst P)] . +Definition sample (P : pprobability Y R) : R.-pker X ~> Y := + kprobability (measurable_fun_cst P). -Definition normalize (k : R.-sfker X ~> Y) P x := - locked [the probability _ _ of mnormalize k P x]. +Definition normalize (k : R.-sfker X ~> Y) P : X -> probability Y R := + mnormalize k P. Definition ite (f : X -> bool) (mf : measurable_fun setT f) - (k1 k2 : R.-sfker X ~> Y):= - locked [the R.-sfker X ~> Y of kite k1 k2 mf]. + (k1 k2 : R.-sfker X ~> Y) : R.-sfker X ~> Y := + locked (kite k1 k2 mf). End insn2. Arguments ret {d d' X Y R f} mf. Arguments sample {d d' X Y R}. Section insn2_lemmas. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variable R : realType. +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Lemma retE (f : X -> Y) (mf : measurable_fun setT f) x : ret mf x = \d_(f x) :> (_ -> \bar R). -Proof. by rewrite [in LHS]/ret; unlock. Qed. +Proof. by []. Qed. Lemma sampleE (P : probability Y R) (x : X) : sample P x = P. -Proof. by rewrite [in LHS]/sample; unlock. Qed. +Proof. by []. Qed. Lemma normalizeE (f : R.-sfker X ~> Y) P x U : normalize f P x U = if (f x [set: Y] == 0) || (f x [set: Y] == +oo) then P U else f x U * ((fine (f x [set: Y]))^-1)%:E. -Proof. -by rewrite /normalize; unlock => /=; rewrite /mnormalize; case: ifPn. -Qed. +Proof. by rewrite /normalize /= /mnormalize; case: ifPn. Qed. Lemma iteE (f : X -> bool) (mf : measurable_fun setT f) (k1 k2 : R.-sfker X ~> Y) x : @@ -461,23 +449,20 @@ Qed. End insn2_lemmas. Section insn3. -Variables (R : realType). -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3). +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). -Definition letin (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) := - locked [the R.-sfker X ~> Z of l \; k]. +Definition letin (l : R.-sfker X ~> Y) (k : R.-sfker (X * Y)%type ~> Z) + : R.-sfker X ~> Z := + l \; k. End insn3. Section insn3_lemmas. -Variables (R : realType). -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3). +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). -Lemma letinE (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z) x U : +Lemma letinE (l : R.-sfker X ~> Y) (k : R.-sfker (X * Y)%type ~> Z) x U : letin l k x U = \int[l x]_y k (x, y) U. Proof. by rewrite /letin; unlock. Qed. @@ -485,8 +470,8 @@ End insn3_lemmas. (* rewriting laws *) Section letin_return. -Variables (d d' d3 : _) (R : realType) (X : measurableType d) - (Y : measurableType d') (Z : measurableType d3). +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 : @@ -502,7 +487,7 @@ Qed. Lemma letin_retk (f : X -> Y) (mf : measurable_fun setT f) - (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) + (k : R.-sfker (X * Y)%type ~> Z) x U : measurable U -> letin (ret mf) k x U = k (x, f x) U. Proof. @@ -514,16 +499,16 @@ Qed. End letin_return. Section insn1. -Variables (R : realType) (d : _) (X : measurableType d). +Context d (X : measurableType d) (R : realType). -Definition score (f : X -> R) (mf : measurable_fun setT f) := - [the R.-sfker X ~> _ of kscore mf]. +Definition score (f : X -> R) (mf : measurable_fun setT f) + : R.-sfker X ~> unit := + kscore mf. End insn1. Section hard_constraint. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d'). -Variable R : realType. +Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Definition fail := letin (score (@measurable_fun_cst _ _ X _ setT (0%R : R))) @@ -552,7 +537,7 @@ Notation mbool := Datatypes_bool__canonical__measure_Measurable. End Notations. Section cst_fun. -Variables (R : realType) (d : _) (T : measurableType d). +Context d (T : measurableType d) (R : realType). Definition kr (r : R) := @measurable_fun_cst _ _ T _ setT r. Definition k3 : measurable_fun _ _ := kr 3%:R. @@ -560,17 +545,17 @@ Definition k10 : measurable_fun _ _ := kr 10%:R. Definition ktt := @measurable_fun_cst _ _ T _ setT tt. End cst_fun. -Arguments kr {R d T}. -Arguments k3 {R d T}. -Arguments k10 {R d T}. +Arguments kr {d T R}. +Arguments k3 {d T R}. +Arguments k10 {d T R}. Arguments ktt {d T}. Section insn1_lemmas. Import Notations. -Variables (R : realType) (d : _) (T : measurableType d). +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) + (g : R.-sfker (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. @@ -609,15 +594,15 @@ apply/eq_sfkernel => x U. rewrite letinE/= /sample; unlock. rewrite integral_measure_add//= ge0_integral_mscale//= ge0_integral_mscale//=. rewrite integral_dirac//= integral_dirac//= !indicT/= !mul1e. -by rewrite iteE//= iteE//= /mscale/= failE retE//= mule0 adde0 ger0_norm. +by rewrite /mscale/= iteE//= iteE//= failE mule0 adde0 ger0_norm. Qed. End insn1_lemmas. Section letin_ite. -Variables (R : realType) (d d2 d3 : _) (T : measurableType d) - (T2 : measurableType d2) (Z : measurableType d3) - (k1 k2 : R.-sfker T ~> Z) (u : R.-sfker [the measurableType _ of (T * Z)%type] ~> T2) +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 (T * Z)%type ~> T2) (f : T -> bool) (mf : measurable_fun setT f) (t : T) (U : set T2). @@ -640,16 +625,16 @@ Qed. End letin_ite. Section letinC. -Variables (d d1 : _) (X : measurableType d) (Y : measurableType d1). -Variables (R : realType) (d' : _) (Z : measurableType d'). +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) + (t' : R.-sfker (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) + (u' : R.-sfker (Z * X)%type ~> Y) (uu' : forall x, u =1 fun z => u' (z, x)). Lemma letinC z A : measurable A -> @@ -664,7 +649,7 @@ move=> mA. rewrite !letinE. under eq_integral. move=> x _. - rewrite letinE/= -uu'. + rewrite letinE -uu'. under eq_integral do rewrite retE /=. over. rewrite (sfinite_fubini _ _ (fun x => \d_(x.1, x.2) A ))//; last 3 first. @@ -750,20 +735,20 @@ Qed. End exponential. -Lemma letin_sample_bernoulli (R : realType) (d d' : _) (T : measurableType d) - (T' : measurableType d') (r : {nonneg R}) (r1 : (r%:num <= 1)%R) +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 (bernoulli r1)) u x y = r%:num%:E * u (x, true) y + (`1- (r%:num : R))%:E * u (x, false) y. Proof. -rewrite letinE/= sampleE. +rewrite letinE/=. rewrite ge0_integral_measure_sum// 2!big_ord_recl/= big_ord0 adde0/=. by rewrite !ge0_integral_mscale//= !integral_dirac//= indicT 2!mul1e. Qed. Section sample_and_return. Import Notations. -Variables (R : realType) (d : _) (T : measurableType d). +Context d (T : measurableType d) (R : realType). Definition sample_and_return : R.-sfker T ~> _ := letin @@ -774,7 +759,7 @@ 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. rewrite /sample_and_return. -rewrite letin_sample_bernoulli/=. +rewrite letin_sample_bernoulli. rewrite !retE. by rewrite onem27. Qed. @@ -784,7 +769,7 @@ End sample_and_return. (* trivial example *) Section sample_and_branch. Import Notations. -Variables (R : realType) (d : _) (T : measurableType d). +Context d (T : measurableType d) (R : realType). (* let x = sample (bernoulli (2/7)) in let r = case x of {(1, _) => return (k3()), (2, _) => return (k10())} in @@ -801,7 +786,7 @@ Lemma sample_and_branchE t U : sample_and_branch t U = (5%:R / 7%:R)%:E * \d_(10%:R : R) U. Proof. rewrite /sample_and_branch letin_sample_bernoulli/=. -rewrite !iteE/= !retE. +rewrite !iteE !retE. by rewrite onem27. Qed. @@ -809,7 +794,7 @@ End sample_and_branch. Section staton_bus. Import Notations. -Variables (R : realType) (d : _) (T : measurableType d) (h : R -> R). +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 (bernoulli p27)) @@ -828,7 +813,7 @@ End staton_bus. return x *) Section staton_bus_poisson. Import Notations. -Variables (R : realType) (d : _) (T : measurableType d). +Context d (T : measurableType d) (R : realType). Let poisson4 := @poisson R 4%N. Let mpoisson4 := @mpoisson R 4%N. @@ -876,7 +861,7 @@ End staton_bus_poisson. return x *) Section staton_bus_exponential. Import Notations. -Variables (R : realType) (d : _) (T : measurableType d). +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)). diff --git a/theories/wip.v b/theories/wip.v index 22a13a661d..41b6a28988 100644 --- a/theories/wip.v +++ b/theories/wip.v @@ -105,7 +105,7 @@ End gauss. Section gauss_lebesgue. Import Notations. -Variables (R : realType) (d : _) (T : measurableType d). +Context d (T : measurableType d) (R : realType). Let f1 (x : R) := (gauss01_density x) ^-1. @@ -131,16 +131,13 @@ Lemma staton_lebesgueE x U : measurable U -> staton_lebesgue x U = lebesgue_measure U. Proof. move=> mU; rewrite [in LHS]/staton_lebesgue/=. -rewrite [in LHS]letinE. -rewrite [in LHS]/sample. -unlock. -rewrite [in LHS]/=. +rewrite [in LHS]letinE /=. transitivity (\int[@mgauss01 R]_(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 integral_dirac// indicT mul1e retE/= diracE indicE. + by rewrite integral_dirac// indicT mul1e diracE indicE. transitivity (\int[lebesgue_measure]_(x in U) (gauss01_density x * f1 x)%:E). admit. transitivity (\int[lebesgue_measure]_(x in U) (\1_U x)%:E). From 2cdb09d0e4203cbea4d873ca3bea6a400fab9e90 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Mon, 9 Jan 2023 11:19:20 +0900 Subject: [PATCH 28/54] upd wrt recent PRs, compat with Coq 8.15 --- theories/kernel.v | 86 ++++++++++++++++---------------------------- theories/prob_lang.v | 76 +++++++++++++++++++++------------------ 2 files changed, 73 insertions(+), 89 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 4f08ec2a60..10a2894046 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -101,35 +101,12 @@ Lemma xsection_preimage_snd (X Y Z : Type) (f : Y -> Z) (A : set Z) (x : X) : xsection ((f \o snd) @^-1` A) x = f @^-1` A. Proof. by apply/seteqP; split; move=> y/=; rewrite /xsection/= inE. Qed. -Canonical unit_pointedType := PointedType unit tt. - -Section discrete_measurable_unit. - -Definition discrete_measurable_unit : set (set unit) := [set: set unit]. - -Let discrete_measurable0 : discrete_measurable_unit set0. Proof. by []. Qed. - -Let discrete_measurableC X : - discrete_measurable_unit X -> discrete_measurable_unit (~` X). -Proof. by []. Qed. - -Let discrete_measurableU (F : (set unit)^nat) : - (forall i, discrete_measurable_unit (F i)) -> - discrete_measurable_unit (\bigcup_i F i). -Proof. by []. Qed. - -HB.instance Definition _ := @isMeasurable.Build default_measure_display unit - (Pointed.class _) discrete_measurable_unit discrete_measurable0 - discrete_measurableC discrete_measurableU. - -End discrete_measurable_unit. - Lemma measurable_curry (T1 T2 : Type) d (T : semiRingOfSetsType d) (G : T1 * T2 -> set T) (x : T1 * T2) : measurable (G x) <-> measurable (curry G x.1 x.2). Proof. by case: x. Qed. -Lemma emeasurable_itv (R : realType) (i : nat) : +Lemma emeasurable_itv1 (R : realType) (i : nat) : measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set \bar R). Proof. rewrite -[X in measurable X]setCK. @@ -143,13 +120,13 @@ Qed. Lemma measurable_fun_fst d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) : measurable_fun setT (@fst T1 T2). Proof. -by have /prod_measurable_funP[] := @measurable_fun_id _ (T1 * T2)%type setT. +by have /prod_measurable_funP[] := @measurable_fun_id _ [the measurableType _ of (T1 * T2)%type] setT. Qed. Lemma measurable_fun_snd d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) : measurable_fun setT (@snd T1 T2). Proof. -by have /prod_measurable_funP[] := @measurable_fun_id _ (T1 * T2)%type setT. +by have /prod_measurable_funP[] := @measurable_fun_id _ [the measurableType _ of (T1 * T2)%type] setT. Qed. Definition swap (T1 T2 : Type) (x : T1 * T2) := (x.2, x.1). @@ -243,10 +220,6 @@ Proof. by rewrite -fubini_tonelli1// fubini_tonelli2. Qed. End fubini_tonelli. (* /TODO: PR *) -Definition finite_measure d (T : measurableType d) (R : realType) - (mu : set T -> \bar R) := - mu setT < +oo. - Definition sfinite_measure d (T : measurableType d) (R : realType) (mu : set T -> \bar R) := exists2 s : {measure set T -> \bar R}^nat, @@ -274,7 +247,7 @@ Lemma sfinite_fubini : Proof. have [s1 fm1 m1E] := sfm1. have [s2 fm2 m2E] := sfm2. -rewrite [LHS](eq_measure_integral (mseries s1 0)); last first. +rewrite [LHS](eq_measure_integral [the measure _ _ of mseries s1 0]); last first. by move=> A mA _; rewrite m1E. transitivity (\int[mseries s1 0]_x \int[mseries s2 0]_y f (x, y)). by apply eq_integral => x _; apply: eq_measure_integral => ? ? _; rewrite m2E. @@ -352,7 +325,7 @@ Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Variable k : (R.-ker X ~> Y)^nat. Definition kseries : X -> {measure set Y -> \bar R} := - fun x => mseries (k ^~ x) 0. + fun x => [the measure _ _ of mseries (k ^~ x) 0]. Lemma measurable_fun_kseries (U : set Y) : measurable U -> @@ -441,7 +414,7 @@ HB.factory Record Kernel_isFinite d d' (X : measurableType d) Section kzero. Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Definition kzero : X -> {measure set Y -> \bar R} := fun _ : X => mzero. +Definition kzero : X -> {measure set Y -> \bar R} := fun _ : X => [the measure _ _ of mzero]. Let measurable_fun_kzero U : measurable U -> measurable_fun setT (kzero ^~ U). @@ -463,7 +436,7 @@ Lemma sfinite_finite : forall x U, measurable U -> k x U = mseries (k_ ^~ x) 0 U. Proof. exists (fun n => if n is O then [the _.-ker _ ~> _ of k] else - @kzero _ _ X Y R). + [the _.-ker _ ~> _ of @kzero _ _ X Y R]). by case => [|_]; [exact: measure_uub|exact: kzero_uub]. move=> t U mU/=; rewrite /mseries. rewrite (nneseries_split 1%N)// big_ord_recl/= big_ord0 adde0. @@ -503,7 +476,7 @@ HB.instance Definition _ n := Lemma sfinite : exists s : (R.-fker X ~> Y)^nat, forall x U, measurable U -> k x U = kseries s x U. Proof. -by exists s => x U mU; rewrite /s /= /s; by case: cid2 => ? ? ->. +by exists (fun n => [the _.-fker _ ~> _ of s n]) => x U mU; rewrite /s /= /s; by case: cid2 => ? ? ->. Qed. End sfinite. @@ -703,7 +676,7 @@ Variable k : X * Y -> \bar R. Lemma measurable_fun_xsection_integral (l : X -> {measure set Y -> \bar R}) - (k_ : ({nnsfun (X * Y)%type >-> R})^nat) + (k_ : ({nnsfun [the measurableType _ of (X * Y)%type] >-> R})^nat) (ndk_ : nondecreasing_seq (k_ : (X * Y -> R)^nat)) (k_k : forall z, EFin \o (k_ ^~ z) --> k z) : (forall n r, measurable_fun setT (fun x => l x (xsection (k_ n @^-1` [set r]) x))) -> @@ -738,7 +711,8 @@ rewrite [X in measurable_fun _ X](_ : _ = (fun x => \sum_(r \in range (k_ n)) - by apply: eq_integral => y _; rewrite -fsumEFin. - move=> r. apply/EFin_measurable_fun/measurable_funrM/measurable_fun_prod1 => /=. - by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). + rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r))//. + exact/measurable_funP. - by move=> m y _; rewrite nnfun_muleindic_ge0. apply: emeasurable_fun_fsum => // r. rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * @@ -747,7 +721,8 @@ rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * have [r0|r0] := leP 0%R r. rewrite ge0_integralM//; last by move=> y _; rewrite lee_fin. apply/EFin_measurable_fun/measurable_fun_prod1 => /=. - by rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r)). + rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r))//. + exact/measurable_funP. rewrite integral_eq0; last first. by move=> y _; rewrite preimage_nnfun0// indic0 mule0. by rewrite integral_eq0 ?mule0// => y _; rewrite preimage_nnfun0// indic0. @@ -805,7 +780,7 @@ Variable f : X -> Y. Definition kdirac (mf : measurable_fun setT f) : X -> {measure set Y -> \bar R} := - fun x => dirac (f x). + fun x => [the measure _ _ of dirac (f x)]. Hypothesis mf : measurable_fun setT f. @@ -831,7 +806,7 @@ Arguments kdirac {d d' X Y R f}. Section dist_salgebra_instance. Context d (T : measurableType d) (R : realType). -Let p0 : probability T R := dirac point. +Let p0 : probability T R := [the probability _ _ of dirac point]. Definition prob_pointed := Pointed.Class (Choice.Class gen_eqMixin (Choice.Class gen_eqMixin gen_choiceMixin)) p0. @@ -857,7 +832,7 @@ Qed. Definition pset : set (set (probability T R)) := [set mset U r | r in `[0%R,1%R] & U in measurable]. -Definition pprobability : measurableType pset.-sigma := salgebraType pset. +Definition pprobability : measurableType pset.-sigma := [the measurableType _ of salgebraType pset]. End dist_salgebra_instance. @@ -898,7 +873,7 @@ Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Variables k1 k2 : R.-ker X ~> Y. Definition kadd : X -> {measure set Y -> \bar R} := - fun x => measure_add (k1 x) (k2 x). + fun x => [the measure _ _ of measure_add (k1 x) (k2 x)]. Let measurable_fun_kadd U : measurable U -> measurable_fun setT (kadd ^~ U). @@ -922,7 +897,7 @@ Let sfinite_kadd : exists2 k_ : (R.-ker _ ~> _)^nat, forall n, measure_fam_uub ( kadd k1 k2 x U = mseries (k_ ^~ x) 0 U. Proof. have [f1 hk1] := sfinite k1; have [f2 hk2] := sfinite k2. -exists (fun n => kadd (f1 n) (f2 n)). +exists (fun n => [the _.-ker _ ~> _ of kadd (f1 n) (f2 n)]). move=> n. have [r1 f1r1] := measure_uub (f1 n). have [r2 f2r2] := measure_uub (f2 n). @@ -1046,7 +1021,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} := - mnormalize f P. + fun x => [the measure _ _ of mnormalize f P x]. Variable P : probability Y R. @@ -1113,7 +1088,7 @@ Section kcomp_is_measure. Context d1 d2 d3 (X : measurableType d1) (Y : measurableType d2) (Z : measurableType d3) (R : realType). Variable l : R.-ker X ~> Y. -Variable k : R.-ker (X * Y)%type ~> Z. +Variable k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z. Local Notation "l \; k" := (kcomp l k). @@ -1139,7 +1114,7 @@ Qed. HB.instance Definition _ x := isMeasure.Build _ R _ ((l \; k) x) (kcomp0 x) (kcomp_ge0 x) (@kcomp_sigma_additive x). -Definition mkcomp : X -> {measure set Z -> \bar R} := l \; k. +Definition mkcomp : X -> {measure set Z -> \bar R} := fun x => [the measure _ _ of (l \; k) x]. End kcomp_is_measure. @@ -1150,7 +1125,7 @@ Module KCOMP_FINITE_KERNEL. Section kcomp_finite_kernel_kernel. Context d d' d3 (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType) (l : R.-fker X ~> Y) - (k : R.-ker (X * Y)%type ~> Z). + (k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z). Lemma measurable_fun_kcomp_finite U : measurable U -> measurable_fun setT ((l \; k) ^~ U). @@ -1168,7 +1143,7 @@ Section kcomp_finite_kernel_finite. Context d d' d3 (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType). Variable l : R.-fker X ~> Y. -Variable k : R.-fker (X * Y)%type ~> Z. +Variable k : R.-fker [the measurableType _ of (X * Y)%type] ~> Z. Let mkcomp_finite : measure_fam_uub (l \; k). Proof. @@ -1194,7 +1169,7 @@ Section kcomp_sfinite_kernel. Context d d' d3 (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType). Variable l : R.-sfker X ~> Y. -Variable k : R.-sfker (X * Y)%type ~> Z. +Variable k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. Import KCOMP_FINITE_KERNEL. @@ -1206,10 +1181,10 @@ have [kl hkl] : exists kl : (R.-fker X ~> Z) ^nat, forall x U, \esum_(i in setT) (l_ i.2 \; k_ i.1) x U = \sum_(i l_ (f i).2 \; k_ (f i).1) => x U. + exists (fun i => [the _.-fker _ ~> _ of l_ (f i).2 \; k_ (f i).1]) => x U. by rewrite (reindex_esum [set: nat] _ f)// nneseries_esum// fun_true. exists kl => x U mU. -transitivity ((kseries l_ \; kseries k_) x U). +transitivity (([the _.-ker _ ~> _ of kseries l_] \; [the _.-ker _ ~> _ of kseries k_]) x U). rewrite /= /kcomp [in RHS](eq_measure_integral (l x)); last first. by move=> *; rewrite hl_. by apply: eq_integral => y _; rewrite hk_. @@ -1239,7 +1214,7 @@ Section kcomp_sfinite_kernel. Context d d' d3 (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType). Variable l : R.-sfker X ~> Y. -Variable k : R.-sfker (X * Y)%type ~> Z. +Variable k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. HB.instance Definition _ := isKernel.Build _ _ X Z R (l \; k) (measurable_fun_mkcomp_sfinite l k). @@ -1283,7 +1258,8 @@ Lemma measurable_fun_preimage_integral (l : X -> {measure set Y -> \bar R}) : (forall n r, measurable_fun setT (l ^~ (k_ n @^-1` [set r]))) -> measurable_fun setT (fun x => \int[l x]_z k z). Proof. -move=> h; apply: (measurable_fun_xsection_integral (k \o snd) l k_2) => /=. +move=> h; apply: (measurable_fun_xsection_integral (k \o snd) l + (fun n => [the {nnsfun _ >-> _} of k_2 n])) => /=. - by rewrite /k_2 => m n mn; apply/lefP => -[x y] /=; exact/lefP/ndk_. - by move=> [x y]; exact: k_k. - move=> n r _ /= B mB. @@ -1310,7 +1286,7 @@ Qed. Section integral_kcomp. Context d d2 d3 (X : measurableType d) (Y : measurableType d2) (Z : measurableType d3) (R : realType). -Variables (l : R.-sfker X ~> Y) (k : R.-sfker (X * Y)%type ~> Z). +Variables (l : R.-sfker X ~> Y) (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z). Let integral_kcomp_indic x E (mE : measurable E) : \int[(l \; k) x]_z (\1_E z)%:E = \int[l x]_y (\int[k (x, y)]_z (\1_E z)%:E). @@ -1351,7 +1327,7 @@ rewrite /= ge0_integral_fsum//; last 2 first. - move=> n y _. have := mulemu_ge0 (fun n => f @^-1` [set n]). by apply; exact: preimage_nnfun0. -apply eq_fsbigr => r _. +apply: eq_fsbigr => r _. rewrite (integralM_indic _ (fun r => f @^-1` [set r]))//; last first. exact: preimage_nnfun0. rewrite /= integral_kcomp_indic; last exact/measurable_sfunP. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 4a76560f7b..4bbc420f08 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -59,9 +59,10 @@ Section bernoulli. Variables (R : realType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R). Local Open Scope ring_scope. -Definition bernoulli := measure_add - (mscale p (dirac true)) - (mscale (onem_nonneg p1) (dirac false)). +Definition bernoulli : set _ -> \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]]. HB.instance Definition _ := Measure.on bernoulli. @@ -81,9 +82,9 @@ Section mscore. Context d (T : measurableType d) (R : realType). Variable f : T -> R. -Definition mscore t : {measure set unit -> \bar R} := +Definition mscore t : {measure set _ -> \bar R} := let p := NngNum (normr_ge0 (f t)) in - mscale p (dirac tt). + [the measure _ _ of mscale p [the measure _ _ of dirac tt]]. Lemma mscoreE t U : mscore t U = if U == set0 then 0 else `| (f t)%:E |. Proof. @@ -168,10 +169,10 @@ rewrite (_ : (fun x => _) = (fun x => x * by rewrite indicE/= memNset ?mule0// /= in_itv/=; exact/negP. apply emeasurable_funM => /=; first exact: measurable_fun_id. apply/EFin_measurable_fun. -by rewrite (_ : \1__ = mindic R (emeasurable_itv R i)). +by rewrite (_ : \1__ = mindic R (emeasurable_itv1 R i)). Qed. -Definition mk i t : {measure set unit -> \bar R} := k mf i t. +Definition mk i t := [the measure _ _ of k mf i t]. HB.instance Definition _ i := isKernel.Build _ _ _ _ _ (mk i) (measurable_fun_k i). @@ -193,7 +194,7 @@ Context d (T : measurableType d) (R : realType). Variable f : T -> R. Definition kscore (mf : measurable_fun setT f) - : T -> {measure set unit -> \bar R} := + : T -> {measure set _ -> \bar R} := mscore f. Variable mf : measurable_fun setT f. @@ -207,11 +208,11 @@ HB.instance Definition _ := isKernel.Build _ _ T _ R Import SCORE. -Let sfinite_kscore : exists k : (R.-fker T ~> unit)^nat, +Let sfinite_kscore : exists k : (R.-fker T ~> _)^nat, forall x U, measurable U -> kscore mf x U = mseries (k ^~ x) 0 U. Proof. -rewrite /=; exists (mk mf) => /= t U mU. +rewrite /=; exists (fun i => [the R.-fker _ ~> _ of mk mf i]) => /= t U mU. rewrite /mseries /kscore/= mscoreE; case: ifPn => [/eqP U0|U0]. by apply/esym/eseries0 => i _; rewrite U0 measure0. rewrite /mk /= /k /= mscoreE (negbTE U0). @@ -252,7 +253,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 mzero. + fun xb => if xb.2 then k xb.1 else [the measure _ _ of mzero]. Let measurable_fun_kiteT U : measurable U -> measurable_fun setT (kiteT ^~ U). Proof. @@ -278,7 +279,7 @@ Let sfinite_kiteT : exists2 k_ : (R.-ker _ ~> _)^nat, forall x U, measurable U -> kiteT k x U = mseries (k_ ^~ x) 0 U. Proof. have [k_ hk /=] := sfinite k. -exists (kiteT \o k_) => /=. +exists (fun n => [the _.-ker _ ~> _ of kiteT (k_ n)]) => /=. move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). by exists r%:num => /= -[x []]; rewrite /kiteT//= /mzero//. move=> [x b] U mU; rewrite /kiteT; case: ifPn => hb; first by rewrite hk. @@ -309,7 +310,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 mzero. + fun xb => if ~~ xb.2 then k xb.1 else [the measure _ _ of mzero]. Let measurable_fun_kiteF U : measurable U -> measurable_fun setT (kiteF ^~ U). Proof. @@ -336,7 +337,7 @@ Let sfinite_kiteF : exists2 k_ : (R.-ker _ ~> _)^nat, forall x U, measurable U -> kiteF k x U = mseries (k_ ^~ x) 0 U. Proof. have [k_ hk /=] := sfinite k. -exists (kiteF \o k_) => /=. +exists (fun n => [the _.-ker _ ~> _ of kiteF (k_ n)]) => /=. move=> n; have /measure_fam_uubP[r k_r] := measure_uub (k_ n). by exists r%:num => /= -[x []]; rewrite /kiteF//= /mzero//. move=> [x b] U mU; rewrite /kiteF; case: ifPn => hb; first by rewrite hk. @@ -391,8 +392,15 @@ HB.instance Definition _ t := isMeasure.Build _ _ _ (mite mf t) 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] ]. End ite. @@ -400,17 +408,17 @@ Section insn2. Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Definition ret (f : X -> Y) (mf : measurable_fun setT f) - : R.-sfker X ~> Y := kdirac mf. + : R.-sfker X ~> Y := [the R.-sfker _ ~> _ of kdirac mf]. Definition sample (P : pprobability Y R) : R.-pker X ~> Y := - kprobability (measurable_fun_cst P). + [the R.-pker _ ~> _ of kprobability (measurable_fun_cst P)]. Definition normalize (k : R.-sfker X ~> Y) P : X -> probability Y R := - mnormalize k P. + fun x => [the probability _ _ of mnormalize k P x]. Definition ite (f : X -> bool) (mf : measurable_fun setT f) (k1 k2 : R.-sfker X ~> Y) : R.-sfker X ~> Y := - locked (kite k1 k2 mf). + locked [the R.-sfker X ~> Y of kite k1 k2 mf]. End insn2. Arguments ret {d d' X Y R f} mf. @@ -452,9 +460,9 @@ Section insn3. Context d d' d3 (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType). -Definition letin (l : R.-sfker X ~> Y) (k : R.-sfker (X * Y)%type ~> Z) +Definition letin (l : R.-sfker X ~> Y) (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) : R.-sfker X ~> Z := - l \; k. + [the R.-sfker X ~> Z of l \; k]. End insn3. @@ -462,9 +470,9 @@ Section insn3_lemmas. Context d d' d3 (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType). -Lemma letinE (l : R.-sfker X ~> Y) (k : R.-sfker (X * Y)%type ~> Z) x U : +Lemma letinE (l : R.-sfker X ~> Y) (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) x U : letin l k x U = \int[l x]_y k (x, y) U. -Proof. by rewrite /letin; unlock. Qed. +Proof. by []. Qed. End insn3_lemmas. @@ -487,7 +495,7 @@ Qed. Lemma letin_retk (f : X -> Y) (mf : measurable_fun setT f) - (k : R.-sfker (X * Y)%type ~> Z) + (k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z) x U : measurable U -> letin (ret mf) k x U = k (x, f x) U. Proof. @@ -502,8 +510,8 @@ Section insn1. Context d (X : measurableType d) (R : realType). Definition score (f : X -> R) (mf : measurable_fun setT f) - : R.-sfker X ~> unit := - kscore mf. + : R.-sfker X ~> _ := + [the R.-sfker X ~> _ of kscore mf]. End insn1. @@ -555,7 +563,7 @@ Import Notations. Context d (T : measurableType d) (R : realType). Let kcomp_scoreE d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) - (g : R.-sfker (T1 * unit)%type ~> T2) + (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. @@ -587,7 +595,7 @@ Import Notations. (* hard constraints to express score below 1 *) Lemma score_fail (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : score (kr r%:num) = - letin (sample (bernoulli r1) : R.-pker T ~> _) + letin (sample [the probability _ _ of bernoulli r1] : R.-pker T ~> _) (ite var2of2 (ret ktt) fail). Proof. apply/eq_sfkernel => x U. @@ -602,7 +610,7 @@ 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 (T * Z)%type ~> T2) +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). @@ -631,10 +639,10 @@ Context d d1 d' (X : measurableType d) (Y : measurableType d1) Import Notations. Variables (t : R.-sfker Z ~> X) - (t' : R.-sfker (Z * Y)%type ~> 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 (Z * X)%type ~> Y) + (u' : R.-sfker [the measurableType _ of (Z * X)%type] ~> Y) (uu' : forall x, u =1 fun z => u' (z, x)). Lemma letinC z A : measurable A -> @@ -738,7 +746,7 @@ End exponential. 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 (bernoulli r1)) u x y = + letin (sample [the probability _ _ of bernoulli r1]) u x y = r%:num%:E * u (x, true) y + (`1- (r%:num : R))%:E * u (x, false) y. Proof. rewrite letinE/=. @@ -752,7 +760,7 @@ Context d (T : measurableType d) (R : realType). Definition sample_and_return : R.-sfker T ~> _ := letin - (sample (bernoulli p27)) (* T -> B *) + (sample [the probability _ _ of bernoulli p27]) (* T -> B *) (ret var2of2) (* T * B -> B *). Lemma sample_and_returnE t U : sample_and_return t U = @@ -778,7 +786,7 @@ Context d (T : measurableType d) (R : realType). Definition sample_and_branch : R.-sfker T ~> mR R := letin - (sample (bernoulli p27)) (* T -> B *) + (sample [the probability _ _ of bernoulli p27]) (* T -> B *) (ite var2of2 (ret k3) (ret k10)). Lemma sample_and_branchE t U : sample_and_branch t U = @@ -797,7 +805,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 (bernoulli p27)) + letin (sample [the probability _ _ of bernoulli p27]) (letin (letin (ite var2of2 (ret k3) (ret k10)) (score (measurable_fun_comp mh var3of3))) From 30af345b2572f54d242ce80ae9202be7e7447779 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Tue, 10 Jan 2023 21:42:42 +0900 Subject: [PATCH 29/54] simple example --- theories/prob_lang.v | 56 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 4bbc420f08..9ba16e6afc 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -677,6 +677,12 @@ Section constants. Variable R : realType. Local Open Scope ring_scope. +Lemma onem12 : `1- (1 / 2%:R) = (1%:R / 2%:R)%:nng%:num :> R. +Proof. by rewrite /onem/= {1}(splitr 1) addrK. Qed. + +Lemma p12 : (1 / 2%:R)%:nng%:num <= 1 :> R. +Proof. by rewrite ler_pdivr_mulr//= mul1r ler1n. 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. @@ -684,6 +690,7 @@ Lemma p27 : (2 / 7%:R)%:nng%:num <= 1 :> R. Proof. by rewrite /= lter_pdivr_mulr// mul1r ler_nat. Qed. End constants. +Arguments p12 {R}. Arguments p27 {R}. Section poisson. @@ -800,6 +807,54 @@ Qed. End sample_and_branch. +Section bernoulli_and. +Context d (T : measurableType d) (R : realType). +Import Notations. + +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: (@emeasurable_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 [the probability _ _ of bernoulli p12]) + (letin (sample [the probability _ _ of bernoulli p12]) + (ret (measurable_fun_mand var2of3 var3of3)))). + +Lemma bernoulli_andE t U : + bernoulli_and t U = (1 / 4 * \1_U true)%:E + (3 / 4 * \1_U false)%:E. +Proof. +rewrite /bernoulli_and. +rewrite !letin_sample_bernoulli//=. +rewrite /mand/=. +rewrite muleDr//=. +rewrite -muleDl//. +rewrite !muleA. +rewrite -addeA. +rewrite -muleDl//. +rewrite -!EFinM. +rewrite !onem12/= -splitr mulr1. +have -> : (1 / 2 * (1 / 2) = 1 / 4 :> R)%R. + by rewrite mulf_div mulr1// -natrM. +congr (_ + (_ * _)%:E). +have -> : (1 / 2 = 2 / 4 :> R)%R. + by apply/eqP; rewrite eqr_div// ?pnatr_eq0// mul1r -natrM. +by rewrite -mulrDl. +Qed. + +End bernoulli_and. + Section staton_bus. Import Notations. Context d (T : measurableType d) (R : realType) (h : R -> R). @@ -913,3 +968,4 @@ by rewrite addr_gt0// mulr_gt0//= ?divr_gt0// ?ltr0n// exp_density_gt0 ?ltr0n. Qed. End staton_bus_exponential. + From da98948865525bcd998ae6e66ee32ea487916b48 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Tue, 17 Jan 2023 01:53:51 +0900 Subject: [PATCH 30/54] letinA --- theories/kernel.v | 216 +++++-------------------------------------- theories/prob_lang.v | 54 +++++++++-- 2 files changed, 69 insertions(+), 201 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 10a2894046..f0295acffe 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -41,71 +41,7 @@ Local Open Scope classical_set_scope. Local Open Scope ring_scope. Local Open Scope ereal_scope. -(* PR 516 in progress *) -HB.mixin Record isProbability d (T : measurableType d) - (R : realType) (P : set T -> \bar R) of isMeasure d R T P := - { probability_setT : P setT = 1%E }. - -#[short(type=probability)] -HB.structure Definition Probability d (T : measurableType d) (R : realType) := - {P of isProbability d T R P & isMeasure d R T P }. - -Section probability_lemmas. -Context d (T : measurableType d) (R : realType) (P : probability T R). - -Lemma probability_le1 (A : set T) : measurable A -> (P A <= 1)%E. -Proof. -move=> mA; rewrite -(@probability_setT _ _ _ P). -by apply: le_measure => //; rewrite ?in_setE. -Qed. - -End probability_lemmas. -(* /PR 516 in progress *) - (* TODO: PR*) -Lemma setT0 (T : pointedType) : setT != set0 :> set T. -Proof. by apply/eqP => /seteqP[] /(_ point) /(_ Logic.I). Qed. - -Lemma set_unit (A : set unit) : A = set0 \/ A = setT. -Proof. -have [->|/set0P[[] Att]] := eqVneq A set0; [by left|right]. -by apply/seteqP; split => [|] []. -Qed. - -Lemma set_boolE (B : set bool) : [\/ B == [set true], B == [set false], B == set0 | B == setT]. -Proof. -have [Bt|Bt] := boolP (true \in B). - have [Bf|Bf] := boolP (false \in B). - have -> : B = setT. - by apply/seteqP; split => // -[] _; [rewrite inE in Bt| rewrite inE in Bf]. - by apply/or4P; rewrite eqxx/= !orbT. - have -> : B = [set true]. - apply/seteqP; split => -[]//=. - by rewrite notin_set in Bf. - by rewrite inE in Bt. - by apply/or4P; rewrite eqxx. -have [Bf|Bf] := boolP (false \in B). - have -> : B = [set false]. - apply/seteqP; split => -[]//=. - by rewrite notin_set in Bt. - by rewrite inE in Bf. - by apply/or4P; rewrite eqxx/= orbT. -have -> : B = set0. - apply/seteqP; split => -[]//=. - by rewrite notin_set in Bt. - by rewrite notin_set in Bf. -by apply/or4P; rewrite eqxx/= !orbT. -Qed. - -Lemma xsection_preimage_snd (X Y Z : Type) (f : Y -> Z) (A : set Z) (x : X) : - xsection ((f \o snd) @^-1` A) x = f @^-1` A. -Proof. by apply/seteqP; split; move=> y/=; rewrite /xsection/= inE. Qed. - -Lemma measurable_curry (T1 T2 : Type) d (T : semiRingOfSetsType d) - (G : T1 * T2 -> set T) (x : T1 * T2) : - measurable (G x) <-> measurable (curry G x.1 x.2). -Proof. by case: x. Qed. - Lemma emeasurable_itv1 (R : realType) (i : nat) : measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set \bar R). Proof. @@ -117,109 +53,6 @@ apply: measurableU. exact: emeasurable_itv_bnd_pinfty. Qed. -Lemma measurable_fun_fst d1 d2 (T1 : measurableType d1) - (T2 : measurableType d2) : measurable_fun setT (@fst T1 T2). -Proof. -by have /prod_measurable_funP[] := @measurable_fun_id _ [the measurableType _ of (T1 * T2)%type] setT. -Qed. - -Lemma measurable_fun_snd d1 d2 (T1 : measurableType d1) - (T2 : measurableType d2) : measurable_fun setT (@snd T1 T2). -Proof. -by have /prod_measurable_funP[] := @measurable_fun_id _ [the measurableType _ of (T1 * T2)%type] setT. -Qed. - -Definition swap (T1 T2 : Type) (x : T1 * T2) := (x.2, x.1). - -Lemma measurable_fun_swap d d' (X : measurableType d) (Y : measurableType d') : - measurable_fun [set: X * Y] (@swap X Y). -Proof. -by apply/prod_measurable_funP => /=; split; - [exact: measurable_fun_snd|exact: measurable_fun_fst]. -Qed. - -Section measurable_fun_pair. -Context d d2 d3 (X : measurableType d) (Y : measurableType d2) - (Z : measurableType d3). - -Lemma measurable_fun_pair (f : X -> Y) (g : X -> Z) : - measurable_fun setT f -> measurable_fun setT g -> - measurable_fun setT (fun x => (f x, g x)). -Proof. by move=> mf mg; apply/prod_measurable_funP. Qed. - -End measurable_fun_pair. - -Section measurable_fun_comp. -Context d1 d2 d3 (T1 : measurableType d1) - (T2 : measurableType d2) (T3 : measurableType d3). - -(* NB: this generalizes MathComp-Analysis' measurable_fun_comp *) -Lemma measurable_fun_comp' F (f : T2 -> T3) E (g : T1 -> T2) : - measurable F -> - g @` E `<=` F -> - measurable_fun F f -> measurable_fun E g -> measurable_fun E (f \o g). -Proof. -move=> mF FgE mf mg /= mE A mA. -rewrite comp_preimage. -rewrite [X in measurable X](_ : _ = E `&` g @^-1` (F `&` f @^-1` A)); last first. - apply/seteqP; split=> [|? [?] []//]. - by move=> x/= [Ex Afgx]; split => //; split => //; exact: FgE. -by apply/mg => //; exact: mf. -Qed. - -End measurable_fun_comp. - -Lemma measurable_fun_if_pair d d' (X : measurableType d) - (Y : measurableType d') (x y : X -> Y) : - measurable_fun setT x -> measurable_fun setT y -> - measurable_fun setT (fun tb => if tb.2 then x tb.1 else y tb.1). -Proof. -move=> mx my. -have {}mx : measurable_fun [set: X * bool] (x \o fst). - by apply: measurable_fun_comp => //; exact: measurable_fun_fst. -have {}my : measurable_fun [set: X * bool] (y \o fst). - by apply: measurable_fun_comp => //; exact: measurable_fun_fst. -by apply: measurable_fun_ifT => //=; exact: measurable_fun_snd. -Qed. - -Lemma measurable_fun_opp (R : realType) : measurable_fun [set: R] -%R. -Proof. -apply: continuous_measurable_fun. -by have := @opp_continuous R [the normedModType R of R^o]. -Qed. - -Lemma integral_eq0 d (T : measurableType d) (R : realType) - (mu : {measure set T -> \bar R}) (D : set T) f : - (forall x, D x -> f x = 0) -> \int[mu]_(x in D) f x = 0. -Proof. -move=> f0; under eq_integral. - by move=> x /[1!inE] /f0 ->; over. -by rewrite integral0. -Qed. - -Lemma dirac0 d (T : measurableType d) (R : realFieldType) (a : T) : - \d_a set0 = 0%E :> \bar R. -Proof. by rewrite /dirac indic0. Qed. - -Lemma diracT d (T : measurableType d) (R : realFieldType) (a : T) : - \d_a setT = 1%E :> \bar R. -Proof. by rewrite /dirac indicT. Qed. - -Section fubini_tonelli. -Local Open Scope ereal_scope. -Context d1 d2 (T1 : measurableType d1) (T2 : measurableType d2) (R : realType). -Variables (m1 : {measure set T1 -> \bar R}) (m2 : {measure set T2 -> \bar R}). -Hypotheses (sm1 : sigma_finite setT m1) (sm2 : sigma_finite setT m2). -Variables (f : T1 * T2 -> \bar R) (f0 : forall xy, 0 <= f xy). -Variables (mf : measurable_fun setT f). - -Lemma fubini_tonelli : - \int[m1]_x \int[m2]_y f (x, y) = \int[m2]_y \int[m1]_x f (x, y). -Proof. by rewrite -fubini_tonelli1// fubini_tonelli2. Qed. - -End fubini_tonelli. -(* /TODO: PR *) - Definition sfinite_measure d (T : measurableType d) (R : realType) (mu : set T -> \bar R) := exists2 s : {measure set T -> \bar R}^nat, @@ -684,10 +517,10 @@ Lemma measurable_fun_xsection_integral Proof. move=> h. rewrite (_ : (fun x => _) = - (fun x => elim_sup (fun n => \int[l x]_y (k_ n (x, y))%:E))); last first. + (fun x => lim_esup (fun n => \int[l x]_y (k_ n (x, y))%:E))); last first. apply/funext => x. transitivity (lim (fun n => \int[l x]_y (k_ n (x, y))%:E)); last first. - rewrite is_cvg_elim_supE//. + rewrite is_cvg_lim_esupE//. apply: ereal_nondecreasing_is_cvg => m n mn. apply: ge0_le_integral => //. - by move=> y _; rewrite lee_fin. @@ -711,7 +544,7 @@ rewrite [X in measurable_fun _ X](_ : _ = (fun x => \sum_(r \in range (k_ n)) - by apply: eq_integral => y _; rewrite -fsumEFin. - move=> r. apply/EFin_measurable_fun/measurable_funrM/measurable_fun_prod1 => /=. - rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r))//. + rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) (measurable_set1 r)))//. exact/measurable_funP. - by move=> m y _; rewrite nnfun_muleindic_ge0. apply: emeasurable_fun_fsum => // r. @@ -721,11 +554,11 @@ rewrite [X in measurable_fun _ X](_ : _ = (fun x => r%:E * have [r0|r0] := leP 0%R r. rewrite ge0_integralM//; last by move=> y _; rewrite lee_fin. apply/EFin_measurable_fun/measurable_fun_prod1 => /=. - rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) r))//. + rewrite (_ : \1_ _ = mindic R (measurable_sfunP (k_ n) (measurable_set1 r)))//. exact/measurable_funP. - rewrite integral_eq0; last first. + rewrite integral0_eq; last first. by move=> y _; rewrite preimage_nnfun0// indic0 mule0. - by rewrite integral_eq0 ?mule0// => y _; rewrite preimage_nnfun0// indic0. + by rewrite integral0_eq ?mule0// => y _; rewrite preimage_nnfun0// indic0. apply/measurable_funeM. rewrite (_ : (fun x => _) = (fun x => l x (xsection (k_ n @^-1` [set r]) x))). exact/h. @@ -788,7 +621,7 @@ Let measurable_fun_kdirac U : measurable U -> measurable_fun setT (kdirac mf ^~ U). Proof. move=> mU; apply/EFin_measurable_fun. -by rewrite (_ : (fun x => _) = mindic R mU \o f)//; exact/measurable_fun_comp. +by rewrite (_ : (fun x => _) = mindic R mU \o f)//; exact/measurable_funT_comp. Qed. HB.instance Definition _ := isKernel.Build _ _ _ _ _ (kdirac mf) @@ -832,7 +665,8 @@ Qed. Definition pset : set (set (probability T R)) := [set mset U r | r in `[0%R,1%R] & U in measurable]. -Definition pprobability : measurableType pset.-sigma := [the measurableType _ of salgebraType pset]. +Definition pprobability : measurableType pset.-sigma := + [the measurableType _ of salgebraType pset]. End dist_salgebra_instance. @@ -904,12 +738,8 @@ exists (fun n => [the _.-ker _ ~> _ of kadd (f1 n) (f2 n)]). exists (r1 + r2)%R => x/=. by rewrite /msum !big_ord_recr/= big_ord0 add0e EFinD lte_add. move=> x U mU. -rewrite /kadd/=. -rewrite -/(measure_add (k1 x) (k2 x)) measure_addE. -rewrite /mseries. -rewrite hk1//= hk2//= /mseries. -rewrite -nneseriesD//. -apply: eq_eseries => n _. +rewrite /kadd/= -/(measure_add (k1 x) (k2 x)) measure_addE hk1//= hk2//=. +rewrite /mseries -nneseriesD//; apply: eq_eseries => n _ /=. by rewrite -/(measure_add (f1 n x) (f2 n x)) measure_addE. Qed. @@ -963,7 +793,7 @@ Lemma measurable_fun_eq_cst d d' (T : measurableType d) measurable_fun setT (fun t => f t setT == k). Proof. move=> _ /= B mB; rewrite setTI. -have [/eqP->|/eqP->|/eqP->|/eqP->] := set_boolE B. +have [/eqP->|/eqP->|/eqP->|/eqP->] := set_bool B. - exact: measurable_eq_cst. - rewrite (_ : _ @^-1` _ = [set b | f b setT != k]); last first. by apply/seteqP; split => [t /negbT//|t /negbTE]. @@ -996,7 +826,7 @@ case: ifPn => [_|_]; first exact: measure_semi_sigma_additive. rewrite (_ : (fun _ => _) = ((fun n => \sum_(0 <= i < n) f x (F i)) \* cst ((fine (f x setT))^-1)%:E)); last first. by apply/funext => n; rewrite -ge0_sume_distrl. -by apply: ereal_cvgMr => //; exact: measure_semi_sigma_additive. +by apply: cvgeMr => //; exact: measure_semi_sigma_additive. Qed. HB.instance Definition _ x := isMeasure.Build _ _ _ (mnormalize x) @@ -1045,14 +875,14 @@ apply: measurable_fun_if => //. - apply: emeasurable_funM. by have := measurable_kernel f U mU; exact: measurable_funS. apply/EFin_measurable_fun. - apply: (@measurable_fun_comp' _ _ _ _ _ _ [set r : R | r != 0%R]) => //. + apply: (@measurable_fun_comp _ _ _ _ _ _ [set r : R | r != 0%R]) => //. + exact: open_measurable. + move=> /= r [t] [] [_ ft0] ftoo ftr; apply/eqP => r0. move: (ftr); rewrite r0 => /eqP; rewrite fine_eq0 ?ft0//. by rewrite ge0_fin_numE// lt_neqAle leey ftoo. + apply: open_continuous_measurable_fun => //; apply/in_setP => x /= x0. exact: inv_continuous. - + apply: measurable_fun_comp => /=; first exact: measurable_fun_fine. + + apply: measurable_funT_comp => /=; first exact: measurable_fun_fine. by have := measurable_kernel f _ measurableT; exact: measurable_funS. Qed. @@ -1173,8 +1003,8 @@ Variable k : R.-sfker [the measurableType _ of (X * Y)%type] ~> Z. Import KCOMP_FINITE_KERNEL. -Lemma mkcomp_sfinite : exists k_ : (R.-fker X ~> Z)^nat, forall x U, measurable U -> - (l \; k) x U = kseries k_ x U. +Lemma mkcomp_sfinite : exists k_ : (R.-fker X ~> Z)^nat, + forall x U, measurable U -> (l \; k) x U = kseries k_ x U. Proof. have [k_ hk_] := sfinite k; have [l_ hl_] := sfinite l. have [kl hkl] : exists kl : (R.-fker X ~> Z) ^nat, forall x U, @@ -1241,7 +1071,7 @@ Let k_2_ge0 n x : (0 <= k_2 n x)%R. Proof. by []. Qed. HB.instance Definition _ n := @IsNonNegFun.Build _ _ _ (k_2_ge0 n). Let mk_2 n : measurable_fun setT (k_2 n). -Proof. by apply: measurable_fun_comp => //; exact: measurable_fun_snd. Qed. +Proof. by apply: measurable_funT_comp => //; exact: measurable_fun_snd. Qed. HB.instance Definition _ n := @IsMeasurableFun.Build _ _ _ _ (mk_2 n). @@ -1322,7 +1152,7 @@ under [in RHS]eq_integral. over. rewrite /= ge0_integral_fsum//; last 2 first. - move=> r; apply: measurable_funeM. - have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). + have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f (measurable_set1 r)). by move=> /measurable_fun_prod1; exact. - move=> n y _. have := mulemu_ge0 (fun n => f @^-1` [set n]). @@ -1333,12 +1163,12 @@ rewrite (integralM_indic _ (fun r => f @^-1` [set r]))//; last first. rewrite /= integral_kcomp_indic; last exact/measurable_sfunP. have [r0|r0] := leP 0%R r. rewrite ge0_integralM//; last first. - have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f r). + have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f (measurable_set1 r)). by move/measurable_fun_prod1; exact. by congr (_ * _); apply eq_integral => y _; rewrite integral_indic// setIT. -rewrite integral_eq0 ?mule0; last first. - by move=> y _; rewrite integral_eq0// => z _; rewrite preimage_nnfun0// indic0. -by rewrite integral_eq0// => y _; rewrite preimage_nnfun0// measure0 mule0. +rewrite integral0_eq ?mule0; last first. + by move=> y _; rewrite integral0_eq// => z _; rewrite preimage_nnfun0// indic0. +by rewrite integral0_eq// => y _; rewrite preimage_nnfun0// measure0 mule0. Qed. Lemma integral_kcomp x f : (forall z, 0 <= f z) -> measurable_fun setT f -> diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 9ba16e6afc..87dcf0b036 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -408,7 +408,7 @@ Section insn2. Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Definition ret (f : X -> Y) (mf : measurable_fun setT f) - : R.-sfker X ~> Y := [the R.-sfker _ ~> _ of kdirac mf]. + : R.-pker X ~> Y := [the R.-pker _ ~> _ of kdirac mf]. Definition sample (P : pprobability Y R) : R.-pker X ~> Y := [the R.-pker _ ~> _ of kprobability (measurable_fun_cst P)]. @@ -632,6 +632,35 @@ 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). +have /measurable_fun_prod1 := @measurable_kernel _ _ _ _ _ v _ mA. +exact. +Qed. + +End letinA. + Section letinC. Context d d1 d' (X : measurableType d) (Y : measurableType d1) (Z : measurableType d') (R : realType). @@ -677,12 +706,18 @@ Section constants. Variable R : realType. Local Open Scope ring_scope. -Lemma onem12 : `1- (1 / 2%:R) = (1%:R / 2%:R)%:nng%:num :> R. -Proof. by rewrite /onem/= {1}(splitr 1) addrK. Qed. +Lemma onem1S n : `1- (1 / n.+1%:R) = (n%:R / n.+1%:R)%:nng%:num :> R. +Proof. +by rewrite /onem/= -{1}(@divrr _ n.+1%:R) ?unitfE// -mulrBl -natr1 addrK. +Qed. -Lemma p12 : (1 / 2%:R)%:nng%:num <= 1 :> R. +Lemma p1S n : (1 / n.+1%:R)%:nng%:num <= 1 :> R. Proof. by rewrite ler_pdivr_mulr//= mul1r ler1n. Qed. +Lemma p12 : (1 / 2%:R)%:nng%:num <= 1 :> R. Proof. by rewrite p1S. Qed. + +Lemma p14 : (1 / 4%:R)%:nng%:num <= 1 :> R. Proof. by rewrite p1S. 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. @@ -691,6 +726,7 @@ Proof. by rewrite /= lter_pdivr_mulr// mul1r ler_nat. Qed. End constants. Arguments p12 {R}. +Arguments p14 {R}. Arguments p27 {R}. Section poisson. @@ -833,7 +869,8 @@ Definition bernoulli_and : R.-sfker T ~> mbool := (ret (measurable_fun_mand var2of3 var3of3)))). Lemma bernoulli_andE t U : - bernoulli_and t U = (1 / 4 * \1_U true)%:E + (3 / 4 * \1_U false)%:E. + bernoulli_and t U = + sample [the probability _ _ of bernoulli p14] t U. Proof. rewrite /bernoulli_and. rewrite !letin_sample_bernoulli//=. @@ -844,12 +881,14 @@ rewrite !muleA. rewrite -addeA. rewrite -muleDl//. rewrite -!EFinM. -rewrite !onem12/= -splitr mulr1. +rewrite !onem1S/= -splitr mulr1. have -> : (1 / 2 * (1 / 2) = 1 / 4 :> R)%R. by rewrite mulf_div mulr1// -natrM. -congr (_ + (_ * _)%:E). +rewrite /bernoulli/= measure_addE/= /mscale/= -!EFinM. +congr( _ + (_ * _)%:E). have -> : (1 / 2 = 2 / 4 :> R)%R. by apply/eqP; rewrite eqr_div// ?pnatr_eq0// mul1r -natrM. +rewrite onem1S//. by rewrite -mulrDl. Qed. @@ -968,4 +1007,3 @@ by rewrite addr_gt0// mulr_gt0//= ?divr_gt0// ?ltr0n// exp_density_gt0 ?ltr0n. Qed. End staton_bus_exponential. - From 4d7145e6917c98aac986d6090c892250e5c4b99a Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Tue, 17 Jan 2023 20:45:31 +0900 Subject: [PATCH 31/54] minor cleaning --- theories/lebesgue_integral.v | 2 +- theories/prob_lang.v | 53 ++++++++++++------------------------ 2 files changed, 19 insertions(+), 36 deletions(-) diff --git a/theories/lebesgue_integral.v b/theories/lebesgue_integral.v index 959a041e32..c4c7567de3 100644 --- a/theories/lebesgue_integral.v +++ b/theories/lebesgue_integral.v @@ -4093,7 +4093,7 @@ Section xsection. Variables (pt2 : T2) (m2 : T1 -> {measure set T2 -> \bar R}). (* the generalization from m2 : {measure set T2 -> \bar R}t to T1 -> {measure set T2 -> \bar R} is needed to develop the theory - of kernels; the original type was sufficient for the the development + of kernels; the original type was sufficient for the development of the theory of integration *) Let phi A x := m2 x (xsection A x). Let B := [set A | measurable A /\ measurable_fun setT (phi A)]. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 87dcf0b036..223ec44d2e 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -90,7 +90,7 @@ Lemma mscoreE t U : mscore t U = if U == set0 then 0 else `| (f t)%:E |. Proof. rewrite /mscore/= /mscale/=; have [->|->] := set_unit U. by rewrite eqxx dirac0 mule0. -by rewrite diracT mule1 (negbTE (setT0 _)). +by rewrite diracT mule1 (negbTE setT0). Qed. Lemma measurable_fun_mscore U : measurable_fun setT f -> @@ -98,7 +98,7 @@ Lemma measurable_fun_mscore U : measurable_fun setT f -> Proof. move=> mr; under eq_fun do rewrite mscoreE/=. have [U0|U0] := eqVneq U set0; first exact: measurable_fun_cst. -by apply: measurable_fun_comp => //; exact: measurable_fun_comp. +by apply: measurable_funT_comp => //; exact: measurable_funT_comp. Qed. End mscore. @@ -162,7 +162,7 @@ Lemma measurable_fun_k i U : measurable U -> measurable_fun setT (k mf i ^~ U). Proof. move=> /= mU; rewrite /k /= (_ : (fun x => _) = (fun x => if i%:R%:E <= x < i.+1%:R%:E then x else 0) \o (mscore f ^~ U)) //. -apply: measurable_fun_comp => /=; last exact/measurable_fun_mscore. +apply: measurable_funT_comp => /=; last exact/measurable_fun_mscore. rewrite (_ : (fun x => _) = (fun x => x * (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set _) x)%:E)); last first. apply/funext => x; case: ifPn => ix; first by rewrite indicE/= mem_set ?mule1. @@ -532,9 +532,9 @@ Module Notations. Notation var1of2 := (@measurable_fun_fst _ _ _ _). Notation var2of2 := (@measurable_fun_snd _ _ _ _). -Notation var1of3 := (measurable_fun_comp (@measurable_fun_fst _ _ _ _) +Notation var1of3 := (measurable_funT_comp (@measurable_fun_fst _ _ _ _) (@measurable_fun_fst _ _ _ _)). -Notation var2of3 := (measurable_fun_comp (@measurable_fun_snd _ _ _ _) +Notation var2of3 := (measurable_funT_comp (@measurable_fun_snd _ _ _ _) (@measurable_fun_fst _ _ _ _)). Notation var3of3 := (@measurable_fun_snd _ _ _ _). @@ -574,7 +574,7 @@ 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 (measurable_fun_comp mf var2of2) + score (measurable_funT_comp mf var2of2) (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. @@ -753,7 +753,7 @@ Proof. apply: measurable_funM => /=. apply: measurable_funM => //=; last exact: measurable_fun_cst. exact/measurable_fun_exprn/measurable_fun_id. -apply: measurable_fun_comp; last exact: measurable_fun_opp. +apply: measurable_funT_comp; last exact: measurable_fun_opp. by apply: continuous_measurable_fun; exact: continuous_expR. Qed. @@ -778,7 +778,7 @@ Proof. by move=> r0; rewrite /exp_density mulr_ge0// expR_ge0. Qed. Lemma mexp_density x : measurable_fun setT (exp_density x). Proof. apply: measurable_funM => /=; first exact: measurable_fun_id. -apply: measurable_fun_comp. +apply: measurable_funT_comp. by apply: continuous_measurable_fun; exact: continuous_expR. apply: measurable_funM => /=; first exact: measurable_fun_opp. exact: measurable_fun_cst. @@ -790,7 +790,7 @@ 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 [the probability _ _ of bernoulli r1]) u x y = - r%:num%:E * u (x, true) y + (`1- (r%:num : R))%:E * u (x, false) y. + r%:num%:E * u (x, true) y + (`1- (r%:num))%:E * u (x, false) y. Proof. rewrite letinE/=. rewrite ge0_integral_measure_sum// 2!big_ord_recl/= big_ord0 adde0/=. @@ -809,10 +809,7 @@ Definition sample_and_return : R.-sfker T ~> _ := 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. -rewrite /sample_and_return. -rewrite letin_sample_bernoulli. -rewrite !retE. -by rewrite onem27. +by rewrite /sample_and_return letin_sample_bernoulli !retE onem27. Qed. End sample_and_return. @@ -826,8 +823,7 @@ Context d (T : measurableType d) (R : realType). let r = case x of {(1, _) => return (k3()), (2, _) => return (k10())} in return r *) -Definition sample_and_branch : - R.-sfker T ~> mR R := +Definition sample_and_branch : R.-sfker T ~> mR R := letin (sample [the probability _ _ of bernoulli p27]) (* T -> B *) (ite var2of2 (ret k3) (ret k10)). @@ -836,9 +832,7 @@ 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. Proof. -rewrite /sample_and_branch letin_sample_bernoulli/=. -rewrite !iteE !retE. -by rewrite onem27. +by rewrite /sample_and_branch letin_sample_bernoulli/= !iteE !retE onem27. Qed. End sample_and_branch. @@ -872,24 +866,13 @@ Lemma bernoulli_andE t U : bernoulli_and t U = sample [the probability _ _ of bernoulli p14] t U. Proof. -rewrite /bernoulli_and. -rewrite !letin_sample_bernoulli//=. -rewrite /mand/=. -rewrite muleDr//=. -rewrite -muleDl//. -rewrite !muleA. -rewrite -addeA. -rewrite -muleDl//. -rewrite -!EFinM. -rewrite !onem1S/= -splitr mulr1. -have -> : (1 / 2 * (1 / 2) = 1 / 4 :> R)%R. - by rewrite mulf_div mulr1// -natrM. -rewrite /bernoulli/= measure_addE/= /mscale/= -!EFinM. -congr( _ + (_ * _)%:E). +rewrite /bernoulli_and 3!letin_sample_bernoulli/= /mand/= muleDr//= -muleDl//. +rewrite !muleA -addeA -muleDl// -!EFinM !onem1S/= -splitr mulr1. +have -> : (1 / 2 * (1 / 2) = 1 / 4 :> R)%R by rewrite mulf_div mulr1// -natrM. +rewrite /bernoulli/= measure_addE/= /mscale/= -!EFinM; congr( _ + (_ * _)%:E). have -> : (1 / 2 = 2 / 4 :> R)%R. by apply/eqP; rewrite eqr_div// ?pnatr_eq0// mul1r -natrM. -rewrite onem1S//. -by rewrite -mulrDl. +by rewrite onem1S// -mulrDl. Qed. End bernoulli_and. @@ -902,7 +885,7 @@ Definition kstaton_bus : R.-sfker T ~> mbool := letin (sample [the probability _ _ of bernoulli p27]) (letin (letin (ite var2of2 (ret k3) (ret k10)) - (score (measurable_fun_comp mh var3of3))) + (score (measurable_funT_comp mh var3of3))) (ret var2of3)). Definition staton_bus := normalize kstaton_bus. From 9b21152f2e14a24986f2777d25219182e1d1ae33 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Mon, 6 Feb 2023 20:41:50 +0900 Subject: [PATCH 32/54] rebase wrt branch on finite measures --- theories/kernel.v | 74 +++++++++++++++++--------------------------- theories/prob_lang.v | 39 ++++++++++++++++++----- theories/wip.v | 8 ++--- 3 files changed, 64 insertions(+), 57 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index f0295acffe..2e975685e6 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -53,37 +53,23 @@ apply: measurableU. exact: emeasurable_itv_bnd_pinfty. Qed. -Definition sfinite_measure d (T : measurableType d) (R : realType) - (mu : set T -> \bar R) := - exists2 s : {measure set T -> \bar R}^nat, - forall n, finite_measure (s n) & forall U, measurable U -> mu U = mseries s 0 U. - -Lemma finite_measure_sigma_finite d (T : measurableType d) (R : realType) - (mu : {measure set T -> \bar R}) : - finite_measure mu -> sigma_finite setT mu. -Proof. -exists (fun i => if i \in [set 0%N] then setT else set0). - by rewrite -bigcup_mkcondr setTI bigcup_const//; exists 0%N. -move=> n; split; first by case: ifPn. -by case: ifPn => // _; rewrite ?measure0//; exact: finite_measure. -Qed. - Section sfinite_fubini. Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). -Variables (m1 : {measure set X -> \bar R}) (sfm1 : sfinite_measure m1). -Variables (m2 : {measure set Y -> \bar R}) (sfm2 : sfinite_measure m2). +Variables (m1 : {sfinite_measure set X -> \bar R}). +Variables (m2 : {sfinite_measure set Y -> \bar R}). Variables (f : X * Y -> \bar R) (f0 : forall xy, 0 <= f xy). Hypothesis mf : measurable_fun setT f. Lemma sfinite_fubini : \int[m1]_x \int[m2]_y f (x, y) = \int[m2]_y \int[m1]_x f (x, y). Proof. -have [s1 fm1 m1E] := sfm1. -have [s2 fm2 m2E] := sfm2. +have [s1 m1E] := sfinite_measure m1. +have [s2 m2E] := sfinite_measure m2. rewrite [LHS](eq_measure_integral [the measure _ _ of mseries s1 0]); last first. - by move=> A mA _; rewrite m1E. + by move=> A mA _; rewrite /= -m1E. transitivity (\int[mseries s1 0]_x \int[mseries s2 0]_y f (x, y)). - by apply eq_integral => x _; apply: eq_measure_integral => ? ? _; rewrite m2E. + apply eq_integral => x _; apply: eq_measure_integral => ? ? _. + by rewrite /= -m2E. transitivity (\sum_(n t _; exact: integral_ge0. @@ -92,14 +78,12 @@ transitivity (\sum_(n x. by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. apply: ge0_emeasurable_fun_sum; first by move=> k x; exact: integral_ge0. - move=> k; apply: measurable_fun_fubini_tonelli_F => //=. - exact: finite_measure_sigma_finite. + by move=> k; apply: measurable_fun_fubini_tonelli_F. apply: eq_eseries => n _; apply eq_integral => x _. by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. transitivity (\sum_(n n _; rewrite integral_nneseries//. - move=> m; apply: measurable_fun_fubini_tonelli_F => //=. - exact: finite_measure_sigma_finite. + by move=> m; exact: measurable_fun_fubini_tonelli_F. by move=> m x _; exact: integral_ge0. transitivity (\sum_(n n _; apply eq_eseries => m _. @@ -107,12 +91,10 @@ transitivity (\sum_(n n _ /=. rewrite ge0_integral_measure_series//. by move=> y _; exact: integral_ge0. - apply: measurable_fun_fubini_tonelli_G => //=. - by apply: finite_measure_sigma_finite; exact: fm1. + exact: measurable_fun_fubini_tonelli_G. transitivity (\int[mseries s2 0]_y \sum_(n n; apply: measurable_fun_fubini_tonelli_G => //=. - by apply: finite_measure_sigma_finite; exact: fm1. + by move=> n; apply: measurable_fun_fubini_tonelli_G. by move=> n y _; exact: integral_ge0. transitivity (\int[mseries s2 0]_y \int[mseries s1 0]_x f (x, y)). apply eq_integral => y _. @@ -123,7 +105,7 @@ by apply eq_integral => y _; apply eq_measure_integral => A mA _ /=; rewrite m1E Qed. End sfinite_fubini. -Arguments sfinite_fubini {d d' X Y R m1} _ {m2} _ f. +Arguments sfinite_fubini {d d' X Y R} m1 m2 f. Reserved Notation "R .-ker X ~> Y" (at level 42, format "R .-ker X ~> Y"). Reserved Notation "R .-sfker X ~> Y" (at level 42, format "R .-sfker X ~> Y"). @@ -143,8 +125,8 @@ Notation "R .-ker X ~> Y" := (kernel X Y R). Arguments measurable_kernel {_ _ _ _ _} _. -Lemma eq_kernel d d' (T : measurableType d) (T' : measurableType d') (R : realType) - (k1 k2 : R.-ker T ~> T') : +Lemma eq_kernel d d' (T : measurableType d) (T' : measurableType d') + (R : realType) (k1 k2 : R.-ker T ~> T') : (forall x U, k1 x U = k2 x U) -> k1 = k2. Proof. move: k1 k2 => [m1 [[?]]] [m2 [[?]]] /= k12. @@ -314,6 +296,17 @@ Qed. End sfinite. +Lemma sfinite_kernel_measure d d' (Z : measurableType d) (X : measurableType d') + (R : realType) (k : R.-sfker Z ~> X) (z : Z) : + sfinite_measure_def (k z). +Proof. +have [s ks] := sfinite k. +exists (s ^~ z). + move=> n; have [r snr] := measure_uub (s n). + by rewrite /finite_measure (lt_le_trans (snr _))// leey. +by move=> U mU; rewrite ks. +Qed. + HB.instance Definition _ d d' (X : measurableType d) (Y : measurableType d') (R : realType) := @Kernel_isFinite.Build _ _ _ _ R (@kzero _ _ X Y R) @@ -411,16 +404,6 @@ have [r k_r] := measure_uub k. by rewrite /finite_measure (@lt_trans _ _ r%:E) ?ltey. Qed. -Lemma sfinite_kernel_measure d d' (X : measurableType d) - (Y : measurableType d') (R : realType) (k : R.-sfker X ~> Y) (x : X) : - sfinite_measure (k x). -Proof. -have [k_ k_E] := sfinite k. -exists (fun n => k_ n x); last by move=> A mA; rewrite k_E. -move=> n; rewrite /finite_measure. -exact: finite_kernel_measure. -Qed. - (* see measurable_prod_subset in lebesgue_integral.v; the differences between the two are: - m2 is a kernel instead of a measure (the proof uses the @@ -1068,12 +1051,12 @@ Let k_2 : (X * Y -> R)^nat := fun n => k_ n \o snd. Let k_2_ge0 n x : (0 <= k_2 n x)%R. Proof. by []. Qed. -HB.instance Definition _ n := @IsNonNegFun.Build _ _ _ (k_2_ge0 n). +HB.instance Definition _ n := @isNonNegFun.Build _ _ _ (k_2_ge0 n). Let mk_2 n : measurable_fun setT (k_2 n). Proof. by apply: measurable_funT_comp => //; exact: measurable_fun_snd. Qed. -HB.instance Definition _ n := @IsMeasurableFun.Build _ _ _ _ (mk_2 n). +HB.instance Definition _ n := @isMeasurableFun.Build _ _ _ _ (mk_2 n). Let fk_2 n : finite_set (range (k_2 n)). Proof. @@ -1096,7 +1079,8 @@ move=> h; apply: (measurable_fun_xsection_integral (k \o snd) l have := h n r measurableT B mB; rewrite !setTI. suff : (l ^~ (k_ n @^-1` [set r])) @^-1` B = (fun x => l x (xsection (k_2 n @^-1` [set r]) x)) @^-1` B by move=> ->. - by apply/seteqP; split => x/=; rewrite xsection_preimage_snd. + by apply/seteqP; split => x/=; + rewrite (comp_preimage _ snd (k_ n)) xsection_preimage_snd. Qed. End measurable_fun_preimage_integral. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 223ec44d2e..809e9ca7ed 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -50,9 +50,6 @@ 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). - -Lemma expR_ge0 (R : realType) (x : R) : (0 <= expR x)%R. -Proof. by rewrite ltW// expR_gt0. Qed. (* /TODO: PR *) Section bernoulli. @@ -674,6 +671,30 @@ Variables (t : R.-sfker Z ~> X) (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 _ R X (T z) (T0 z) (T_ge0 z) + (@T_semi_sigma_additive z). + +Let sfinT z : sfinite_measure_def (T z). Proof. exact: sfinite_kernel_measure. Qed. +HB.instance Definition _ z := @Measure_isSFinite_subdef.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 _ R Y (U z) (U0 z) (U_ge0 z) + (@U_semi_sigma_additive z). + +Let sfinU z : sfinite_measure_def (U z). Proof. exact: sfinite_kernel_measure. Qed. +HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ Y R + (U z) (sfinU z). + Lemma letinC z A : measurable A -> letin t (letin u' @@ -689,13 +710,15 @@ under eq_integral. rewrite letinE -uu'. under eq_integral do rewrite retE /=. over. -rewrite (sfinite_fubini _ _ (fun x => \d_(x.1, x.2) A ))//; last 3 first. - exact: sfinite_kernel_measure. - exact: sfinite_kernel_measure. +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 => -[]. -apply eq_integral => y _. -by rewrite letinE/= -tt'; apply eq_integral => // x _; rewrite retE. +rewrite /=. +apply: eq_integral => y _. +by rewrite letinE/= -tt'; apply: eq_integral => // x _; rewrite retE. Qed. End letinC. diff --git a/theories/wip.v b/theories/wip.v index 41b6a28988..c9ae698bd2 100644 --- a/theories/wip.v +++ b/theories/wip.v @@ -51,10 +51,10 @@ Lemma measurable_fun_gauss_density m s : measurable_fun setT (gauss_density m s). Proof. apply: measurable_funM; first exact: measurable_fun_cst. -apply: measurable_fun_comp => /=. +apply: measurable_funT_comp => /=. by apply: continuous_measurable_fun; apply continuous_expR. apply: measurable_funM; last exact: measurable_fun_cst. -apply: measurable_fun_comp => /=; first exact: measurable_fun_opp. +apply: measurable_funT_comp => /=; first exact: measurable_fun_opp. apply: measurable_fun_exprn. apply: measurable_funM => /=; last exact: measurable_fun_cst. apply: measurable_funD => //; first exact: measurable_fun_id. @@ -111,7 +111,7 @@ Let f1 (x : R) := (gauss01_density x) ^-1. Let mf1 : measurable_fun setT f1. Proof. -apply: (measurable_fun_comp' (F := [set r : R | r != 0%R])) => //. +apply: (measurable_fun_comp (F := [set r : R | r != 0%R])) => //. - exact: open_measurable. - by move=> /= r [t _ <-]; rewrite gt_eqF// gauss_density_gt0. - apply: open_continuous_measurable_fun => //. @@ -124,7 +124,7 @@ Variable mu : {measure set mR R -> \bar R}. Definition staton_lebesgue : R.-sfker T ~> _ := letin (sample (@gauss01 R)) (letin - (score (measurable_fun_comp mf1 var2of2)) + (score (measurable_funT_comp mf1 var2of2)) (ret var2of3)). Lemma staton_lebesgueE x U : measurable U -> From 75af27d496a3e3ddcedf8efc8a5c2fed20760425 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Sun, 12 Feb 2023 23:47:26 +0900 Subject: [PATCH 33/54] adapt to hierarchy with subprob --- theories/kernel.v | 10 +--------- theories/prob_lang.v | 2 +- theories/wip.v | 2 +- 3 files changed, 3 insertions(+), 11 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 2e975685e6..46a3c00712 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -582,14 +582,6 @@ Arguments measurable_fun_xsection_integral {_ _ _ _ _} k l. Arguments measurable_fun_integral_finite_kernel {_ _ _ _ _} k l. Arguments measurable_fun_integral_sfinite_kernel {_ _ _ _ _} k l. -Section pdirac. -Context d (T : measurableType d) (R : realType). - -HB.instance Definition _ x := - isProbability.Build _ _ _ (@dirac _ T x R) (diracT R x). - -End pdirac. - Section kdirac. Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Variable f : X -> Y. @@ -825,7 +817,7 @@ by rewrite -{1}(@fineK _ (f x setT))// -EFinM divrr// ?unitfE fine_eq0. Qed. HB.instance Definition _ x := - isProbability.Build _ _ _ (mnormalize x) (mnormalize1 x). + Measure_isProbability.Build _ _ _ (mnormalize x) (mnormalize1 x). End mnormalize. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 809e9ca7ed..fb7103c2ff 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -71,7 +71,7 @@ rewrite /bernoulli/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. by rewrite /mscale/= !diracT !mule1 -EFinD onem1'. Qed. -HB.instance Definition _ := @isProbability.Build _ _ R bernoulli bernoulli_setT. +HB.instance Definition _ := @Measure_isProbability.Build _ _ R bernoulli bernoulli_setT. End bernoulli. diff --git a/theories/wip.v b/theories/wip.v index c9ae698bd2..897d70c886 100644 --- a/theories/wip.v +++ b/theories/wip.v @@ -97,7 +97,7 @@ HB.instance Definition _ := isMeasure.Build _ _ _ Let mgauss01_setT : mgauss01 [set: _] = 1%E. Proof. by rewrite /mgauss01 integral_gauss01_density. Qed. -HB.instance Definition _ := @isProbability.Build _ _ R mgauss01 mgauss01_setT. +HB.instance Definition _ := @Measure_isProbability.Build _ _ R mgauss01 mgauss01_setT. Definition gauss01 := [the probability _ _ of mgauss01]. From 042dbb37d8728c657512441afec7f3b8af14e6eb Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 22 Feb 2023 17:11:56 +0900 Subject: [PATCH 34/54] rebase --- theories/kernel.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 46a3c00712..4d3ac70ef9 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -303,7 +303,7 @@ Proof. have [s ks] := sfinite k. exists (s ^~ z). move=> n; have [r snr] := measure_uub (s n). - by rewrite /finite_measure (lt_le_trans (snr _))// leey. + by apply: lty_fin_num_fun; rewrite (lt_le_trans (snr _))// leey. by move=> U mU; rewrite ks. Qed. @@ -398,10 +398,10 @@ HB.end. Lemma finite_kernel_measure d d' (X : measurableType d) (Y : measurableType d') (R : realType) (k : R.-fker X ~> Y) (x : X) : - finite_measure (k x). + fin_num_fun (k x). Proof. have [r k_r] := measure_uub k. -by rewrite /finite_measure (@lt_trans _ _ r%:E) ?ltey. +by apply: lty_fin_num_fun; rewrite (@lt_trans _ _ r%:E) ?ltey. Qed. (* see measurable_prod_subset in lebesgue_integral.v; From d24568dde0c0976fd4ac441dbc31f886e86ae758 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Thu, 23 Feb 2023 15:29:55 +0900 Subject: [PATCH 35/54] rebase --- theories/kernel.v | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index 4d3ac70ef9..bd526e03c1 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -63,13 +63,13 @@ Hypothesis mf : measurable_fun setT f. Lemma sfinite_fubini : \int[m1]_x \int[m2]_y f (x, y) = \int[m2]_y \int[m1]_x f (x, y). Proof. -have [s1 m1E] := sfinite_measure m1. -have [s2 m2E] := sfinite_measure m2. +pose s1 := sfinite_measure_seq m1. +pose s2 := sfinite_measure_seq m2. rewrite [LHS](eq_measure_integral [the measure _ _ of mseries s1 0]); last first. - by move=> A mA _; rewrite /= -m1E. + by move=> A mA _; rewrite /=; exact: sfinite_measure_seqP. transitivity (\int[mseries s1 0]_x \int[mseries s2 0]_y f (x, y)). apply eq_integral => x _; apply: eq_measure_integral => ? ? _. - by rewrite /= -m2E. + exact: sfinite_measure_seqP. transitivity (\sum_(n t _; exact: integral_ge0. @@ -89,7 +89,7 @@ transitivity (\sum_(n n _; apply eq_eseries => m _. by rewrite fubini_tonelli//; exact: finite_measure_sigma_finite. transitivity (\sum_(n n _ /=. rewrite ge0_integral_measure_series//. + apply eq_eseries => n _; rewrite ge0_integral_measure_series//. by move=> y _; exact: integral_ge0. exact: measurable_fun_fubini_tonelli_G. transitivity (\int[mseries s2 0]_y \sum_(n y _. by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod2. transitivity (\int[m2]_y \int[mseries s1 0]_x f (x, y)). - by apply eq_measure_integral => A mA _ /=; rewrite m2E. -by apply eq_integral => y _; apply eq_measure_integral => A mA _ /=; rewrite m1E. + by apply eq_measure_integral => A mA _ /=; rewrite sfinite_measure_seqP. +apply eq_integral => y _; apply eq_measure_integral => A mA _ /=. +by rewrite sfinite_measure_seqP. Qed. End sfinite_fubini. From 544e270ead6ad69dcdde6af666dee55762ba9ea9 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Sat, 25 Feb 2023 19:04:11 +0900 Subject: [PATCH 36/54] upd --- theories/kernel.v | 50 ++++++++++++++++++++++---------------------- theories/prob_lang.v | 12 +++++------ 2 files changed, 31 insertions(+), 31 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index bd526e03c1..2161f1762c 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -41,16 +41,16 @@ Local Open Scope classical_set_scope. Local Open Scope ring_scope. Local Open Scope ereal_scope. -(* TODO: PR*) -Lemma emeasurable_itv1 (R : realType) (i : nat) : - measurable (`[(i%:R)%:E, (i.+1%:R)%:E[%classic : set \bar R). +(* PR in progress *) +Lemma emeasurable_itv (R : realType) (i : interval (\bar R)) : + measurable ([set` i]%classic : set \bar R). Proof. -rewrite -[X in measurable X]setCK. -apply: measurableC. -rewrite set_interval.setCitv /=. -apply: measurableU. +rewrite -[X in measurable X]setCK; apply: measurableC. +rewrite set_interval.setCitv /=; apply: measurableU => [|]. +- move: i => [[b1 i1|[|]] i2] /=; rewrite ?set_interval.set_itvE//. exact: emeasurable_itv_ninfty_bnd. -exact: emeasurable_itv_bnd_pinfty. +- move: i => [i1 [b2 i2|[|]]] /=; rewrite ?set_interval.set_itvE//. + exact: emeasurable_itv_bnd_pinfty. Qed. Section sfinite_fubini. @@ -68,7 +68,7 @@ pose s2 := sfinite_measure_seq m2. rewrite [LHS](eq_measure_integral [the measure _ _ of mseries s1 0]); last first. by move=> A mA _; rewrite /=; exact: sfinite_measure_seqP. transitivity (\int[mseries s1 0]_x \int[mseries s2 0]_y f (x, y)). - apply eq_integral => x _; apply: eq_measure_integral => ? ? _. + apply: eq_integral => x _; apply: eq_measure_integral => ? ? _. exact: sfinite_measure_seqP. transitivity (\sum_(n k x; exact: integral_ge0. by move=> k; apply: measurable_fun_fubini_tonelli_F. - apply: eq_eseries => n _; apply eq_integral => x _. + apply: eq_eseriesr => n _; apply: eq_integral => x _. by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod1. transitivity (\sum_(n n _; rewrite integral_nneseries//. + apply: eq_eseriesr => n _; rewrite integral_nneseries//. by move=> m; exact: measurable_fun_fubini_tonelli_F. by move=> m x _; exact: integral_ge0. transitivity (\sum_(n n _; apply eq_eseries => m _. + apply: eq_eseriesr => n _; apply: eq_eseriesr => m _. by rewrite fubini_tonelli//; exact: finite_measure_sigma_finite. transitivity (\sum_(n n _; rewrite ge0_integral_measure_series//. + apply: eq_eseriesr => n _; rewrite ge0_integral_measure_series//. by move=> y _; exact: integral_ge0. exact: measurable_fun_fubini_tonelli_G. transitivity (\int[mseries s2 0]_y \sum_(n n; apply: measurable_fun_fubini_tonelli_G. by move=> n y _; exact: integral_ge0. transitivity (\int[mseries s2 0]_y \int[mseries s1 0]_x f (x, y)). - apply eq_integral => y _. + apply: eq_integral => y _. by rewrite ge0_integral_measure_series//; exact/measurable_fun_prod2. transitivity (\int[m2]_y \int[mseries s1 0]_x f (x, y)). - by apply eq_measure_integral => A mA _ /=; rewrite sfinite_measure_seqP. -apply eq_integral => y _; apply eq_measure_integral => A mA _ /=. + by apply: eq_measure_integral => A mA _ /=; rewrite sfinite_measure_seqP. +apply: eq_integral => y _; apply: eq_measure_integral => A mA _ /=. by rewrite sfinite_measure_seqP. Qed. @@ -256,7 +256,7 @@ exists (fun n => if n is O then [the _.-ker _ ~> _ of k] else by case => [|_]; [exact: measure_uub|exact: kzero_uub]. move=> t U mU/=; rewrite /mseries. rewrite (nneseries_split 1%N)// big_ord_recl/= big_ord0 adde0. -rewrite ereal_series (@eq_eseries _ _ (fun=> 0%E)); last by case. +rewrite ereal_series (@eq_eseriesr _ _ (fun=> 0%E)); last by case. by rewrite eseries0// adde0. Qed. @@ -299,7 +299,7 @@ End sfinite. Lemma sfinite_kernel_measure d d' (Z : measurableType d) (X : measurableType d') (R : realType) (k : R.-sfker Z ~> X) (z : Z) : - sfinite_measure_def (k z). + sfinite_measure (k z). Proof. have [s ks] := sfinite k. exists (s ^~ z). @@ -715,7 +715,7 @@ exists (fun n => [the _.-ker _ ~> _ of kadd (f1 n) (f2 n)]). by rewrite /msum !big_ord_recr/= big_ord0 add0e EFinD lte_add. move=> x U mU. rewrite /kadd/= -/(measure_add (k1 x) (k2 x)) measure_addE hk1//= hk2//=. -rewrite /mseries -nneseriesD//; apply: eq_eseries => n _ /=. +rewrite /mseries -nneseriesD//; apply: eq_eseriesr => n _ /=. by rewrite -/(measure_add (f1 n x) (f2 n x)) measure_addE. Qed. @@ -997,7 +997,7 @@ transitivity (([the _.-ker _ ~> _ of kseries l_] \; [the _.-ker _ ~> _ of kserie rewrite /= /kcomp/= integral_nneseries//=; last first. by move=> n; have /measurable_fun_prod1 := measurable_kernel (k_ n) _ mU; exact. transitivity (\sum_(i i _; rewrite integral_kseries//. + apply: eq_eseriesr => i _; rewrite integral_kseries//. by have /measurable_fun_prod1 := measurable_kernel (k_ i) _ mU; exact. rewrite /mseries -hkl/=. rewrite (_ : setT = setT `*`` (fun=> setT)); last by apply/seteqP; split. @@ -1099,7 +1099,7 @@ Let integral_kcomp_indic x E (mE : measurable E) : \int[(l \; k) x]_z (\1_E z)%:E = \int[l x]_y (\int[k (x, y)]_z (\1_E z)%:E). Proof. rewrite integral_indic//= /kcomp. -by apply eq_integral => y _; rewrite integral_indic. +by apply: eq_integral => y _; rewrite integral_indic. Qed. Let integral_kcomp_nnsfun x (f : {nnsfun Z >-> R}) : @@ -1142,7 +1142,7 @@ have [r0|r0] := leP 0%R r. rewrite ge0_integralM//; last first. have := measurable_kernel k (f @^-1` [set r]) (measurable_sfunP f (measurable_set1 r)). by move/measurable_fun_prod1; exact. - by congr (_ * _); apply eq_integral => y _; rewrite integral_indic// setIT. + by congr (_ * _); apply: eq_integral => y _; rewrite integral_indic// setIT. rewrite integral0_eq ?mule0; last first. by move=> y _; rewrite integral0_eq// => z _; rewrite preimage_nnfun0// indic0. by rewrite integral0_eq// => y _; rewrite preimage_nnfun0// measure0 mule0. @@ -1169,18 +1169,18 @@ transitivity (\int[l x]_y lim (fun n => \int[k (x, y)]_z (f_ n z)%:E)). by move=> /measurable_fun_prod1; exact. + by move=> z; rewrite lee_fin. + exact/EFin_measurable_fun. - - by move=> n y _; apply integral_ge0 => // z _; rewrite lee_fin. + - by move=> n y _; apply: integral_ge0 => // z _; rewrite lee_fin. - move=> y _ a b ab; apply: ge0_le_integral => //. + by move=> z _; rewrite lee_fin. + exact/EFin_measurable_fun. + by move=> z _; rewrite lee_fin. + exact/EFin_measurable_fun. + by move: ab => /ndf_ /lefP ab z _; rewrite lee_fin. -apply eq_integral => y _; rewrite -monotone_convergence//; last 3 first. +apply: eq_integral => y _; rewrite -monotone_convergence//; last 3 first. - by move=> n; exact/EFin_measurable_fun. - by move=> n z _; rewrite lee_fin. - by move=> z _ a b /ndf_ /lefP; rewrite lee_fin. -by apply eq_integral => z _; apply/cvg_lim => //; exact: f_f. +by apply: eq_integral => z _; apply/cvg_lim => //; exact: f_f. Qed. End integral_kcomp. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index fb7103c2ff..d7dd3d30aa 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -164,9 +164,9 @@ rewrite (_ : (fun x => _) = (fun x => x * (\1_(`[i%:R%:E, i.+1%:R%:E [%classic : set _) x)%:E)); last first. apply/funext => x; case: ifPn => ix; first by rewrite indicE/= mem_set ?mule1. by rewrite indicE/= memNset ?mule0// /= in_itv/=; exact/negP. -apply emeasurable_funM => /=; first exact: measurable_fun_id. +apply: emeasurable_funM => /=; first exact: measurable_fun_id. apply/EFin_measurable_fun. -by rewrite (_ : \1__ = mindic R (emeasurable_itv1 R i)). +by rewrite (_ : \1__ = mindic R (emeasurable_itv `[(i%:R)%:E, (i.+1%:R)%:E[)). Qed. Definition mk i t := [the measure _ _ of k mf i t]. @@ -615,7 +615,7 @@ 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 _. +apply: eq_measure_integral => V mV _. by rewrite iteE ftT. Qed. @@ -623,7 +623,7 @@ 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 _. +apply: eq_measure_integral => V mV _. by rewrite iteE (negbTE ftF). Qed. @@ -679,7 +679,7 @@ Proof. exact: measure_semi_sigma_additive. Qed. HB.instance Definition _ z := @isMeasure.Build _ R X (T z) (T0 z) (T_ge0 z) (@T_semi_sigma_additive z). -Let sfinT z : sfinite_measure_def (T z). Proof. exact: sfinite_kernel_measure. Qed. +Let sfinT z : sfinite_measure (T z). Proof. exact: sfinite_kernel_measure. Qed. HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ X R (T z) (sfinT z). @@ -691,7 +691,7 @@ Proof. exact: measure_semi_sigma_additive. Qed. HB.instance Definition _ z := @isMeasure.Build _ R Y (U z) (U0 z) (U_ge0 z) (@U_semi_sigma_additive z). -Let sfinU z : sfinite_measure_def (U z). Proof. exact: sfinite_kernel_measure. Qed. +Let sfinU z : sfinite_measure (U z). Proof. exact: sfinite_kernel_measure. Qed. HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ Y R (U z) (sfinU z). From f4005e719e2516db9c916aaaf5e10f3b2c320088 Mon Sep 17 00:00:00 2001 From: AyumuSaito Date: Tue, 14 Feb 2023 22:02:38 +0900 Subject: [PATCH 37/54] generalize the interface of finite measures - eval - eval_uniq - eval_full and letinC12 --- CHANGELOG_UNRELEASED.md | 2 +- _CoqProject | 7 +- theories/kernel.v | 2 +- theories/lang_syntax.v | 1093 +++++++++++++++++++++++++++++++++++++++ theories/prob_lang.v | 311 +++++++++++ theories/sample.v | 59 +++ theories/semantics.v | 89 ++++ theories/wip.v | 2 +- 8 files changed, 1560 insertions(+), 5 deletions(-) create mode 100644 theories/lang_syntax.v create mode 100644 theories/sample.v create mode 100644 theories/semantics.v diff --git a/CHANGELOG_UNRELEASED.md b/CHANGELOG_UNRELEASED.md index 83b78d3cac..dc67809d18 100644 --- a/CHANGELOG_UNRELEASED.md +++ b/CHANGELOG_UNRELEASED.md @@ -20,4 +20,4 @@ ### Infrastructure -### Misc +### Misc \ No newline at end of file diff --git a/_CoqProject b/_CoqProject index 74008d6ef1..a8ebbde651 100644 --- a/_CoqProject +++ b/_CoqProject @@ -34,13 +34,16 @@ theories/lebesgue_measure.v theories/forms.v theories/derive.v theories/measure.v +theories/kernel.v +theories/prob_lang.v theories/numfun.v theories/lebesgue_integral.v theories/kernel.v -theories/prob_lang.v -theories/wip.v theories/summability.v theories/signed.v +theories/prob_lang.v +theories/wip.v +theories/lang_syntax.v theories/altreals/xfinmap.v theories/altreals/discrete.v theories/altreals/realseq.v diff --git a/theories/kernel.v b/theories/kernel.v index 2161f1762c..bea2d42001 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -1183,4 +1183,4 @@ apply: eq_integral => y _; rewrite -monotone_convergence//; last 3 first. by apply: eq_integral => z _; apply/cvg_lim => //; exact: f_f. Qed. -End integral_kcomp. +End integral_kcomp. \ No newline at end of file diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v new file mode 100644 index 0000000000..9b396aadf1 --- /dev/null +++ b/theories/lang_syntax.v @@ -0,0 +1,1093 @@ +From HB Require Import structures. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval finmap. +Require Import mathcomp_extra boolp classical_sets signed functions cardinality. +Require Import reals ereal topology normedtype sequences esum measure. +Require Import lebesgue_measure fsbigop numfun lebesgue_integral kernel. +Require Import prob_lang. + +Set Implicit Arguments. +Implicit Types V : Set. +Unset Strict Implicit. +Set 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. + +Require Import String ZArith. +Local Open Scope string. + +Import Notations. + +Section type_syntax. +Variables (R : realType). + + +Section string_eq. + +Definition string_eqMixin := @EqMixin string eqb eqb_spec. +Canonical string_eqType := EqType string string_eqMixin. + +End string_eq. + +Local Obligation Tactic := idtac. +Program Fixpoint prod_meas (l : list {d & measurableType d}) : {d & measurableType d} := + match l with + | [::] => existT measurableType _ munit + | h :: t => + let t' := prod_meas t in + existT _ _ _ + end. +Next Obligation. +move=> ? l h t htl t'. +exact: (measure_prod_display (projT1 h, projT1 t')). +Defined. +Next Obligation. +move=> ? l h t htl t'. +simpl. +exact: [the measurableType _ of (projT2 h * projT2 t')%type]. +Defined. + +Inductive stype := +| sunit : stype +| sbool : stype +| sreal : stype +| spair : stype -> stype -> stype +| sprob : stype -> stype +| sprod : list stype -> stype. + +Fixpoint typei (t : stype) : {d & measurableType d} := + match t with + | sunit => existT _ _ munit + | sbool => existT _ _ mbool + | sreal => existT _ _ (mR R) + | spair A B => existT _ _ + [the measurableType ((projT1 (typei A),projT1 (typei B)).-prod)%mdisp of (projT2 (typei A) * projT2 (typei B))%type] + | sprob A => existT _ _ (pprobability (projT2 (typei A)) R) + | sprod l => prod_meas (map typei l) + end. + +Definition typei2 (t : stype) := projT2 (typei t). + +End type_syntax. + +Arguments typei {R}. +Arguments typei2 {R}. + +Section context. +Definition context := seq (string * stype)%type. +End context. + +Section expr. +Variables (R : realType). +Inductive expD : context -> stype -> Type := +| exp_unit l : expD l sunit +| exp_bool l : bool -> expD l sbool +| exp_real l : R -> expD l sreal +| exp_pair l t1 t2 : expD l t1 -> expD l t2 -> expD l (spair t1 t2) +| exp_var l x t : t = nth sunit (map snd l) (seq.index x (map fst l)) -> + expD l t +| exp_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : + expD l (sprob sbool) +| exp_poisson l : nat -> expD l sreal -> expD l sreal +| exp_norm l t : expP l t -> expD l (sprob t) + +with expP : context -> stype -> Type := +| exp_if l t : expD l sbool -> expP l t -> expP l t -> expP l t +| exp_letin l l' t1 t2 (x : string) : l' = (x, t1) :: l -> + expP l t1 -> expP l' t2 -> expP l t2 +(* | exp_sample : forall t l, expD (sprob t) l -> expP t l *) +| exp_sample_bern l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : + expP l sbool +| exp_score l : expD l sreal -> expP l sunit +| exp_return l t : expD l t -> expP l t +. + +End expr. + +Arguments expD {R}. +Arguments expP {R}. +Arguments exp_unit {R l}. +Arguments exp_bool {R l}. +Arguments exp_real {R l}. +Arguments exp_pair {R l _ _}. +Arguments exp_var {R _}. +Arguments exp_bernoulli {R l}. +Arguments exp_poisson {R l}. +Arguments exp_norm {R l _}. +Arguments exp_if {R l _}. +Arguments exp_letin {R l _ _}. +Arguments exp_sample_bern {R} l r. +Arguments exp_score {R l}. +Arguments exp_return {R l _}. + +Section eval. +Variables (R : realType). + +Definition varof (l : context) (i : nat) (li : (i < size l)%nat) : + projT2 (@typei R (sprod (map snd l))) -> + projT2 (@typei R (nth sunit (map snd l) i)). +revert l i li. +fix H 1. +destruct l. + by destruct i. +destruct i. +simpl => _. +intro K. +exact: K.1. +simpl. +move=> il. +move=> K. +refine (H _ _ _ K.2). +exact il. +Defined. + +Lemma false_index_size (x : string) (l : context) (H : x \in (map fst l)) : + (seq.index x (map fst l) < size l)%nat. +Proof. by rewrite -(size_map fst) index_mem. Qed. + +Lemma mvarof (l : context) (i : nat) (li : (i < size l)%nat) : + measurable_fun setT (@varof l i li). +Proof. +revert l i li. +induction l. + by destruct i. +destruct i. +simpl => _. +intro K. +exact: measurable_fun_fst. +move=> il K. +apply: (measurable_funT_comp (IHl _ _) (@measurable_fun_snd _ _ _ _)). +apply: K. +Qed. + +Lemma measurable_fun_normalize d d' (X : measurableType d) (Y : measurableType d') (k : R.-sfker X ~> Y) : + measurable_fun setT (normalize k point : X -> pprobability Y R). +Proof. +(* have := measurable_kernel k set0 measurable0. +rewrite /normalize /mnormalize. +(* rewrite [X in measurable_fun X](_ : _ = (fun x : X => + if (k x [set: Y] == 0) || (k x [set: Y] == +oo) + then fun U : set Y =>point U + else fun U : set Y => k x U * ((fine (k x [set: Y]))^-1)%:E)); last first. *) +suff: measurable_fun (T:=X) (U:=pprobability Y R) [set: X] + (fun x : X => + fun U : set Y => + if (k x [set: Y] == 0) || (k x [set: Y] == +oo) + then point U + else k x U * ((fine (k x [set: Y]))^-1)%:E). +have:= (@measurable_fun_if _ _ _ _ (fun x => _) (fun x U => k x U * ((fine (k x [set: Y]))^-1)%:E) (fun x => (k x [set: Y] == 0) || (k x [set: Y] == +oo))). +(* move=> mX U mU. +rewrite setTI. *) +apply: measurability. +reflexivity. +move=> B [Z [r r01]] [Z0 mZ0 <-{Z}] <-{B}. +rewrite /normalize. +rewrite /mnormalize. +rewrite setTI. +rewrite /mset /preimage /= /mnormalize. +rewrite [X in measurable X](_ : _ = (fun x : X => + if (k x [set: Y] == 0) || (k x [set: Y] == +oo) + then fun U : set Y =>point U + else fun U : set Y => k x U * ((fine (k x [set: Y]))^-1)%:E) @^-1` + [set mu | mu Z0 < r%:E]); last first. + apply/funext => x/=. + rewrite /mset/= /mnormalize. + case: ifP => //= ?. + rewrite diracE. + case: (point \in Z0) => /=. + admit. + apply: measurable_fun_if. + reflexivity. + done. +simpl. +rewe +move=> _ B. +rewrite /pset/= => hB. + => _ /= -[_ [r ->] <-]. +(* apply: (measurability (ErealGenInftyO.measurableE R)). *) +apply: measurability => //. +apply: measurableI => //. +apply: measurable_fun_knormalize. +have := measurable_kernel [the kernel _ _ _ of (normalize k : X -> pprobability Y R)]. +rewrite preimage. *) +Admitted. + +(* Fixpoint denoteType (t : stype) (e : @expD t) := + match e with + | exp_unit => sunit + | exp_bool _ => sbool + | exp_real R _ => sreal + | exp_pair _ _ e1 e2 => spair (denoteType e1) (denoteType e2) + | exp_var l x => nth sunit (map snd l) (seq.index x (map fst l)) + end. *) + +(* Fixpoint execD (l : context) (t : stype) (e : expD t) + : {f : @typei2 R (sprod (map snd l)) -> typei2 (denoteType e) & measurable_fun _ f} := + match e return {f : @typei2 R (sprod (map snd l)) -> typei2 (denoteType e) & measurable_fun _ f} with + | exp_unit => existT _ (cst tt) ktt + | exp_bool b => existT _ (cst b) (kb b) + | exp_real r => existT _ (cst r) (kr r) + | exp_pair _ _ e1 e2 => + existT _ _ (@measurable_fun_pair _ _ _ _ _ _ _ _ (projT2 (execD l e1)) (projT2 (execD l e2))) + | exp_var l x => forall (H : x \in (map fst l)), + existT _ (@varof l (seq.index x (map fst l)) (false_index_size H)) (@mvarof l (seq.index x (map fst l)) (false_index_size H)) + end. *) + +Reserved Notation "l |- e -D-> v # mv" (at level 50). +Reserved Notation "l |- e -P-> v" (at level 50). + +Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) + (f : projT2 (typei (sprod (map (snd) l))) -> projT2 (typei T)), + measurable_fun setT f -> Prop := +| E_unit l : + l |- exp_unit -D-> cst tt # ktt + +| E_bool l b : + l |- exp_bool b -D-> cst b # kb b + +| E_real l r : + l |- exp_real r -D-> cst r # kr r + +| E_pair l (G := sprod (map (snd) l)) A B e1 f1 mf1 e2 f2 mf2 : + l |- e1 -D-> f1 # mf1 -> (* (f1 : projT2 (typei G) -> projT2 (typei A)) *) + l |- e2 -D-> f2 # mf2 -> (* (f2 : projT2 (typei G) -> projT2 (typei B)) *) + + l |- exp_pair e1 e2 -D-> fun x => (f1 x, f2 x) # + (@measurable_fun_pair _ _ _ (projT2 (typei G)) (projT2 (typei A)) + (projT2 (typei B)) f1 f2 mf1 mf2) + (* + ((fun x : projT2 (typei G) => (f1 x, f2 x)) + : projT2 (typei G) -> projT2 (typei (spair A B))) + *) + +| E_var (l : context) (x : string) (H : x \in map fst l) : + let i := seq.index x (map fst l) in + l |- exp_var x _ erefl -D-> @varof l i (false_index_size H) # + @mvarof l i (false_index_size H) + +| E_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : + l |- exp_bernoulli r r1 -D-> + cst [the probability _ _ of bernoulli r1] # measurable_fun_cst _ + (* sprob sbool *) + +| E_poisson l k e f mf : + l |- e -D-> f # mf -> + l |- exp_poisson k e -D-> poisson k \o f # + measurable_funT_comp (mpoisson k) mf + +| E_norm l (t : stype) (e : expP l t) (k : R.-sfker _ ~> projT2 (typei t)) : + l |- e -P-> k -> + l |- exp_norm e -D-> (normalize k point : _ -> pprobability _ _) # + measurable_fun_normalize k + +where "l |- e -D-> v # mv" := (@evalD l _ e v mv) + +with evalP : forall (l : context) (T : stype), + expP l T -> + R.-sfker (projT2 (typei (sprod (map (snd) l)))) ~> projT2 (typei T) -> Prop := +| E_sample l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : + (* @evalD l (sprob T) e (cst p) (measurable_fun_cst p) -> *) + l |- @exp_sample_bern R _ r r1 -P-> + sample [the probability _ _ of bernoulli r1] + +| E_ifP l T e1 f1 mf e2 k2 e3 k3 : + l |- e1 -D-> f1 # mf -> + l |- e2 -P-> k2 -> + l |- e3 -P-> k3 -> + l |- exp_if e1 e2 e3 : expP l T -P-> ite mf k2 k3 + +| E_score l (G := sprod (map snd l)) e (f : projT2 (typei G) -> R) + (mf : measurable_fun _ f) : + l |- e : expD l sreal -D-> f # mf -> + l |- exp_score e -P-> [the R.-sfker _ ~> _ of kscore mf] + +| E_return l T e (f : _ -> _) (mf : measurable_fun _ f) : + l |- e -D-> f # mf -> + l |- exp_return e : expP l T -P-> ret mf + +| E_letin (l : context) (G := sprod (map snd l)) (t1 t2 : stype) + (x : string) (e1 : expP l t1) (e2 : expP ((x, t1) :: l) t2) + (k1 : R.-sfker projT2 (typei G) ~> projT2 (typei t1)) + (k2 : R.-sfker (typei2 (spair t1 G)) ~> projT2 (typei t2)) : + l |- e1 -P-> k1 -> + ((x, t1)::l)%SEQ |- e2 -P-> k2 -> + l |- exp_letin _ x erefl e1 e2 -P-> letin' k1 k2 +where "l |- e -P-> v" := (@evalP l _ e v). + +End eval. + +Section eval_prop. +Variables (R : realType). + +Ltac inj H := apply Classical_Prop.EqdepTheory.inj_pair2 in H. + +Scheme evalD_mut_ind := Induction for evalD Sort Prop +with evalP_mut_ind := Induction for evalP Sort Prop. + +Scheme expD_mut_ind := Induction for expD Sort Prop +with expP_mut_ind := Induction for expP Sort Prop. + +Lemma evalD_uniq (l : context) (G := sprod (map snd l)) (t : stype) + (e : expD l t) (u v : projT2 (typei G) -> projT2 (typei t)) + (mu : measurable_fun _ u) (mv : measurable_fun _ v) : + @evalD R l t e u mu -> evalD e mv -> u = v. +Proof. +move=> hu. +apply: (@evalD_mut_ind R + (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expD l t) + (f : projT2 (typei G) -> projT2 (typei t)) (mf : measurable_fun setT f) + (h1 : evalD e mf) => forall (v : projT2 (typei G) -> projT2 (typei t)) (mv : measurable_fun setT v), evalD e mv -> f = v) + (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) + (u : R.-sfker projT2 (typei G) ~> projT2 (typei t)) (h1 : evalP e u) => + forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), + evalP e v -> u = v) _ _ _ _ _ _ _ _ _ _ _ _ _ l t e); last exact: hu. +- +move=> l' {}v {}mv. +inversion 1. +by do 2 inj H3. +- +move=> l' b {}v {}mv. +inversion 1. +by do 2 inj H3. +- +move=> l' r {}v {}mv. +inversion 1. +subst. +by do 2 inj H3. +- (* pair *) +move=> l' G0 A B e1 f1 mf1 e2 f2 mf2 ev1 IH1 ev2 IH2 {}v {}mv H. +simple inversion H => //. +injection H3 => ? ?; subst A0 B0 l0. +inj H4. +injection H4 => He1 He2. +do 2 inj He1. +do 2 inj He2. +subst e0 e3. +do 2 inj H5. +move=> e1f0 e2f3. +by rewrite (IH1 _ _ e1f0) (IH2 _ _ e2f3). +- (* var *) +move=> l' x H n {}v {}mv. +inversion 1. +do 2 inj H8. +by have -> : (H = H1) by exact: Prop_irrelevance. +- (* bernoulli *) +move=> l' r r1 {}v {}mv. +inversion 1. +subst. +do 2 inj H3. +subst. +by have -> : (r1 = r3) by exact: Prop_irrelevance. +- (* poisson *) +move=> l' k e0 f mf ev IH {}v {}mv. +inversion 1. +subst. +inj H2. +do 2 inj H4. +subst. +by rewrite (IH _ _ H3). +- (* norm *) +move=> l' A e0 k ev IH {}v {}mv. +inversion 1. +do 2 inj H2. +do 2 inj H4. +subst. +by rewrite (IH _ H3). +- (* sample *) +move=> l' r r1 p. +inversion 1. +(* do 2 inj H0. *) +do 2 inj H3. +subst. +by have -> : (r1 = r3) by apply: Prop_irrelevance. +- (* if *) +move=> l' G0 e0 f1 mf1 e2 k2 e3 k3 ev1 IH1 ev2 IH2 ev3 IH3 k. +inversion 1. +inj H0. +do 2 inj H1. +do 2 inj H2. +subst. +do 2 inj H5. +have ? := IH1 _ _ H6. +subst f1. +have -> : (mf1 = mf) by exact: Prop_irrelevance. +by rewrite (IH2 _ H7) (IH3 _ H8). +- (* score *) +move=> l' G0 e0 f mf ev IH k H. +simple inversion H => // ev0. +subst. +do 2 inj H4. +do 2 inj H3. +injection H3 => H5. +inj H5. +subst. +have ? := IH _ _ ev0. +subst f0. +by have -> : (mf = mf0) by exact: Prop_irrelevance. +- (* return *) +move=> l' A e0 f mf ev IH k. +inversion 1. +subst. +do 2 inj H5. +do 2 inj H7. +subst. +have ? := IH _ _ H3. +subst f1. +by have -> : (mf = mf1) by exact: Prop_irrelevance. +- (* letin *) +move=> l' G0 A B x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. +inversion 1. +subst. +do 2 inj H10. +(* inj H5. +inj H6. *) +do 2 inj H13. +do 2 inj H11. +subst. +by rewrite (IH1 _ H4) (IH2 _ H14). +Qed. + +(* TODO: factorize proof *) +Lemma evalP_uniq (l : context) (t : stype) (e : expP l t) + (u v : R.-sfker typei2 (sprod (map snd l)) ~> typei2 t) : + evalP e u -> evalP e v -> u = v. +Proof. +move=> hu. +apply: (@evalP_mut_ind R + (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expD l t) (f : projT2 (typei G) -> projT2 (typei t)) (mf : measurable_fun setT f) (h1 : evalD e mf) => + forall (v : projT2 (typei G) -> projT2 (typei t)) (mv : measurable_fun setT v), evalD e mv -> f = v) + (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) (u : R.-sfker projT2 (typei G) ~> projT2 (typei t)) (h1 : evalP e u) => + forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), evalP e v -> u = v) + _ _ _ _ _ _ _ _ _ _ _ _ _ l t e); last exact: hu. +- +move=> l' {}v {}mv. +inversion 1. +by do 2 inj H3. +- +move=> l' b {}v {}mv. +inversion 1. +by do 2 inj H3. +- +move=> l' r {}v {}mv. +inversion 1. +subst. +by do 2 inj H3. +- (* pair *) +move=> l' G0 A B e1 f1 mf1 e2 f2 mf2 ev1 IH1 ev2 IH2 {}v {}mv H. +simple inversion H => //. +injection H3 => ? ?; subst A0 B0 l0. +inj H4. +injection H4 => He1 He2. +do 2 inj He1. +do 2 inj He2. +subst e0 e3. +do 2 inj H5. +move=> e1f0 e2f3. +by rewrite (IH1 _ _ e1f0) (IH2 _ _ e2f3). +- (* var *) +move=> l' x H n {}v {}mv. +inversion 1. +do 2 inj H8. +by have -> : (H = H1) by exact: Prop_irrelevance. +- (* bernoulli *) +move=> l' r r1 {}v {}mv. +inversion 1. +subst. +do 2 inj H3. +subst. +by have -> : (r1 = r3) by exact: Prop_irrelevance. +- (* poisson *) +move=> l' k e0 f mf ev IH {}v {}mv. +inversion 1. +subst. +inj H2. +do 2 inj H4; clear H5. +subst. +by rewrite (IH _ _ H3). +- (* norm *) +move=> l' A e0 k ev IH {}v {}mv. +inversion 1. +do 2 inj H2. +do 2 inj H4. +subst. +by rewrite (IH _ H3). +- (* sample *) +move=> l' r r1 ev. +inversion 1. +(* do 2 inj H0. *) +do 2 inj H3. +subst. +by have -> : (r1 = r3) by exact: Prop_irrelevance. +- (* if *) +move=> l' G0 e0 f1 mf1 e2 k2 e3 k3 ev1 IH1 ev2 IH2 ev3 IH3 k. +inversion 1. +inj H0. +do 2 inj H1. +do 2 inj H2. +subst. +do 2 inj H5. +have ? := IH1 _ _ H6. +subst f1. +have -> : (mf1 = mf) by exact: Prop_irrelevance. +by rewrite (IH2 _ H7) (IH3 _ H8). +- (* score *) +move=> l' G0 e0 f mf ev IH k H. +simple inversion H => // ev0. +subst. +do 2 inj H4. +do 2 inj H3. +injection H3 => H5. +inj H5. +subst. +have ? := IH _ _ ev0. +subst f0. +by have -> : (mf = mf0) by exact: Prop_irrelevance. +- (* return *) +move=> l' A e0 f mf ev IH k. +inversion 1. +subst. +do 2 inj H5. +do 2 inj H7. +subst. +have ? := IH _ _ H3. +subst f1. +by have -> : (mf = mf1) by exact: Prop_irrelevance. +- (* letin *) +move=> l' G0 A B x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. +inversion 1. +subst. +do 2 inj H10. +do 2 inj H11. +do 2 inj H13. +(* do 2 inj H7. +do 4 inj H8. *) +subst. +by rewrite (IH1 _ H4) (IH2 _ H14). +Qed. + +Fixpoint free_varsD l t (e : @expD R l t) : seq string := + match e with + | exp_var _ x _ _ => [:: x] + | exp_poisson _ _ e => free_varsD e + | exp_pair _ _ _ e1 e2 => free_varsD e1 ++ free_varsD e2 + | exp_unit _ => [::] + | exp_bool _ _ => [::] + | exp_real _ _ => [::] + | exp_bernoulli _ _ _ => [::] + | exp_norm _ _ e => free_varsP e + end +with free_varsP T l (e : expP T l) : seq _ := + match e with + | exp_if _ _ e1 e2 e3 => free_varsD e1 ++ free_varsP e2 ++ free_varsP e3 + | exp_letin _ _ _ _ x _ e1 e2 => free_varsP e1 ++ rem x (free_varsP e2) + | exp_sample_bern _ _ _ => [::] + | exp_score _ e => free_varsD e + | exp_return _ _ e => free_varsD e + end. + +Lemma evalD_full (l : context) (t : stype) : + forall e, {subset (free_varsD e) <= map fst l} -> + exists f (mf : measurable_fun _ f), @evalD R l t e f mf. +Proof. +move=> e. +apply: (@expD_mut_ind R + (fun (l : context) (t : stype) (e : expD l t) => + {subset (free_varsD e) <= map fst l} -> + exists f (mf : measurable_fun _ f), evalD e mf) + (fun (l : context) (t : stype) (e : expP l t) => + {subset (free_varsP e) <= map fst l} -> + exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). +do 2 eexists; apply/E_unit. +do 2 eexists; apply/E_bool. +do 2 eexists; apply/E_real. +move=> l0 t1 t2 e1 H1 e2 H2 el. +have h1 : {subset free_varsD e1 <= [seq i.1 | i <- l0]}. + move=> x xe1. + apply: el => /=. + by rewrite mem_cat xe1. +have h2 : {subset free_varsD e2 <= [seq i.1 | i <- l0]}. + move=> x xe2. + apply: el => /=. + by rewrite mem_cat xe2 orbT. +move: H1 => /(_ h1) => H1. +move: H2 => /(_ h2) => H2. +destruct H1 as [f1 [mf1]]. +destruct H2 as [f2 [mf2]]. +exists (fun x => (f1 x, f2 x)). +eexists; exact: E_pair. +move=> l0 x t0 t0E H. +subst t0. +have xl0 : x \in map fst l0. +apply: H. +by rewrite /= inE. +(* exists (@varof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). *) +(* exists (@mvarof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). *) +do 2 eexists. +by apply/E_var. +move=> r r1. +eexists. +eexists. +exact: E_bernoulli. +move=> l0 k e0 H el. +have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. + move=> x xe0. + by apply: el => /=. +move: H => /(_ h) => H. +destruct H as [f [mf]]. +exists (poisson k \o f). +exists (measurable_funT_comp (mpoisson k) mf). +exact: E_poisson. +move=> l0 t0 e0 H el. +have h : {subset free_varsP e0 <= map fst l0}. + move=> x xe0. + by apply: el => /=. +move: H => /(_ h) => H. +destruct H as [k]. +exists (normalize k point). +exists (measurable_fun_normalize k). +exact: E_norm. +move=> l0 t0 e1 H1 e2 H2 e3 H3 el. +have h1 : {subset free_varsD e1 <= map fst l0}. + move=> x xe1. + apply: el => /=. + by rewrite mem_cat xe1. +have h2 : {subset free_varsP e2 <= map fst l0}. + move=> x xe2. + apply: el => /=. + by rewrite 2!mem_cat xe2 orbT. +have h3 : {subset free_varsP e3 <= map fst l0}. + move=> x xe3. + apply: el => /=. + by rewrite 2!mem_cat xe3 2!orbT. +move: H1 => /(_ h1) => H1. +move: H2 => /(_ h2) => H2. +move: H3 => /(_ h3) => H3. +destruct H1 as [f [mf]]. +destruct H2 as [k2]. +destruct H3 as [k3]. +exists (ite mf k2 k3). +exact: E_ifP. +move=> l0 l1 t1 t2 x l1l0 e1 H1 e2 H2 el. +have h1 : {subset free_varsP e1 <= map fst l0}. + move=> y ye1. + apply: el => /=. + by rewrite mem_cat ye1. +have h2 : {subset free_varsP e2 <= map fst ((x, t1) :: l0)}. + move=> y ye2. + rewrite /= inE. + have [//|/= xy] := eqVneq x y. + apply: el => /=. + rewrite mem_cat. + apply/orP. + right. + move: ye2 xy. + move: (free_varsP e2). + (* TODO: extract lemma *) + elim=> // h tl ih /=; rewrite inE => /orP[/eqP <-|yt xy]. + by move/negbTE; rewrite eq_sym => ->; rewrite mem_head. + by case: ifPn => // hx; rewrite inE ih ?orbT. +subst l1. +move: H1 => /(_ h1) => H1. +move: H2 => /(_ h2) => H2. +destruct H1 as [k1 ev1]. +destruct H2 as [k2 ev2]. +exists (letin' k1 k2). +exact: E_letin. +move=> l0 r r1 el. +exists (sample [the pprobability _ _ of bernoulli r1]). +exact: E_sample. +move=> l0 e0 H el. +have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. + move=> x xe0. + by apply: el => /=. +move: H => /(_ h) => H. +destruct H as [f [mf]]. +exists (score mf). +exact: E_score. +move=> l0 t0 e0 H el. +have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. + move=> x xe0. + by apply: el => /=. +move: H => /(_ h) => H. +destruct H as [f [mf]]. +exists (ret mf). +exact: E_return. +Qed. + +Lemma evalP_full (l : context) (t : stype) : + forall e, {subset (free_varsP e) <= map fst l} -> + exists (k : R.-sfker _ ~> _), @evalP R l t e k. +Proof. +move=> e. +apply: (@expP_mut_ind R + (fun (l : context) (t : stype) (e : expD l t) => + {subset (free_varsD e) <= map fst l} -> + exists f (mf : measurable_fun _ f), evalD e mf) + (fun (l : context) (t : stype) (e : expP l t) => + {subset (free_varsP e) <= map fst l} -> + exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). +do 2 eexists; apply/E_unit. +do 2 eexists; apply/E_bool. +do 2 eexists; apply/E_real. +move=> l0 t1 t2 e1 H1 e2 H2 el. +have h1 : {subset free_varsD e1 <= [seq i.1 | i <- l0]}. + move=> x xe1. + apply: el => /=. + by rewrite mem_cat xe1. +have h2 : {subset free_varsD e2 <= [seq i.1 | i <- l0]}. + move=> x xe2. + apply: el => /=. + by rewrite mem_cat xe2 orbT. +move: H1 => /(_ h1) => H1. +move: H2 => /(_ h2) => H2. +destruct H1 as [f1 [mf1]]. +destruct H2 as [f2 [mf2]]. +exists (fun x => (f1 x, f2 x)). +eexists; exact: E_pair. +move=> l0 x t0 t0E H. +subst t0. +have xl0 : x \in map fst l0. +apply: H. +by rewrite /= inE. +do 2 eexists. +by apply/E_var. +move=> r r1. +eexists. +eexists. +exact: E_bernoulli. +move=> l0 k e0 H el. +have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. + move=> x xe0. + by apply: el => /=. +move: H => /(_ h) => H. +destruct H as [f [mf]]. +exists (poisson k \o f). +exists (measurable_funT_comp (mpoisson k) mf). +exact: E_poisson. +move=> l0 t0 e0 H el. +have h : {subset free_varsP e0 <= map fst l0}. + move=> x xe0. + by apply: el => /=. +move: H => /(_ h) => H. +destruct H as [k]. +exists (normalize k point). +exists (measurable_fun_normalize k). +exact: E_norm. +move=> l0 t0 e1 H1 e2 H2 e3 H3 el. +have h1 : {subset free_varsD e1 <= map fst l0}. + move=> x xe1. + apply: el => /=. + by rewrite mem_cat xe1. +have h2 : {subset free_varsP e2 <= map fst l0}. + move=> x xe2. + apply: el => /=. + by rewrite 2!mem_cat xe2 orbT. +have h3 : {subset free_varsP e3 <= map fst l0}. + move=> x xe3. + apply: el => /=. + by rewrite 2!mem_cat xe3 2!orbT. +move: H1 => /(_ h1) => H1. +move: H2 => /(_ h2) => H2. +move: H3 => /(_ h3) => H3. +destruct H1 as [f [mf]]. +destruct H2 as [k2]. +destruct H3 as [k3]. +exists (ite mf k2 k3). +exact: E_ifP. +move=> l0 l1 t1 t2 x l1l0 e1 H1 e2 H2 el. +have h1 : {subset free_varsP e1 <= map fst l0}. + move=> y ye1. + apply: el => /=. + by rewrite mem_cat ye1. +have h2 : {subset free_varsP e2 <= map fst ((x, t1) :: l0)}. + move=> y ye2. + rewrite /= inE. + have [//|/= xy] := eqVneq x y. + apply: el => /=. + rewrite mem_cat. + apply/orP. + right. + move: ye2 xy. + move: (free_varsP e2). + (* TODO: extract lemma *) + elim=> // h tl ih /=; rewrite inE => /orP[/eqP <-|yt xy]. + by move/negbTE; rewrite eq_sym => ->; rewrite mem_head. + by case: ifPn => // hx; rewrite inE ih ?orbT. +subst l1. +move: H1 => /(_ h1) => H1. +move: H2 => /(_ h2) => H2. +destruct H1 as [k1 ev1]. +destruct H2 as [k2 ev2]. +exists (letin' k1 k2). +exact: E_letin. +move=> l0 r r1 el. +exists (sample [the pprobability _ _ of bernoulli r1]). +exact: E_sample. +move=> l0 e0 H el. +have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. + move=> x xe0. + by apply: el => /=. +move: H => /(_ h) => H. +destruct H as [f [mf]]. +exists (score mf). +exact: E_score. +move=> l0 t0 e0 H el. +have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. + move=> x xe0. + by apply: el => /=. +move: H => /(_ h) => H. +destruct H as [f [mf]]. +exists (ret mf). +exact: E_return. +Qed. + +(* Variables (A B C : stype). +Definition X := @typei2 R A. +Definition Y := @typei2 R B. +Definition Z := @typei2 R C. *) + +Definition execP l t (e : @expP R l t) (H : {subset free_varsP e <= map fst l}): + R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t. +Proof. +have /cid h := @evalP_full l t e H. +exact: (proj1_sig h). +Defined. + +Definition execP_cst (l l' : context) (r : R) : + R.-sfker (@typei2 R (sprod (map (@snd string stype) l'))) ~> @typei2 R sreal. +Proof. +have H0 : {subset free_varsP (exp_return (exp_real r) : expP [::] _) <= map (@fst string stype) l'}. + by move=> x /=. +have /cid h := @evalP_full l' _ (exp_return (exp_real r)) H0. +exact: (proj1_sig h). +Defined. + +Scheme expD_mut_rec := Induction for expD Sort Type +with expP_mut_rec := Induction for expP Sort Type. + +Definition rem_context l t (e : @expP R l t) (H : free_varsP e = [::]) : @expP R [::] t. +move: H. +apply: (@expP_mut_rec R + (fun (l : context) (t : stype) (e : expD l t) => + free_varsD e = [::] -> expD [::] t) + (fun (l : context) (t : stype) (e : expP l t) => + free_varsP e = [::] -> expP [::] t) + _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). +move=> ? ?; exact: exp_unit. +move=> ? b ?; exact: (exp_bool b). +move=> ? r ?; exact: (exp_real r). +move=> t1 t2 ? e1 t1nil e2 t2nil H. +rewrite /= in H. +apply: exp_pair. +apply: t1nil. +by destruct (free_varsD e1). +apply: t2nil. +destruct (free_varsD e2). +reflexivity. +move/(congr1 size) : H. +by rewrite size_cat/= addnS. +done. +move=> ? r r1 H. +apply: exp_bernoulli. +exact: r1. +rewrite /=. +move=> ? n e1 h H. +apply: (exp_poisson n). +exact: h. +rewrite /=. +move=> ? ? e1 h H. +apply: exp_norm. +exact: h. +move=> ? ? e1 h1 e2 h2 e3 h3 /= H. +apply: exp_if. +apply: h1. +by destruct (free_varsD e1). +apply: h2. +move: H. +destruct (free_varsP e2) => //=. +move=>/(congr1 size). +by rewrite !size_cat/= addnS. +apply: h3. +destruct (free_varsP e3) => //=. +move/(congr1 size) : H. +by rewrite !size_cat/= !addnS. +rewrite /=. +move=> ? t1 t2 x e1 h1 e2 h2 H. +Abort. + +(* Variables (dT : measure_display) (T : measurableType dT). +(* Definition m := fun A => (_ : {measure set (@typei2 R A) -> \bar R}). *) + +Axiom same_expP : forall (l l' : context) (T : stype) (e : @expP R T l) + (e' : @expP R T l'), Prop. *) + +Lemma evalP_uni_new x r + (u : R.-sfker munit ~> mR R) + (v : R.-sfker prod_meas_obligation_2 prod_meas + (existT [eta measurableType] default_measure_display (mR R)) + [::] ~> mR R) : + evalP (exp_return (exp_real r) : expP [::] sreal) u -> + evalP (exp_return (exp_real r) : expP [:: (x, sreal)] sreal) v -> + forall x0 t, v (x0, t) = u t. +Proof. +move=> H1 H2. +have -> : u = ret (kr r). +have := @evalP_uniq [::] sreal (exp_return (exp_real r)) u (ret (kr r)) H1. +apply. +apply/E_return /E_real. +suff : v = ret (kr r) by move=> ->. +have := @evalP_uniq [:: (x, sreal)] sreal (exp_return (exp_real r)) v (ret (kr r)) H2. +apply. +exact/E_return/E_real. +Qed. + +Definition vx : R.-sfker munit ~> mR R := execP_cst [:: ("x", sreal)] [::] 1. +Definition VX z : set (mR R) -> \bar R := vx z. +Let VX0 z : (VX z) set0 = 0. Proof. by []. Qed. +Let VX_ge0 z x : 0 <= (VX z) x. Proof. by []. Qed. +Let VX_semi_sigma_additive z : semi_sigma_additive (VX z). +Proof. exact: measure_semi_sigma_additive. Qed. +HB.instance Definition _ z := @isMeasure.Build _ R (mR R) (VX z) (VX0 z) + (VX_ge0 z) (@VX_semi_sigma_additive z). +Let sfinVX z : sfinite_measure (VX z). Proof. exact: sfinite_kernel_measure. Qed. +HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ (mR R) R + (VX z) (sfinVX z). + +Definition vy' : R.-sfker munit ~> mR R := execP_cst [::] [::] 2. +Definition VY z : set (mR R) -> \bar R := vy' z. +Let VY0 z : (VY z) set0 = 0. Proof. by []. Qed. +Let VY_ge0 z x : 0 <= (VY z) x. Proof. by []. Qed. +Let VY_semi_sigma_additive z : semi_sigma_additive (VY z). +Proof. exact: measure_semi_sigma_additive. Qed. +HB.instance Definition _ z := @isMeasure.Build _ R (mR R) (VY z) (VY0 z) + (VY_ge0 z) (@VY_semi_sigma_additive z). +Let sfinVY z : sfinite_measure (VY z). Proof. exact: sfinite_kernel_measure. Qed. +HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ (mR R) R + (VY z) (sfinVY z). + +Lemma letinC12 v1 v2 t M : + let x := "x" in + let y := "y" in + measurable M -> + @evalP R [::] (spair sreal sreal) (exp_letin _ x erefl (exp_return (exp_real 1)) (exp_letin _ y erefl (exp_return (exp_real 2)) (exp_return (exp_pair (exp_var x _ erefl) (exp_var y _ erefl))))) v1 -> + evalP (exp_letin _ y erefl (exp_return (exp_real 2)) (exp_letin _ x erefl (exp_return (exp_real 1)) (exp_return (exp_pair (exp_var x _ erefl) (exp_var y _ erefl))))) v2 -> + v1 t M = v2 t M. +Proof. +move=> x y mM ev1 ev2. +pose vx : R.-sfker munit ~> mR R := execP_cst [:: (x, sreal)] [::] 1. +pose vy : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := execP_cst [:: (x, sreal)] [:: (x, sreal)] 2. +have -> : v1 = letin' (vx) (letin' (vy) (ret (measurable_fun_pair var2of3' var1of3'))). +apply: (evalP_uniq ev1). +apply/E_letin /E_letin. +rewrite /vx /execP_cst /ssr_have /sval/=. +by case: cid => // ? h. +rewrite /vy /execP_cst /ssr_have /sval/=. +by case: cid => // ? h. +apply/E_return /E_pair. +have -> : (var2of3' = (@mvarof R [:: (y, sreal); (x, sreal)] 1 (false_index_size (_ : (x \in map fst [:: (y, sreal); (x, sreal)]))))) by []. +apply/(@E_var R [:: (y, sreal); (x, sreal)] x). +have -> : (var1of4' = (@mvarof R [:: (y, sreal); (x, sreal)] 0 (false_index_size (_ : (y \in map fst [:: (y, sreal); (x, sreal)]))))) by []. +apply/(@E_var R [:: (y, sreal); (x, sreal)] y is_true_true). +pose vy' : R.-sfker munit ~> mR R := execP_cst [::] [::] 2. +pose vx' : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := execP_cst [:: (y, sreal)] [:: (y, sreal)] 1. +have -> : v2 = letin' (vy') (letin' (vx') (ret (measurable_fun_pair var1of3' var2of3'))). +apply: (evalP_uniq ev2). +apply/E_letin /E_letin. +rewrite /vy' /execP_cst /ssr_have /sval/=. +case: cid => //. +rewrite /vx' /execP_cst /ssr_have /sval/=. +case: cid => //. +apply/E_return /E_pair. +have -> : (var1of3' = (@mvarof R [:: (x, sreal); (y, sreal)] 0 (false_index_size (_ : (x \in map fst [:: (x, sreal); (y, sreal)]))))) by []. +apply/(@E_var R [:: (x, sreal); (y, sreal)] x is_true_true). +have -> : (var2of3' = (@mvarof R [:: (x, sreal); (y, sreal)] 1 (false_index_size (_ : (y \in map fst [:: (x, sreal); (y, sreal)]))))) by []. +apply/(@E_var R [:: (x, sreal); (y, sreal)] y is_true_true). +apply: letin'C; last by []. +move=> x0 t0. +rewrite (@evalP_uni_new y 1 vx vx'); last 2 first. + rewrite /vx /execP_cst /ssr_have /sval/=. + by case: cid. + rewrite /vx' /execP_cst /ssr_have /sval/=. + by case: cid. + by done. +move=> x0 t0. + rewrite /vy /vy' /execP_cst /ssr_have /sval/=. + case: cid => sy. + case: cid => sy'. + move=> er1 er2. + apply/esym/evalP_uni_new. + exact: er2. + exact: er1. +Qed. + +End eval_prop. + +Section example. + +Local Open Scope ring_scope. +Variables (R : realType). + +Notation "r '%:r'" := (exp_real r) (at level 2, left associativity). +Notation "% x" := (exp_var x _ erefl) (at level 4). +Notation Ret := exp_return. +Notation If := exp_if. +Notation "'Let' x <= e1 'In' e2" := (exp_letin _ x erefl e1 e2) (at level 40, x, e1, e2 at next level). + +Example __ : @evalD R [::] _ (exp_real 3) (cst 3) (kr 3). +Proof. apply: E_real. Qed. + +Example ex_ret : @evalP R [::] _ (exp_return (exp_real 3)) (ret (kr 3)). +Proof. +apply/E_return/E_real. +Qed. + +Check ret (kr 3) : R.-sfker _ ~> (mR R). +Check ret (kr 3) tt : {measure set mR R -> \bar R}. +Goal (ret (kr 3) : R.-sfker _ ~> (mR R)) tt [set: R] = 1%:E. +Proof. rewrite /= diracE in_setT //. Qed. + +Example pgm1 : expD [::] (sprob sbool) := exp_norm ( + Let "x" <= exp_sample_bern [::] (2 / 7%:R)%:nng p27 In + Let "r" <= If (@exp_var R [:: ("x", sbool)] "x" _ erefl) + (Ret 3%:r) (Ret 10%:r) In + Let "_" <= exp_score + (exp_poisson 4 (@exp_var R [:: ("r", sreal); ("x", sbool)] "r" _ erefl)) In Ret %"x"). + +Print pgm1. + +Definition sample_bern : R.-sfker munit ~> mbool := + sample [the probability _ _ of bernoulli p27]. +Definition ite_3_10 : + R.-sfker [the measurableType _ of (mbool * munit)%type] ~> (mR R) := + ite var1of4' (ret k3) (ret k10). +Definition score_poi : + R.-sfker [the measurableType _ of ((mR R) * (mbool * munit)%type)%type] ~> munit := + score (measurable_funT_comp (mpoisson 4) var1of4'). + +Local Definition kstaton_bus'' := + letin' sample_bern + (letin' ite_3_10 + (letin' score_poi (ret var3of4'))). + +Example ev1 : @evalD R [::] _ pgm1 _ (measurable_fun_normalize kstaton_bus''). +Proof. +apply/E_norm /E_letin /E_letin /E_letin. +apply/E_sample. +apply/E_ifP. +have -> : (var1of4' = (@mvarof R [:: ("x", sbool)] 0 (false_index_size (_ : "x" \in map fst [:: ("x", sbool)])))) by done. +exact: (@E_var R [:: ("x", sbool)] "x"). +apply/E_return /E_real. +apply/E_return /E_real. +apply/E_score /E_poisson. +have -> : (var1of4' = (@mvarof R [:: ("r", sreal); ("x", sbool)] 0 (false_index_size (_ : "r" \in map fst [:: ("r", sreal); ("x", sbool)])))) by done. +exact: (@E_var R [:: ("r", sreal); ("x", sbool)] "r"). +apply/E_return. +have -> : (var3of4' = (@mvarof R [:: ("_", sunit); ("r", sreal); ("x", sbool)] 2 (false_index_size (_ : "x" \in map fst [:: ("_", sunit); ("r", sreal); ("x", sbool)])))) by done. +exact: (@E_var R [:: ("_", sunit); ("r", sreal); ("x", sbool)] "x"). +Qed. + +End example. \ No newline at end of file diff --git a/theories/prob_lang.v b/theories/prob_lang.v index d7dd3d30aa..b1cdf777c9 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -548,12 +548,14 @@ Definition kr (r : R) := @measurable_fun_cst _ _ T _ setT r. Definition k3 : measurable_fun _ _ := kr 3%:R. Definition k10 : measurable_fun _ _ := kr 10%:R. Definition ktt := @measurable_fun_cst _ _ T _ setT tt. +Definition kb (b : bool) := @measurable_fun_cst _ _ T _ setT b. End cst_fun. Arguments kr {d T R}. Arguments k3 {d T R}. Arguments k10 {d T R}. Arguments ktt {d T}. +Arguments kb {d T}. Section insn1_lemmas. Import Notations. @@ -1013,3 +1015,312 @@ by rewrite addr_gt0// mulr_gt0//= ?divr_gt0// ?ltr0n// exp_density_gt0 ?ltr0n. Qed. End staton_bus_exponential. + + +Notation var1of3' := (@measurable_fun_fst _ _ _ _). +Notation var2of3' := (measurable_funT_comp (@measurable_fun_fst _ _ _ _) (@measurable_fun_snd _ _ _ _)). +Notation var3of3' := (measurable_funT_comp (@measurable_fun_fst _ _ _ _) (measurable_funT_comp (@measurable_fun_snd _ _ _ _) (@measurable_fun_snd _ _ _ _))). + +Notation var1of4' := (@measurable_fun_fst _ _ _ _). +Notation var2of4' := (measurable_funT_comp (@measurable_fun_fst _ _ _ _) (@measurable_fun_snd _ _ _ _)). +Notation var3of4' := (measurable_funT_comp (@measurable_fun_fst _ _ _ _) (measurable_funT_comp (@measurable_fun_snd _ _ _ _) (@measurable_fun_snd _ _ _ _))). +Notation var4of4' := (measurable_funT_comp (@measurable_fun_fst _ _ _ _) (measurable_funT_comp (@measurable_fun_snd _ _ _ _) (measurable_funT_comp (@measurable_fun_snd _ _ _ _) (@measurable_fun_snd _ _ _ _)))). + +Section kcomp'_def. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : X -> {measure set Y -> \bar R}. +Variable k : (Y * X)%type -> {measure set Z -> \bar R}. + +Definition kcomp' x U := \int[l x]_y k (y, x) U. + +End kcomp'_def. + +Section kcomp_is_measure. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : R.-ker X ~> Y. +Variable k : R.-ker [the measurableType _ of (Y * X)%type] ~> Z. + +Local Notation "l \; k" := (kcomp' l k). + +Let kcomp0 x : (l \; k) x set0 = 0. +Proof. +by rewrite /kcomp' (eq_integral (cst 0)) ?integral0// => y _; rewrite measure0. +Qed. + +Let kcomp_ge0 x U : 0 <= (l \; k) x U. Proof. exact: integral_ge0. Qed. + +Let kcomp_sigma_additive x : semi_sigma_additive ((l \; k) x). +Proof. +move=> U mU tU mUU; rewrite [X in _ --> X](_ : _ = + \int[l x]_y (\sum_(n V _. + by apply/esym/cvg_lim => //; exact/measure_semi_sigma_additive. +apply/cvg_closeP; split. + by apply: is_cvg_nneseries => n _; exact: integral_ge0. +rewrite closeE // integral_nneseries// => n. +by have /measurable_fun_prod2 := measurable_kernel k _ (mU n). +Qed. + +HB.instance Definition _ x := isMeasure.Build _ R _ + ((l \; k) x) (kcomp0 x) (kcomp_ge0 x) (@kcomp_sigma_additive x). + +Definition mkcomp' : X -> {measure set Z -> \bar R} := + fun x => [the measure _ _ of (l \; k) x]. + +End kcomp_is_measure. + +Notation "l \; k" := (mkcomp' l k) : ereal_scope. + +Module KCOMP_FINITE_KERNEL. + +Section measurable_fun_xsection_finite_kernel. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d') + (R : realType). +Variables (k : R.-fker X ~> Y). +Implicit Types A : set (Y * X). + +Let phi A := fun x => k x (ysection A x). +Let XY := [set A | measurable A /\ measurable_fun setT (phi A)]. + +Lemma measurable_fun_ysection_finite_kernel A : + A \in measurable -> measurable_fun setT (phi A). +Admitted. + +End measurable_fun_xsection_finite_kernel. + +Section measurable_fun_integral_finite_sfinite. +Variables (d d' : _) (X : measurableType d) (Y : measurableType d') + (R : realType). +Variable k : Y * X -> \bar R. + +Lemma measurable_fun_ysection_integral + (l : X -> {measure set Y -> \bar R}) + (k_ : ({nnsfun [the measurableType _ of (Y * X)%type] >-> R})^nat) + (ndk_ : nondecreasing_seq (k_ : (Y * X -> R)^nat)) + (k_k : forall z, EFin \o (k_ ^~ z) --> k z) : + (forall n r, measurable_fun setT (fun x => l x (ysection (k_ n @^-1` [set r]) x))) -> + measurable_fun setT (fun x => \int[l x]_y k (y, x)). +Admitted. + +Lemma measurable_fun_integral_finite_kernel (l : R.-fker X ~> Y) + (k0 : forall z, 0 <= k z) (mk : measurable_fun setT k) : + measurable_fun setT (fun x => \int[l x]_y k (y, x)). +Proof. +have [k_ [ndk_ k_k]] := approximation measurableT mk (fun x _ => k0 x). +apply: (measurable_fun_ysection_integral ndk_ (k_k ^~ Logic.I)) => n r. +have [l_ hl_] := measure_uub l. +by apply: measurable_fun_ysection_finite_kernel => // /[!inE]. +Qed. + +Lemma measurable_fun_integral_sfinite_kernel (l : R.-sfker X ~> Y) + (k0 : forall t, 0 <= k t) (mk : measurable_fun setT k) : + measurable_fun setT (fun x => \int[l x]_y k (y, x)). +Proof. +have [k_ [ndk_ k_k]] := approximation measurableT mk (fun xy _ => k0 xy). +apply: (measurable_fun_ysection_integral ndk_ (k_k ^~ Logic.I)) => n r. +have [l_ hl_] := sfinite l. +rewrite (_ : (fun x => _) = + (fun x => mseries (l_ ^~ x) 0 (ysection (k_ n @^-1` [set r]) x))); last first. + by apply/funext => x; rewrite hl_//; exact/measurable_ysection. +apply: ge0_emeasurable_fun_sum => // m. +by apply: measurable_fun_ysection_finite_kernel => // /[!inE]. +Qed. + +End measurable_fun_integral_finite_sfinite. + +Arguments measurable_fun_ysection_integral {_ _ _ _ _} k l. +Arguments measurable_fun_integral_finite_kernel {_ _ _ _ _} k l. +Arguments measurable_fun_integral_sfinite_kernel {_ _ _ _ _} k l. + +Section kcomp_finite_kernel_kernel. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variables (l : R.-fker X ~> Y) + (k : R.-ker [the measurableType _ of (Y * X)%type] ~> Z). + +Lemma measurable_fun_kcomp_finite U : + measurable U -> measurable_fun setT ((l \; k) ^~ U). +Proof. +move=> mU; apply: (measurable_fun_integral_finite_kernel (k ^~ U)) => //. +exact/measurable_kernel. +Qed. + +HB.instance Definition _ := + isKernel.Build _ _ X Z R (l \; k) measurable_fun_kcomp_finite. + +End kcomp_finite_kernel_kernel. + +Section kcomp_finite_kernel_finite. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : R.-fker X ~> Y. +Variable k : R.-fker [the measurableType _ of (Y * X)%type] ~> Z. + +Import Order.TTheory. + +Let mkcomp_finite : measure_fam_uub (l \; k). +Proof. +have /measure_fam_uubP[r hr] := measure_uub k. +have /measure_fam_uubP[s hs] := measure_uub l. +apply/measure_fam_uubP; exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x /=. +apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). + apply: ge0_le_integral => //. + - have /measurable_fun_prod2 := measurable_kernel k _ measurableT. + exact. + - exact/measurable_fun_cst. + - by move=> y _; exact/ltW/hr. +by rewrite integral_cst//= EFinM lte_pmul2l. +Qed. + +HB.instance Definition _ := + Kernel_isFinite.Build _ _ X Z R (l \; k) mkcomp_finite. + +End kcomp_finite_kernel_finite. +End KCOMP_FINITE_KERNEL. + +Section kcomp_sfinite_kernel. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : R.-sfker X ~> Y. +Variable k : R.-sfker [the measurableType _ of (Y * X)%type] ~> Z. + +Import KCOMP_FINITE_KERNEL. + +Lemma mkcomp_sfinite : exists k_ : (R.-fker X ~> Z)^nat, forall x U, measurable U -> + (l \; k) x U = kseries k_ x U. +Proof. +have [k_ hk_] := sfinite k; have [l_ hl_] := sfinite l. +have [kl hkl] : exists kl : (R.-fker X ~> Z) ^nat, forall x U, + \esum_(i in setT) (l_ i.2 \; k_ i.1) x U = \sum_(i [the _.-fker _ ~> _ of l_ (f i).2 \; k_ (f i).1]) => x U. + by rewrite (reindex_esum [set: nat] _ f)// nneseries_esum// fun_true. +exists kl => x U mU. +transitivity (([the _.-ker _ ~> _ of kseries l_] \; + [the _.-ker _ ~> _ of kseries k_]) x U). + rewrite /= /kcomp' [in RHS](eq_measure_integral (l x)); last first. + by move=> *; rewrite hl_. + by apply: eq_integral => y _; rewrite hk_. +rewrite /= /kcomp'/= integral_nneseries//=; last first. + by move=> n; have /measurable_fun_prod2 := measurable_kernel (k_ n) _ mU; exact. +transitivity (\sum_(i i _; rewrite integral_kseries//. + by have /measurable_fun_prod2 := measurable_kernel (k_ i) _ mU; exact. +rewrite /mseries -hkl/=. +rewrite (_ : setT = setT `*`` (fun=> setT)); last by apply/seteqP; split. +rewrite -(@esum_esum _ _ _ _ _ (fun i j => (l_ j \; k_ i) x U))//. +rewrite nneseries_esum; last by move=> n _; exact: nneseries_ge0. +by rewrite fun_true; apply: eq_esum => /= i _; rewrite nneseries_esum// fun_true. +Qed. + +Lemma measurable_fun_mkcomp_sfinite U : measurable U -> + measurable_fun setT ((l \; k) ^~ U). +Proof. +move=> mU; apply: (measurable_fun_integral_sfinite_kernel (k ^~ U)) => //. +exact/measurable_kernel. +Qed. + +End kcomp_sfinite_kernel. + +Module KCOMP_SFINITE_KERNEL. + +Section kcomp_sfinite_kernel. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : R.-sfker X ~> Y. +Variable k : R.-sfker [the measurableType _ of (Y * X)%type] ~> Z. + +HB.instance Definition _ := + isKernel.Build _ _ X Z R (l \; k) (measurable_fun_mkcomp_sfinite l k). + +#[export] +HB.instance Definition _ := + Kernel_isSFinite.Build _ _ X Z R (l \; k) (mkcomp_sfinite l k). + +End kcomp_sfinite_kernel. +End KCOMP_SFINITE_KERNEL. +HB.export KCOMP_SFINITE_KERNEL. + +(* TODO: move to kernel.v *) + +Section letin'. +Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Definition letin' (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType (d', d).-prod of (Y * X)%type] ~> Z) := + locked [the R.-sfker X ~> Z of l \; k]. + +Lemma letin'E (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType (d', d).-prod of (Y * X)%type] ~> Z) x U : + letin' l k x U = \int[l x]_y k (y, x) U. +Proof. by rewrite /letin'; unlock. Qed. + +End letin'. + +Section letin'C. +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 (Y * Z)%type] ~> X) + (tt' : forall y, t =1 fun z => t' (y, z)) + (u : R.-sfker Z ~> Y) + (u' : R.-sfker [the measurableType _ of (X * Z)%type] ~> Y) + (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 _ R X (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 := @Measure_isSFinite_subdef.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 _ R Y (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 := @Measure_isSFinite_subdef.Build _ Y R + (U' z) (sfinU z). + +Lemma letin'C z A : measurable A -> + letin' t + (letin' u' + (ret (measurable_fun_pair var2of3' var1of3'))) z A = + letin' u + (letin' t' + (ret (measurable_fun_pair var1of3' var2of3'))) z A. +Proof. +move=> mA. +rewrite !letin'E. +under eq_integral. + move=> x _. + rewrite letin'E -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 letin'E/= -tt'; apply: eq_integral => // x _; rewrite retE. +Qed. + +End letin'C. \ No newline at end of file diff --git a/theories/sample.v b/theories/sample.v new file mode 100644 index 0000000000..a01ad27fa9 --- /dev/null +++ b/theories/sample.v @@ -0,0 +1,59 @@ + +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval finmap. +Require Import reals ereal classical_sets numfun. +Require Import measure kernel lebesgue_integral signed. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope classical_set_scope. +Local Open Scope ring_scope. +Local Open Scope ereal_scope. + +Section sample. +Variables (R : realType) (d : measure_display) (T : measurableType d). + +Lemma __ : true \in [set true]. +rewrite inE //. +Qed. + +Lemma _k x (s : set T) : kernel_from_dirac x s = dirac x s :> \bar R. +Proof. by []. Qed. + +Check kernel_from_dirac : T -> measure R T. (* T ^^> T *) + +Lemma _k1 : kernel_from_dirac true [set true] = 1 :> \bar R. +Proof. rewrite /= diracE __ //. Qed. + +Lemma _k2 : kernel_from_dirac false [set: bool] = 1 :> \bar R. +Proof. rewrite /= diracE in_setT //. Qed. + +(* bernoulli *) +Check bernoulli27 R : measure _ _. +Check sample_bernoulli27 R : kernel R _ _. + +Lemma _k3 : sample_bernoulli27 R tt set0 = 0. +Proof. by rewrite measure0. Qed. + +Lemma _k4 (s : set bool) : sample_bernoulli27 R tt s = bernoulli27 R s. +Proof. by []. Qed. + +(* star *) +Check Return R : kernel R _ _. + +Lemma _s (b : bool) : + star (Return R) (sample_bernoulli27 R) tt [set (tt, b)] = + bernoulli27 R [set b]. +Proof. +rewrite /star /=. +rewrite ge0_integral_measure_sum// 2!big_ord_recl/= big_ord0 adde0/=. +rewrite !ge0_integral_mscale//=. +rewrite !integral_dirac//=. +rewrite 2!indicE 2!in_setT 2!mul1e. +rewrite /msum 2!big_ord_recl/= big_ord0 adde0/= /mscale /=. +admit. +Abort. + + +End sample. diff --git a/theories/semantics.v b/theories/semantics.v new file mode 100644 index 0000000000..a3ab19e3ae --- /dev/null +++ b/theories/semantics.v @@ -0,0 +1,89 @@ +From HB Require Import structures. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval finmap. +Require Import mathcomp_extra boolp classical_sets signed functions cardinality. +Require Import reals ereal topology normedtype sequences esum measure. +Require Import lebesgue_measure fsbigop numfun lebesgue_integral kernel. + + +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. + +Definition onem (R : numDomainType) (p : R) := (1 - p)%R. + +Lemma onem1 (R : numDomainType) (p : R) : (p + onem p = 1)%R. +Proof. by rewrite /onem addrCA subrr addr0. Qed. + +Lemma onem_nonneg_proof (R : numDomainType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R) : + (0 <= onem p%:num)%R. +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). + +Section bernoulli. +Variables (R : realType) (p : {nonneg R}) (p1 : (p%:num <= 1)%R). +Local Open Scope ring_scope. + +Definition bernoulli : set _ -> \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]]. + +HB.instance Definition _ := Measure.on bernoulli. + +Example bernoulli_set0 : bernoulli set0 = 0%:E. +Proof. by []. Qed. +Example bernoulli_setT : bernoulli setT = 1%:E. +Proof. +rewrite /bernoulli/= /measure_add/= /msum 2!big_ord_recr/= big_ord0 add0e/=. +by rewrite /mscale/= !diracE !in_setT !mule1 -EFinD onem1. +Qed. + +HB.instance Definition _ := @isProbability.Build _ _ R bernoulli bernoulli_setT. + +End bernoulli. + +Section score. +Variables (R : realType) (d : _) (T : measurableType d). +Variables (r : T -> R). + +Definition score (t : T) (U : set unit) : \bar R := + if U == set0 then 0 else `| (r t)%:E |. + +Let score0 t : score t (set0 : set unit) = 0 :> \bar R. +Proof. by rewrite /score eqxx. Qed. + +Let score_ge0 t U : 0 <= score t U. +Proof. by rewrite /score; case: ifP. Qed. + +Let score_sigma_additive t : semi_sigma_additive (score t). +Proof. +move=> /= F mF tF mUF; rewrite /score; case: ifPn => [/eqP/bigcup0P F0|]. + rewrite (_ : (fun _ => _) = cst 0); first exact: cvg_cst. + apply/funext => k. + under eq_bigr do rewrite F0// eqxx. + by rewrite big1. +move=> /eqP/bigcup0P/existsNP[k /not_implyP[_ /eqP Fk0]]. +rewrite -(cvg_shiftn k.+1)/=. +rewrite (_ : (fun _ => _) = cst `|(r t)%:E|); first exact: cvg_cst. +apply/funext => n. +rewrite big_mkord (bigD1 (widen_ord (leq_addl n _) (Ordinal (ltnSn k))))//=. +rewrite (negbTE Fk0) big1 ?adde0// => i/= ik; rewrite ifT//. +have [/eqP//|Fitt] := set_unit (F i). +move/trivIsetP : tF => /(_ i k Logic.I Logic.I ik). +by rewrite Fitt setTI => /eqP; rewrite (negbTE Fk0). +Qed. + +HB.instance Definition _ (t : T) := isMeasure.Build _ _ _ + (score t) (score0 t) (score_ge0 t) (@score_sigma_additive t). + +Definition k_ (i : nat) + +End score. \ No newline at end of file diff --git a/theories/wip.v b/theories/wip.v index 897d70c886..a2820ea8f8 100644 --- a/theories/wip.v +++ b/theories/wip.v @@ -122,7 +122,7 @@ Qed. Variable mu : {measure set mR R -> \bar R}. Definition staton_lebesgue : R.-sfker T ~> _ := - letin (sample (@gauss01 R)) + letin (sample (@gauss01 R : pprobability _ _)) (letin (score (measurable_funT_comp mf1 var2of2)) (ret var2of3)). From 9f3692c2621dd06b7fc3955365f9a362c1140540 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Mon, 20 Mar 2023 18:19:15 +0900 Subject: [PATCH 38/54] prove measurable_fun_normalize --- theories/kernel.v | 8 +-- theories/lang_syntax.v | 127 ++++++++++++++++++++++------------------- 2 files changed, 73 insertions(+), 62 deletions(-) diff --git a/theories/kernel.v b/theories/kernel.v index bea2d42001..80c2a1cf35 100644 --- a/theories/kernel.v +++ b/theories/kernel.v @@ -782,10 +782,10 @@ Section mnormalize. Context d d' (X : measurableType d) (Y : measurableType d') (R : realType). Variables (f : X -> {measure set Y -> \bar R}) (P : probability Y R). -Definition mnormalize x U := +Definition mnormalize x := let evidence := f x [set: Y] in - if (evidence == 0) || (evidence == +oo) then P U - else f x U * (fine evidence)^-1%:E. + if (evidence == 0) || (evidence == +oo) then fun U => P U + else fun U => f x U * (fine evidence)^-1%:E. Let mnormalize0 x : mnormalize x set0 = 0. Proof. @@ -1183,4 +1183,4 @@ apply: eq_integral => y _; rewrite -monotone_convergence//; last 3 first. by apply: eq_integral => z _; apply/cvg_lim => //; exact: f_f. Qed. -End integral_kcomp. \ No newline at end of file +End integral_kcomp. diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index 9b396aadf1..6bf933781d 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -164,57 +164,68 @@ apply: (measurable_funT_comp (IHl _ _) (@measurable_fun_snd _ _ _ _)). apply: K. Qed. -Lemma measurable_fun_normalize d d' (X : measurableType d) (Y : measurableType d') (k : R.-sfker X ~> Y) : - measurable_fun setT (normalize k point : X -> pprobability Y R). +Lemma eq_probability d (Y : measurableType d) (m1 m2 : probability Y R) : + (m1 = m2 :> (set Y -> \bar R)) -> m1 = m2. Proof. -(* have := measurable_kernel k set0 measurable0. -rewrite /normalize /mnormalize. -(* rewrite [X in measurable_fun X](_ : _ = (fun x : X => - if (k x [set: Y] == 0) || (k x [set: Y] == +oo) - then fun U : set Y =>point U - else fun U : set Y => k x U * ((fine (k x [set: Y]))^-1)%:E)); last first. *) -suff: measurable_fun (T:=X) (U:=pprobability Y R) [set: X] - (fun x : X => - fun U : set Y => - if (k x [set: Y] == 0) || (k x [set: Y] == +oo) - then point U - else k x U * ((fine (k x [set: Y]))^-1)%:E). -have:= (@measurable_fun_if _ _ _ _ (fun x => _) (fun x U => k x U * ((fine (k x [set: Y]))^-1)%:E) (fun x => (k x [set: Y] == 0) || (k x [set: Y] == +oo))). -(* move=> mX U mU. -rewrite setTI. *) -apply: measurability. -reflexivity. -move=> B [Z [r r01]] [Z0 mZ0 <-{Z}] <-{B}. -rewrite /normalize. -rewrite /mnormalize. -rewrite setTI. -rewrite /mset /preimage /= /mnormalize. -rewrite [X in measurable X](_ : _ = (fun x : X => - if (k x [set: Y] == 0) || (k x [set: Y] == +oo) - then fun U : set Y =>point U - else fun U : set Y => k x U * ((fine (k x [set: Y]))^-1)%:E) @^-1` - [set mu | mu Z0 < r%:E]); last first. - apply/funext => x/=. - rewrite /mset/= /mnormalize. - case: ifP => //= ?. - rewrite diracE. - case: (point \in Z0) => /=. - admit. - apply: measurable_fun_if. - reflexivity. - done. -simpl. -rewe -move=> _ B. -rewrite /pset/= => hB. - => _ /= -[_ [r ->] <-]. -(* apply: (measurability (ErealGenInftyO.measurableE R)). *) -apply: measurability => //. -apply: measurableI => //. -apply: measurable_fun_knormalize. -have := measurable_kernel [the kernel _ _ _ of (normalize k : X -> pprobability Y R)]. -rewrite preimage. *) -Admitted. +move: m1 m2 => [m1 +] [m2 +] /= m1m2. +rewrite -{}m1m2 => -[[c11 c12] [m01] [sf1] [sig1] [fin1] [sub1] [p1]] + [[c21 c22] [m02] [sf2] [sig2] [fin2] [sub2] [p2]]. +have ? : c11 = c21 by exact: Prop_irrelevance. +subst c21. +have ? : c12 = c22 by exact: Prop_irrelevance. +subst c22. +have ? : m01 = m02 by exact: Prop_irrelevance. +subst m02. +have ? : sf1 = sf2 by exact: Prop_irrelevance. +subst sf2. +have ? : sig1 = sig2 by exact: Prop_irrelevance. +subst sig2. +have ? : fin1 = fin2 by exact: Prop_irrelevance. +subst fin2. +have ? : sub1 = sub2 by exact: Prop_irrelevance. +subst sub2. +have ? : p1 = p2 by exact: Prop_irrelevance. +subst p2. +by f_equal. +Qed. + +Section measurable_fun_normalize. +Context d d' (X : measurableType d) (Y : measurableType d'). +Variable k : R.-sfker X ~> Y. + +Lemma measurable_fun_normalize : + measurable_fun setT (fun x => normalize k point x : pprobability Y R). +Proof. +apply: (@measurability _ _ _ _ _ _ + (@pset _ _ _ : set (set (pprobability Y R)))) => //. +move=> _ -[_ [r r01] [Ys mYs <-]] <-. +rewrite /normalize /mnormalize /mset /preimage/=. +apply: emeasurable_fun_infty_o => //. +rewrite /mnormalize/=. +rewrite (_ : (fun x => _) = (fun x => if (k x setT == 0) || (k x setT == +oo) + then \d_point Ys else k x Ys * ((fine (k x setT))^-1)%:E)); last first. + by apply/funext => x/=; case: ifPn. +apply: measurable_fun_if => //. +- apply: (measurable_fun_bool true) => //. + rewrite (_ : _ @^-1` _ = [set t | k t setT == 0] `|` + [set t | k t setT == +oo]); last first. + by apply/seteqP; split=> x /= /orP//. + by apply: measurableU; [exact: measurable_eq_cst|exact: measurable_eq_cst]. +- exact: measurable_fun_cst. +- apply/emeasurable_funM. + by apply: (@measurable_funS _ _ _ _ setT) => //; exact/measurable_kernel. + apply/EFin_measurable_fun; rewrite setTI. + apply: (@measurable_fun_comp _ _ _ _ _ _ [set r : R | r != 0%R]). + + exact: open_measurable. + + by move=> /= _ [x /norP[s0 soo]] <-; rewrite -eqe fineK ?ge0_fin_numE ?ltey. + + apply: open_continuous_measurable_fun => //; apply/in_setP => x /= x0. + exact: inv_continuous. + + apply: (@measurable_fun_comp _ _ _ _ _ _ setT) => //. + exact: measurable_fun_fine. + by apply: (@measurable_funS _ _ _ _ setT) => //; exact: measurable_kernel. +Qed. + +End measurable_fun_normalize. (* Fixpoint denoteType (t : stype) (e : @expD t) := match e with @@ -983,9 +994,9 @@ pose vy : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := exec have -> : v1 = letin' (vx) (letin' (vy) (ret (measurable_fun_pair var2of3' var1of3'))). apply: (evalP_uniq ev1). apply/E_letin /E_letin. -rewrite /vx /execP_cst /ssr_have /sval/=. +rewrite /vx /execP_cst/= /sval/=. by case: cid => // ? h. -rewrite /vy /execP_cst /ssr_have /sval/=. +rewrite /vy /execP_cst /sval/=. by case: cid => // ? h. apply/E_return /E_pair. have -> : (var2of3' = (@mvarof R [:: (y, sreal); (x, sreal)] 1 (false_index_size (_ : (x \in map fst [:: (y, sreal); (x, sreal)]))))) by []. @@ -997,9 +1008,9 @@ pose vx' : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := have -> : v2 = letin' (vy') (letin' (vx') (ret (measurable_fun_pair var1of3' var2of3'))). apply: (evalP_uniq ev2). apply/E_letin /E_letin. -rewrite /vy' /execP_cst /ssr_have /sval/=. +rewrite /vy' /execP_cst /sval/=. case: cid => //. -rewrite /vx' /execP_cst /ssr_have /sval/=. +rewrite /vx' /execP_cst /sval/=. case: cid => //. apply/E_return /E_pair. have -> : (var1of3' = (@mvarof R [:: (x, sreal); (y, sreal)] 0 (false_index_size (_ : (x \in map fst [:: (x, sreal); (y, sreal)]))))) by []. @@ -1009,13 +1020,13 @@ apply/(@E_var R [:: (x, sreal); (y, sreal)] y is_true_true). apply: letin'C; last by []. move=> x0 t0. rewrite (@evalP_uni_new y 1 vx vx'); last 2 first. - rewrite /vx /execP_cst /ssr_have /sval/=. + rewrite /vx /execP_cst /sval/=. by case: cid. - rewrite /vx' /execP_cst /ssr_have /sval/=. + rewrite /vx' /execP_cst /sval/=. by case: cid. by done. move=> x0 t0. - rewrite /vy /vy' /execP_cst /ssr_have /sval/=. + rewrite /vy /vy' /execP_cst /sval/=. case: cid => sy. case: cid => sy'. move=> er1 er2. @@ -1090,4 +1101,4 @@ have -> : (var3of4' = (@mvarof R [:: ("_", sunit); ("r", sreal); ("x", sbool)] 2 exact: (@E_var R [:: ("_", sunit); ("r", sreal); ("x", sbool)] "x"). Qed. -End example. \ No newline at end of file +End example. From 68122ad0a044c175217208f0599d61ec3984589c Mon Sep 17 00:00:00 2001 From: AyumuSaito Date: Mon, 27 Mar 2023 16:44:01 +0900 Subject: [PATCH 39/54] mkswap (wip) --- theories/prob_lang.v | 279 +++++++++++++++---------------------------- 1 file changed, 95 insertions(+), 184 deletions(-) diff --git a/theories/prob_lang.v b/theories/prob_lang.v index b1cdf777c9..cd1e3dcbf8 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -1026,229 +1026,96 @@ Notation var2of4' := (measurable_funT_comp (@measurable_fun_fst _ _ _ _) (@measu Notation var3of4' := (measurable_funT_comp (@measurable_fun_fst _ _ _ _) (measurable_funT_comp (@measurable_fun_snd _ _ _ _) (@measurable_fun_snd _ _ _ _))). Notation var4of4' := (measurable_funT_comp (@measurable_fun_fst _ _ _ _) (measurable_funT_comp (@measurable_fun_snd _ _ _ _) (measurable_funT_comp (@measurable_fun_snd _ _ _ _) (@measurable_fun_snd _ _ _ _)))). -Section kcomp'_def. +Section mswap. Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType). -Variable l : X -> {measure set Y -> \bar R}. -Variable k : (Y * X)%type -> {measure set Z -> \bar R}. +Variable k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z. -Definition kcomp' x U := \int[l x]_y k (y, x) U. +Definition mswap xy U := k (swap xy) U. -End kcomp'_def. +Let mswap0 xy : mswap xy set0 = 0. +Proof. done. Qed. -Section kcomp_is_measure. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). -Variable l : R.-ker X ~> Y. -Variable k : R.-ker [the measurableType _ of (Y * X)%type] ~> Z. - -Local Notation "l \; k" := (kcomp' l k). - -Let kcomp0 x : (l \; k) x set0 = 0. -Proof. -by rewrite /kcomp' (eq_integral (cst 0)) ?integral0// => y _; rewrite measure0. -Qed. - -Let kcomp_ge0 x U : 0 <= (l \; k) x U. Proof. exact: integral_ge0. Qed. +Let mswap_ge0 x U : 0 <= mswap x U. +Proof. done. Qed. -Let kcomp_sigma_additive x : semi_sigma_additive ((l \; k) x). -Proof. -move=> U mU tU mUU; rewrite [X in _ --> X](_ : _ = - \int[l x]_y (\sum_(n V _. - by apply/esym/cvg_lim => //; exact/measure_semi_sigma_additive. -apply/cvg_closeP; split. - by apply: is_cvg_nneseries => n _; exact: integral_ge0. -rewrite closeE // integral_nneseries// => n. -by have /measurable_fun_prod2 := measurable_kernel k _ (mU n). -Qed. +Let mswap_sigma_additive x : semi_sigma_additive (mswap x). +Proof. exact: measure_semi_sigma_additive. Qed. HB.instance Definition _ x := isMeasure.Build _ R _ - ((l \; k) x) (kcomp0 x) (kcomp_ge0 x) (@kcomp_sigma_additive x). - -Definition mkcomp' : X -> {measure set Z -> \bar R} := - fun x => [the measure _ _ of (l \; k) x]. - -End kcomp_is_measure. - -Notation "l \; k" := (mkcomp' l k) : ereal_scope. + (mswap x) (mswap0 x) (mswap_ge0 x) (@mswap_sigma_additive x). -Module KCOMP_FINITE_KERNEL. +Definition mkswap : _ -> {measure set Z -> \bar R} := + fun x => [the measure _ _ of mswap x]. -Section measurable_fun_xsection_finite_kernel. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d') - (R : realType). -Variables (k : R.-fker X ~> Y). -Implicit Types A : set (Y * X). - -Let phi A := fun x => k x (ysection A x). -Let XY := [set A | measurable A /\ measurable_fun setT (phi A)]. - -Lemma measurable_fun_ysection_finite_kernel A : - A \in measurable -> measurable_fun setT (phi A). -Admitted. - -End measurable_fun_xsection_finite_kernel. - -Section measurable_fun_integral_finite_sfinite. -Variables (d d' : _) (X : measurableType d) (Y : measurableType d') - (R : realType). -Variable k : Y * X -> \bar R. - -Lemma measurable_fun_ysection_integral - (l : X -> {measure set Y -> \bar R}) - (k_ : ({nnsfun [the measurableType _ of (Y * X)%type] >-> R})^nat) - (ndk_ : nondecreasing_seq (k_ : (Y * X -> R)^nat)) - (k_k : forall z, EFin \o (k_ ^~ z) --> k z) : - (forall n r, measurable_fun setT (fun x => l x (ysection (k_ n @^-1` [set r]) x))) -> - measurable_fun setT (fun x => \int[l x]_y k (y, x)). -Admitted. - -Lemma measurable_fun_integral_finite_kernel (l : R.-fker X ~> Y) - (k0 : forall z, 0 <= k z) (mk : measurable_fun setT k) : - measurable_fun setT (fun x => \int[l x]_y k (y, x)). -Proof. -have [k_ [ndk_ k_k]] := approximation measurableT mk (fun x _ => k0 x). -apply: (measurable_fun_ysection_integral ndk_ (k_k ^~ Logic.I)) => n r. -have [l_ hl_] := measure_uub l. -by apply: measurable_fun_ysection_finite_kernel => // /[!inE]. -Qed. - -Lemma measurable_fun_integral_sfinite_kernel (l : R.-sfker X ~> Y) - (k0 : forall t, 0 <= k t) (mk : measurable_fun setT k) : - measurable_fun setT (fun x => \int[l x]_y k (y, x)). +Let measurable_fun_kswap U : + measurable U -> measurable_fun setT (mkswap ^~ U). Proof. -have [k_ [ndk_ k_k]] := approximation measurableT mk (fun xy _ => k0 xy). -apply: (measurable_fun_ysection_integral ndk_ (k_k ^~ Logic.I)) => n r. -have [l_ hl_] := sfinite l. -rewrite (_ : (fun x => _) = - (fun x => mseries (l_ ^~ x) 0 (ysection (k_ n @^-1` [set r]) x))); last first. - by apply/funext => x; rewrite hl_//; exact/measurable_ysection. -apply: ge0_emeasurable_fun_sum => // m. -by apply: measurable_fun_ysection_finite_kernel => // /[!inE]. -Qed. - -End measurable_fun_integral_finite_sfinite. - -Arguments measurable_fun_ysection_integral {_ _ _ _ _} k l. -Arguments measurable_fun_integral_finite_kernel {_ _ _ _ _} k l. -Arguments measurable_fun_integral_sfinite_kernel {_ _ _ _ _} k l. - -Section kcomp_finite_kernel_kernel. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). -Variables (l : R.-fker X ~> Y) - (k : R.-ker [the measurableType _ of (Y * X)%type] ~> Z). - -Lemma measurable_fun_kcomp_finite U : - measurable U -> measurable_fun setT ((l \; k) ^~ U). -Proof. -move=> mU; apply: (measurable_fun_integral_finite_kernel (k ^~ U)) => //. -exact/measurable_kernel. +move=> mU. +rewrite [X in measurable_fun _ X](_ : _ = ((fun xy => k xy U) \o (@swap _ _)))//. +apply measurable_funT_comp. + exact/measurable_kernel. +exact: measurable_fun_swap. Qed. HB.instance Definition _ := - isKernel.Build _ _ X Z R (l \; k) measurable_fun_kcomp_finite. + isKernel.Build _ _ [the measurableType _ of (Y * X)%type] Z R mkswap measurable_fun_kswap. -End kcomp_finite_kernel_kernel. +End mswap. -Section kcomp_finite_kernel_finite. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). -Variable l : R.-fker X ~> Y. -Variable k : R.-fker [the measurableType _ of (Y * X)%type] ~> Z. +(* Module KSWAP_FINITE_KERNEL. *) -Import Order.TTheory. +Section kswap_finite_kernel_finite. +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) + (k : R.-fker [the measurableType _ of (Y * X)%type] ~> Z). -Let mkcomp_finite : measure_fam_uub (l \; k). +Let mkswap_finite : measure_fam_uub (mkswap k). Proof. have /measure_fam_uubP[r hr] := measure_uub k. -have /measure_fam_uubP[s hs] := measure_uub l. -apply/measure_fam_uubP; exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x /=. -apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). - apply: ge0_le_integral => //. - - have /measurable_fun_prod2 := measurable_kernel k _ measurableT. - exact. - - exact/measurable_fun_cst. - - by move=> y _; exact/ltW/hr. -by rewrite integral_cst//= EFinM lte_pmul2l. +apply/measure_fam_uubP; exists (PosNum [gt0 of r%:num%R]) => x /=. +exact: hr. Qed. HB.instance Definition _ := - Kernel_isFinite.Build _ _ X Z R (l \; k) mkcomp_finite. + Kernel_isFinite.Build _ _ _ Z R (mkswap k) mkswap_finite. -End kcomp_finite_kernel_finite. -End KCOMP_FINITE_KERNEL. +End kswap_finite_kernel_finite. +(* End KSWAP_FINITE_KERNEL. *) -Section kcomp_sfinite_kernel. +(* Module MSWAP_SFINITE_KERNEL. *) +Section mswap_sfinite_kernel. Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType). -Variable l : R.-sfker X ~> Y. Variable k : R.-sfker [the measurableType _ of (Y * X)%type] ~> Z. -Import KCOMP_FINITE_KERNEL. +(* Import KSWAP_FINITE_KERNEL. *) -Lemma mkcomp_sfinite : exists k_ : (R.-fker X ~> Z)^nat, forall x U, measurable U -> - (l \; k) x U = kseries k_ x U. +Let mkswap_sfinite : + exists k_ : (R.-fker [the measurableType _ of (X * Y)%type] ~> Z)^nat, + forall x U, measurable U -> mkswap k x U = kseries k_ x U. Proof. -have [k_ hk_] := sfinite k; have [l_ hl_] := sfinite l. -have [kl hkl] : exists kl : (R.-fker X ~> Z) ^nat, forall x U, - \esum_(i in setT) (l_ i.2 \; k_ i.1) x U = \sum_(i [the _.-fker _ ~> _ of l_ (f i).2 \; k_ (f i).1]) => x U. - by rewrite (reindex_esum [set: nat] _ f)// nneseries_esum// fun_true. -exists kl => x U mU. -transitivity (([the _.-ker _ ~> _ of kseries l_] \; - [the _.-ker _ ~> _ of kseries k_]) x U). - rewrite /= /kcomp' [in RHS](eq_measure_integral (l x)); last first. - by move=> *; rewrite hl_. - by apply: eq_integral => y _; rewrite hk_. -rewrite /= /kcomp'/= integral_nneseries//=; last first. - by move=> n; have /measurable_fun_prod2 := measurable_kernel (k_ n) _ mU; exact. -transitivity (\sum_(i i _; rewrite integral_kseries//. - by have /measurable_fun_prod2 := measurable_kernel (k_ i) _ mU; exact. -rewrite /mseries -hkl/=. -rewrite (_ : setT = setT `*`` (fun=> setT)); last by apply/seteqP; split. -rewrite -(@esum_esum _ _ _ _ _ (fun i j => (l_ j \; k_ i) x U))//. -rewrite nneseries_esum; last by move=> n _; exact: nneseries_ge0. -by rewrite fun_true; apply: eq_esum => /= i _; rewrite nneseries_esum// fun_true. +have [k_ /= kE] := sfinite k. +exists (fun n => mkswap (k_ n)). +move=> xy U mU. +by rewrite /mswap/= kE. Qed. -Lemma measurable_fun_mkcomp_sfinite U : measurable U -> - measurable_fun setT ((l \; k) ^~ U). -Proof. -move=> mU; apply: (measurable_fun_integral_sfinite_kernel (k ^~ U)) => //. -exact/measurable_kernel. -Qed. - -End kcomp_sfinite_kernel. - -Module KCOMP_SFINITE_KERNEL. - -Section kcomp_sfinite_kernel. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). -Variable l : R.-sfker X ~> Y. -Variable k : R.-sfker [the measurableType _ of (Y * X)%type] ~> Z. - -HB.instance Definition _ := - isKernel.Build _ _ X Z R (l \; k) (measurable_fun_mkcomp_sfinite l k). - -#[export] HB.instance Definition _ := - Kernel_isSFinite.Build _ _ X Z R (l \; k) (mkcomp_sfinite l k). + Kernel_isSFinite.Build _ _ _ Z R (mkswap k) mkswap_sfinite. +End mswap_sfinite_kernel. -End kcomp_sfinite_kernel. -End KCOMP_SFINITE_KERNEL. -HB.export KCOMP_SFINITE_KERNEL. +Notation "l \; k" := (mkcomp l (mkswap k)) : ereal_scope. (* TODO: move to kernel.v *) Section letin'. Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). + (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) + (k : R.-sfker [the measurableType (d', d).-prod of (Y * X)%type] ~> Z). + +Check [the R.-sfker X ~> Z of l \; k]. + Definition letin' (l : R.-sfker X ~> Y) (k : R.-sfker [the measurableType (d', d).-prod of (Y * X)%type] ~> Z) := locked [the R.-sfker X ~> Z of l \; k]. @@ -1323,4 +1190,48 @@ apply: eq_integral => y _. by rewrite letin'E/= -tt'; apply: eq_integral => // x _; rewrite retE. Qed. -End letin'C. \ No newline at end of file +End letin'C. + + +Module KCOMP_SWAP_FINITE_KERNEL. + +Section kcomp_swap_finite_kernel_kernel. +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType) (l : R.-fker X ~> Y) + (k : R.-ker [the measurableType _ of (Y * X)%type] ~> Z). + +Lemma measurable_fun_kcomp_finite U : + measurable U -> measurable_fun setT ((l \; k) ^~ U). +Proof. +Admitted. + +HB.instance Definition _ := + isKernel.Build _ _ X Z R (l \; k) measurable_fun_kcomp_finite. + +End kcomp_swap_finite_kernel_kernel. + +Section kcomp_finite_kernel_finite. +Context d d' d3 (X : measurableType d) (Y : measurableType d') + (Z : measurableType d3) (R : realType). +Variable l : R.-fker X ~> Y. +Variable k : R.-fker [the measurableType _ of (Y * X)%type] ~> Z. + +Let mkcomp_swap_finite : measure_fam_uub (l \; k). +Proof. +have /measure_fam_uubP[r hr] := measure_uub k. +have /measure_fam_uubP[s hs] := measure_uub l. +apply/measure_fam_uubP; exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x /=. +apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). + apply: ge0_le_integral => //. + - have /measurable_fun_prod1 := measurable_kernel k _ measurableT. + (* exact. + - exact/measurable_fun_cst. + - by move=> y _; exact/ltW/hr. +by rewrite integral_cst//= EFinM lte_pmul2l. *) +Admitted. + +HB.instance Definition _ := + Kernel_isFinite.Build _ _ _ Z R (l \; k) mkcomp_swap_finite. + +End kcomp_finite_kernel_finite. +End KCOMP_FINITE_KERNEL. From b75c39662cc646cf17964120e6141644c82db74c Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Mon, 27 Mar 2023 17:19:39 +0900 Subject: [PATCH 40/54] fix --- theories/prob_lang.v | 52 ++++++++++++++++++++++++-------------------- 1 file changed, 28 insertions(+), 24 deletions(-) diff --git a/theories/prob_lang.v b/theories/prob_lang.v index cd1e3dcbf8..7cc3d62044 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -1063,12 +1063,38 @@ HB.instance Definition _ := 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 [the measurableType _ of (X * Y)%type] ~> Z. + +(* Import KSWAP_FINITE_KERNEL. *) + +Let mkswap_sfinite : + exists2 k_ : (R.-ker [the measurableType _ of (Y * X)%type] ~> Z)^nat, + forall n, measure_fam_uub (k_ n) & + forall x U, measurable U -> mkswap k x U = kseries k_ x U. +Proof. +have [k_ /= kE] := sfinite 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. + +HB.instance Definition _ := + Kernel_isSFinite_subdef.Build _ _ _ Z R (mkswap k) mkswap_sfinite. + +End mswap_sfinite_kernel. + (* Module KSWAP_FINITE_KERNEL. *) Section kswap_finite_kernel_finite. Context d d' d3 (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType) - (k : R.-fker [the measurableType _ of (Y * X)%type] ~> Z). + (k : R.-fker [the measurableType _ of (X * Y)%type] ~> Z). Let mkswap_finite : measure_fam_uub (mkswap k). Proof. @@ -1084,26 +1110,6 @@ End kswap_finite_kernel_finite. (* End KSWAP_FINITE_KERNEL. *) (* Module MSWAP_SFINITE_KERNEL. *) -Section mswap_sfinite_kernel. -Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). -Variable k : R.-sfker [the measurableType _ of (Y * X)%type] ~> Z. - -(* Import KSWAP_FINITE_KERNEL. *) - -Let mkswap_sfinite : - exists k_ : (R.-fker [the measurableType _ of (X * Y)%type] ~> Z)^nat, - forall x U, measurable U -> mkswap k x U = kseries k_ x U. -Proof. -have [k_ /= kE] := sfinite k. -exists (fun n => mkswap (k_ n)). -move=> xy U mU. -by rewrite /mswap/= kE. -Qed. - -HB.instance Definition _ := - Kernel_isSFinite.Build _ _ _ Z R (mkswap k) mkswap_sfinite. -End mswap_sfinite_kernel. Notation "l \; k" := (mkcomp l (mkswap k)) : ereal_scope. @@ -1112,9 +1118,7 @@ Notation "l \; k" := (mkcomp l (mkswap k)) : ereal_scope. Section letin'. Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType (d', d).-prod of (Y * X)%type] ~> Z). - -Check [the R.-sfker X ~> Z of l \; k]. + (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z). Definition letin' (l : R.-sfker X ~> Y) (k : R.-sfker [the measurableType (d', d).-prod of (Y * X)%type] ~> Z) := From 15d4f97512a12b962f2cb862f3b026451bc24805 Mon Sep 17 00:00:00 2001 From: AyumuSaito Date: Mon, 3 Apr 2023 16:58:10 +0900 Subject: [PATCH 41/54] fix --- theories/prob_lang.v | 57 +++++--------------------------------------- 1 file changed, 6 insertions(+), 51 deletions(-) diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 7cc3d62044..6e888a7878 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -1029,7 +1029,7 @@ Notation var4of4' := (measurable_funT_comp (@measurable_fun_fst _ _ _ _) (measur Section mswap. Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType). -Variable k : R.-ker [the measurableType _ of (X * Y)%type] ~> Z. +Variable k : R.-ker [the measurableType _ of (Y * X)%type] ~> Z. Definition mswap xy U := k (swap xy) U. @@ -1059,19 +1059,19 @@ exact: measurable_fun_swap. Qed. HB.instance Definition _ := - isKernel.Build _ _ [the measurableType _ of (Y * X)%type] Z R mkswap measurable_fun_kswap. + isKernel.Build _ _ [the measurableType _ of (X * Y)%type] Z R mkswap measurable_fun_kswap. 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 [the measurableType _ of (X * Y)%type] ~> Z. +Variable k : R.-sfker [the measurableType _ of (Y * X)%type] ~> Z. (* Import KSWAP_FINITE_KERNEL. *) Let mkswap_sfinite : - exists2 k_ : (R.-ker [the measurableType _ of (Y * X)%type] ~> Z)^nat, + exists2 k_ : (R.-ker [the measurableType _ of (X * Y)%type] ~> Z)^nat, forall n, measure_fam_uub (k_ n) & forall x U, measurable U -> mkswap k x U = kseries k_ x U. Proof. @@ -1094,7 +1094,7 @@ End mswap_sfinite_kernel. Section kswap_finite_kernel_finite. Context d d' d3 (X : measurableType d) (Y : measurableType d') (Z : measurableType d3) (R : realType) - (k : R.-fker [the measurableType _ of (X * Y)%type] ~> Z). + (k : R.-fker [the measurableType _ of (Y * X)%type] ~> Z). Let mkswap_finite : measure_fam_uub (mkswap k). Proof. @@ -1117,8 +1117,7 @@ Notation "l \; k" := (mkcomp l (mkswap k)) : ereal_scope. Section letin'. Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) (l : R.-sfker X ~> Y) - (k : R.-sfker [the measurableType (d, d').-prod of (X * Y)%type] ~> Z). + (Z : measurableType d3) (R : realType). Definition letin' (l : R.-sfker X ~> Y) (k : R.-sfker [the measurableType (d', d).-prod of (Y * X)%type] ~> Z) := @@ -1195,47 +1194,3 @@ by rewrite letin'E/= -tt'; apply: eq_integral => // x _; rewrite retE. Qed. End letin'C. - - -Module KCOMP_SWAP_FINITE_KERNEL. - -Section kcomp_swap_finite_kernel_kernel. -Context d d' d3 (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType) (l : R.-fker X ~> Y) - (k : R.-ker [the measurableType _ of (Y * X)%type] ~> Z). - -Lemma measurable_fun_kcomp_finite U : - measurable U -> measurable_fun setT ((l \; k) ^~ U). -Proof. -Admitted. - -HB.instance Definition _ := - isKernel.Build _ _ X Z R (l \; k) measurable_fun_kcomp_finite. - -End kcomp_swap_finite_kernel_kernel. - -Section kcomp_finite_kernel_finite. -Context d d' d3 (X : measurableType d) (Y : measurableType d') - (Z : measurableType d3) (R : realType). -Variable l : R.-fker X ~> Y. -Variable k : R.-fker [the measurableType _ of (Y * X)%type] ~> Z. - -Let mkcomp_swap_finite : measure_fam_uub (l \; k). -Proof. -have /measure_fam_uubP[r hr] := measure_uub k. -have /measure_fam_uubP[s hs] := measure_uub l. -apply/measure_fam_uubP; exists (PosNum [gt0 of (r%:num * s%:num)%R]) => x /=. -apply: (@le_lt_trans _ _ (\int[l x]__ r%:num%:E)). - apply: ge0_le_integral => //. - - have /measurable_fun_prod1 := measurable_kernel k _ measurableT. - (* exact. - - exact/measurable_fun_cst. - - by move=> y _; exact/ltW/hr. -by rewrite integral_cst//= EFinM lte_pmul2l. *) -Admitted. - -HB.instance Definition _ := - Kernel_isFinite.Build _ _ _ Z R (l \; k) mkcomp_swap_finite. - -End kcomp_finite_kernel_finite. -End KCOMP_FINITE_KERNEL. From 85ac261fcce4437bf919a56ae410112159d9c98b Mon Sep 17 00:00:00 2001 From: AyumuSaito Date: Fri, 7 Apr 2023 10:43:49 +0900 Subject: [PATCH 42/54] test binomial --- theories/binomial.v | 75 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 75 insertions(+) create mode 100644 theories/binomial.v diff --git a/theories/binomial.v b/theories/binomial.v new file mode 100644 index 0000000000..dee4056d7c --- /dev/null +++ b/theories/binomial.v @@ -0,0 +1,75 @@ +From HB Require Import structures. +From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint interval finmap. +Require Import mathcomp_extra boolp classical_sets signed functions cardinality. +Require Import reals ereal topology normedtype sequences esum measure. +Require Import lebesgue_measure fsbigop numfun lebesgue_integral kernel. +Require Import prob_lang. + +Section bernoulli. +Variable (R : realType) (p : {nonneg R}%R) (p1 : (p%:num <= 1)%R). + +Lemma b10 : bernoulli p1 [set 0] = (`1-(p%:num))%:E. +Proof. +rewrite /bernoulli/= /measure_add/= /msum. +rewrite 2!big_ord_recr/= big_ord0 add0e. +rewrite /mscale/= !diracE memNset// mem_set//= mule1 mule0 add0e //. +Qed. + +Lemma b11 : bernoulli p1 [set 1] = p%:num%:E. +Proof. +rewrite /bernoulli/= /measure_add/= /msum. +rewrite 2!big_ord_recr/= big_ord0 add0e. +rewrite /mscale/= !diracE mem_set// memNset//= mule1 mule0 adde0 //. +Qed. + +End bernoulli. +Section binomial. +Local Open Scope ring_scope. +Variables (R : realType). + +(* Compute p%:num%:E. +Compute p%:num%R ^+ 2. *) + +Definition binomial2 (p : {nonneg R}) (p1 : p%:num <= 1) := + measure_add + (mscale (p%:num ^+ 2)%:nng (dirac 2%N)) + (measure_add + (mscale (2 * p%:num * (onem_nonneg p1)%:num)%:nng (dirac 1%N)) + (mscale ((onem_nonneg p1)%:num ^+ 2)%:nng (dirac 0%N))). + +Lemma b20 p p1 : binomial2 p p1 [set 2%N] = (p%:num ^+ 2)%:E. +Proof. +rewrite /binomial2/= /measure_add/= /msum !big_ord_recr/= big_ord0 add0e. +rewrite /msum !big_ord_recr/= big_ord0 add0e. +rewrite /mscale/= !diracE mem_set//= memNset// memNset// mule1 mule0 mule0 add0e adde0//. +Qed. + +End binomial. + +Local Open Scope ring_scope. +Import Order.TTheory GRing.Theory Num.Def Num.ExtraDef Num.Theory. + +Section example. +Variables (R : realType). + +Goal binomial2 R (1 / 2)%:nng p12 [set 2%N] = (1 / 4)%:E. +Proof. +rewrite b20 /= expr2. +by rewrite mulf_div -natrM [in LHS]mul1r. +Qed. + +(* Lemma measurable_fun_bernoulli (U : set _) : + measurable U -> + measurable_fun setT (@bernoulli R p). +Proof. +move=> mU. +by apply: ge0_emeasurable_fun_sum => // n; exact/measurable_kernel. +Qed. *) + +HB.instance Definition _ := + isKernel.Build _ _ _ _ _ (bernoulli p1) measurable_fun_kseries. + +Check letin bernoulli. + +Check p27. + From 7111ba87eb868dba7e0a2f10d75859348d582899 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Fri, 7 Apr 2023 11:59:15 +0900 Subject: [PATCH 43/54] custom entry (test) --- theories/lang_syntax.v | 46 +++++++++++++++++++++++++++++++++--------- 1 file changed, 37 insertions(+), 9 deletions(-) diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index 6bf933781d..27eb5c3c8d 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -22,6 +22,9 @@ Local Open Scope string. Import Notations. +Reserved Notation "l |- e -D-> v # mv" (at level 50). +Reserved Notation "l |- e -P-> v" (at level 50). + Section type_syntax. Variables (R : realType). @@ -90,7 +93,7 @@ Inductive expD : context -> stype -> Type := | exp_pair l t1 t2 : expD l t1 -> expD l t2 -> expD l (spair t1 t2) | exp_var l x t : t = nth sunit (map snd l) (seq.index x (map fst l)) -> expD l t -| exp_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : +| exp_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : expD l (sprob sbool) | exp_poisson l : nat -> expD l sreal -> expD l sreal | exp_norm l t : expP l t -> expD l (sprob t) @@ -248,9 +251,6 @@ End measurable_fun_normalize. existT _ (@varof l (seq.index x (map fst l)) (false_index_size H)) (@mvarof l (seq.index x (map fst l)) (false_index_size H)) end. *) -Reserved Notation "l |- e -D-> v # mv" (at level 50). -Reserved Notation "l |- e -P-> v" (at level 50). - Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) (f : projT2 (typei (sprod (map (snd) l))) -> projT2 (typei T)), measurable_fun setT f -> Prop := @@ -330,6 +330,8 @@ with evalP : forall (l : context) (T : stype), where "l |- e -P-> v" := (@evalP l _ e v). End eval. +Notation "l |- e -D-> v # mv" := (@evalD _ l _ e v mv). +Notation "l |- e -P-> v" := (@evalP _ l _ e v). Section eval_prop. Variables (R : realType). @@ -980,12 +982,38 @@ Let sfinVY z : sfinite_measure (VY z). Proof. exact: sfinite_kernel_measure. Qed HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ (mR R) R (VY z) (sfinVY z). +End eval_prop. + +Declare Custom Entry expr. +Notation "[ e ]" := e (e custom expr at level 50). +Notation "x ':r'" := (@exp_real _ _ x) (in custom expr at level 0). +Notation "ret x" := (@exp_return _ _ _ x) (in custom expr at level 2). +Notation "% x" := (exp_var x _ erefl) (in custom expr at level 1). +Notation "( x , y )" := (exp_pair x y) (in custom expr at level 1). +Notation "'Let' x '<~' e 'In' f" := (exp_letin _ x erefl e f) + (in custom expr at level 3, + x constr, + e custom expr at level 3, + f custom expr at level 3, + left associativity). +(*Notation "( x )" := x (in custom expr, x at level 50).*) +Notation "{ x }" := x (in custom expr, x constr). +Notation "x" := x (in custom expr at level 0, x ident). + +Section letinC. +Variable R : realType. + Lemma letinC12 v1 v2 t M : let x := "x" in let y := "y" in measurable M -> - @evalP R [::] (spair sreal sreal) (exp_letin _ x erefl (exp_return (exp_real 1)) (exp_letin _ y erefl (exp_return (exp_real 2)) (exp_return (exp_pair (exp_var x _ erefl) (exp_var y _ erefl))))) v1 -> - evalP (exp_letin _ y erefl (exp_return (exp_real 2)) (exp_letin _ x erefl (exp_return (exp_real 1)) (exp_return (exp_pair (exp_var x _ erefl) (exp_var y _ erefl))))) v2 -> + [::] |- [Let x <~ ret {1%R}:r In + Let y <~ ret {2%R}:r In + ret (%x , %y)] : @expP R _ _ -P-> v1 + -> + [::] |- [Let y <~ ret {2%R}:r In + Let x <~ ret {1%R}:r In + ret (%x, %y)] -P-> v2 -> v1 t M = v2 t M. Proof. move=> x y mM ev1 ev2. @@ -1019,12 +1047,12 @@ have -> : (var2of3' = (@mvarof R [:: (x, sreal); (y, sreal)] 1 (false_index_size apply/(@E_var R [:: (x, sreal); (y, sreal)] y is_true_true). apply: letin'C; last by []. move=> x0 t0. -rewrite (@evalP_uni_new y 1 vx vx'); last 2 first. +rewrite (@evalP_uni_new _ y 1 vx vx'); last 2 first. rewrite /vx /execP_cst /sval/=. by case: cid. rewrite /vx' /execP_cst /sval/=. by case: cid. - by done. + by []. move=> x0 t0. rewrite /vy /vy' /execP_cst /sval/=. case: cid => sy. @@ -1035,7 +1063,7 @@ move=> x0 t0. exact: er1. Qed. -End eval_prop. +End letinC. Section example. From f1bacdff8a991a8a6b27e42bb83bf99dae3a6258 Mon Sep 17 00:00:00 2001 From: AyumuSaito Date: Fri, 7 Apr 2023 16:16:55 +0900 Subject: [PATCH 44/54] before introduce finmap --- theories/binomial.v | 18 ++---- theories/lang_syntax.v | 144 ++++++++++++++++++++++++++++++++--------- 2 files changed, 121 insertions(+), 41 deletions(-) diff --git a/theories/binomial.v b/theories/binomial.v index dee4056d7c..e9dc4c8488 100644 --- a/theories/binomial.v +++ b/theories/binomial.v @@ -5,17 +5,20 @@ Require Import reals ereal topology normedtype sequences esum measure. Require Import lebesgue_measure fsbigop numfun lebesgue_integral kernel. Require Import prob_lang. +Local Open Scope ring_scope. +Import Order.TTheory GRing.Theory Num.Def Num.ExtraDef Num.Theory. + Section bernoulli. Variable (R : realType) (p : {nonneg R}%R) (p1 : (p%:num <= 1)%R). -Lemma b10 : bernoulli p1 [set 0] = (`1-(p%:num))%:E. +Lemma b10 : bernoulli p1 [set 0%N] = (`1-(p%:num))%:E. Proof. rewrite /bernoulli/= /measure_add/= /msum. rewrite 2!big_ord_recr/= big_ord0 add0e. rewrite /mscale/= !diracE memNset// mem_set//= mule1 mule0 add0e //. Qed. -Lemma b11 : bernoulli p1 [set 1] = p%:num%:E. +Lemma b11 : bernoulli p1 [set 1%N] = p%:num%:E. Proof. rewrite /bernoulli/= /measure_add/= /msum. rewrite 2!big_ord_recr/= big_ord0 add0e. @@ -24,18 +27,14 @@ Qed. End bernoulli. Section binomial. -Local Open Scope ring_scope. Variables (R : realType). -(* Compute p%:num%:E. -Compute p%:num%R ^+ 2. *) - Definition binomial2 (p : {nonneg R}) (p1 : p%:num <= 1) := measure_add (mscale (p%:num ^+ 2)%:nng (dirac 2%N)) (measure_add - (mscale (2 * p%:num * (onem_nonneg p1)%:num)%:nng (dirac 1%N)) - (mscale ((onem_nonneg p1)%:num ^+ 2)%:nng (dirac 0%N))). + (mscale (2 * p%:num * (onem_nonneg p1)%:num)%:nng (dirac 1%N)) + (mscale ((onem_nonneg p1)%:num ^+ 2)%:nng (dirac 0%N))). Lemma b20 p p1 : binomial2 p p1 [set 2%N] = (p%:num ^+ 2)%:E. Proof. @@ -46,9 +45,6 @@ Qed. End binomial. -Local Open Scope ring_scope. -Import Order.TTheory GRing.Theory Num.Def Num.ExtraDef Num.Theory. - Section example. Variables (R : realType). diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index 27eb5c3c8d..d455f93183 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -62,6 +62,8 @@ Inductive stype := | sprob : stype -> stype | sprod : list stype -> stype. +Canonical stype_eqType := Equality.Pack (@gen_eqMixin stype). + Fixpoint typei (t : stype) : {d & measurableType d} := match t with | sunit => existT _ _ munit @@ -251,6 +253,9 @@ End measurable_fun_normalize. existT _ (@varof l (seq.index x (map fst l)) (false_index_size H)) (@mvarof l (seq.index x (map fst l)) (false_index_size H)) end. *) +Lemma mem_cons h (t : context) : h :: t =i h :: t. +Proof. by []. Qed. + Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) (f : projT2 (typei (sprod (map (snd) l))) -> projT2 (typei T)), measurable_fun setT f -> Prop := @@ -958,6 +963,33 @@ apply. exact/E_return/E_real. Qed. +Require Import JMeq. + +Obligation Tactic := idtac. + +Program Fixpoint wP {st} {l : context} (x : string * stype) (e : @expP R l st) + : { l' | @expP R l' st /\ l' =i x :: l} := +match e with +| exp_return l0 _ e0 => @exp_return R (x :: l0) _ (wD x e0) +| exp_if l0 _ e1 e2 e3 => @exp_if R (x :: l0) _ (wD x e1) (wP x e2) (wP x e3) +| exp_letin l0 l1 _ _ x0 H e1 e2 => @exp_letin R (x :: l0) (x :: l1) _ _ x0 _ (wP x e1) (wP _ e2) +| exp_sample_bern l0 _ _ => _ +| exp_score l0 e1 => _ +end with wD {st} {l : context} x (e : @expD R l st) := +match e with +| _ => _ +end. +Next Obligation. +Admitted. +Next Obligation. +move=> st l x e l0 l1 ? ? x0 H e1 e2 l0l ? ?. +rewrite H. + + + + + + Definition vx : R.-sfker munit ~> mR R := execP_cst [:: ("x", sreal)] [::] 1. Definition VX z : set (mR R) -> \bar R := vx z. Let VX0 z : (VX z) set0 = 0. Proof. by []. Qed. @@ -985,18 +1017,19 @@ HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ (mR R) R End eval_prop. Declare Custom Entry expr. -Notation "[ e ]" := e (e custom expr at level 50). -Notation "x ':r'" := (@exp_real _ _ x) (in custom expr at level 0). -Notation "ret x" := (@exp_return _ _ _ x) (in custom expr at level 2). +Notation "[ e ]" := e (e custom expr at level 5). +Notation "x ':r'" := (@exp_real _ _ x%R) (in custom expr at level 1). +Notation "'Ret' x" := (@exp_return _ _ _ x) (in custom expr at level 2). Notation "% x" := (exp_var x _ erefl) (in custom expr at level 1). Notation "( x , y )" := (exp_pair x y) (in custom expr at level 1). Notation "'Let' x '<~' e 'In' f" := (exp_letin _ x erefl e f) (in custom expr at level 3, x constr, - e custom expr at level 3, + (* e custom expr at level 2, *) f custom expr at level 3, left associativity). (*Notation "( x )" := x (in custom expr, x at level 50).*) +Notation "'If' e1 'Then' e2 'Else' e3" := (exp_if e1 e2 e3) (in custom expr at level 1). Notation "{ x }" := x (in custom expr, x constr). Notation "x" := x (in custom expr at level 0, x ident). @@ -1007,19 +1040,23 @@ Lemma letinC12 v1 v2 t M : let x := "x" in let y := "y" in measurable M -> - [::] |- [Let x <~ ret {1%R}:r In - Let y <~ ret {2%R}:r In - ret (%x , %y)] : @expP R _ _ -P-> v1 + [::] |- [Let x <~ Ret {1}:r In + Let y <~ Ret {2}:r In + Ret (%x , %y)] : @expP R _ _ -P-> v1 -> - [::] |- [Let y <~ ret {2%R}:r In - Let x <~ ret {1%R}:r In - ret (%x, %y)] -P-> v2 -> + [::] |- [Let y <~ Ret {2}:r In + Let x <~ Ret {1}:r In + Ret (%x , %y)] -P-> v2 -> v1 t M = v2 t M. Proof. +set d := (x in (projT1 x).-measurable _). +rewrite -/d in M v1 v2 *. move=> x y mM ev1 ev2. pose vx : R.-sfker munit ~> mR R := execP_cst [:: (x, sreal)] [::] 1. -pose vy : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := execP_cst [:: (x, sreal)] [:: (x, sreal)] 2. -have -> : v1 = letin' (vx) (letin' (vy) (ret (measurable_fun_pair var2of3' var1of3'))). +pose vy : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := + execP_cst [:: (x, sreal)] [:: (x, sreal)] 2. +have -> : v1 = + letin' (vx) (letin' (vy) (ret (measurable_fun_pair var2of3' var1of3'))). apply: (evalP_uniq ev1). apply/E_letin /E_letin. rewrite /vx /execP_cst/= /sval/=. @@ -1063,6 +1100,61 @@ move=> x0 t0. exact: er1. Qed. +(* Lemma evalP_uni_new x r + (u : R.-sfker munit ~> mR R) + (v : R.-sfker prod_meas_obligation_2 prod_meas + (existT [eta measurableType] default_measure_display (mR R)) + [::] ~> mR R) : + evalP (exp_return (exp_real r) : expP [::] sreal) u -> + evalP (exp_return (exp_real r) : expP [:: (x, sreal)] sreal) v -> + forall x0 t, v (x0, t) = u t. *) + +Lemma evalP_uniq_sub (st : stype) (u1 : R.-sfker munit ~> _) (u1' : R.-sfker prod_meas_obligation_2 prod_meas + (existT [eta measurableType] _ (typei2 st)) + [::] ~> _) M e1 e1' : + let x := "x" in + (* let y := "y" in *) + x \notin free_varsP e1 -> + measurable M -> + [::] |- [e1] -P-> u1 -> + (* evalP ([e1'] : expP [:: (y, st)] st) u1' -> *) + [:: (x, st)] |- [e1'] : expP [:: (x, st)] st -P-> u1' -> + forall y0 t, u1 t M = u1' (y0, t) M. +Proof. +move=> x xNe1 mst. +move=> H1 H2. +(* have -> : u1 = ret (kr r). *) +have := @evalP_uniq R [::] st [e1] u1 _ H1. +(* apply. +apply/E_return /E_real. *) +(* suff : u1' = ret (kr r) by move=> ->. *) +have := @evalP_uniq R [:: (x, st)] st [e1'] u1' _ H2. +apply. +exact/E_return/E_real. +Admitted. + +Lemma letinC u1 u1' u2 u2' v1 v2 t M (e1 : expP [::] sreal) e1' (e2 : expP [:: ("x", sreal)] sreal) e2' : + let x := "x" in + let y := "y" in + "x" \notin free_varsP e2 -> + "y" \notin free_varsP e1 -> + measurable M -> + [::] |- [e1] -P-> u1 -> + [:: ("y", sreal)] |- [e1'] -P-> u1' -> + [:: ("x", sreal)] |- [e2] -P-> u2 -> + [::] |- [e2'] -P-> u2' -> + [::] |- [Let x <~ e1 In + Let y <~ e2 In + Ret (%x , %y)] : @expP R _ _ -P-> v1 + -> + [::] |- [Let y <~ e2' In + Let x <~ e1' In + Ret (%x , %y)] -P-> v2 -> + v1 t M = v2 t M. +Proof. +rewrite /=. +Admitted. + End letinC. Section example. @@ -1070,31 +1162,23 @@ Section example. Local Open Scope ring_scope. Variables (R : realType). -Notation "r '%:r'" := (exp_real r) (at level 2, left associativity). -Notation "% x" := (exp_var x _ erefl) (at level 4). -Notation Ret := exp_return. -Notation If := exp_if. -Notation "'Let' x <= e1 'In' e2" := (exp_letin _ x erefl e1 e2) (at level 40, x, e1, e2 at next level). - -Example __ : @evalD R [::] _ (exp_real 3) (cst 3) (kr 3). -Proof. apply: E_real. Qed. +Example __ : @evalD R [::] _ [{3}:r] (cst 3) (kr 3). +Proof. apply/E_real. Qed. -Example ex_ret : @evalP R [::] _ (exp_return (exp_real 3)) (ret (kr 3)). -Proof. -apply/E_return/E_real. -Qed. +Example ex_ret : @evalP R [::] _ [Ret {3}:r] (ret (kr 3)). +Proof. apply/E_return/E_real. Qed. Check ret (kr 3) : R.-sfker _ ~> (mR R). Check ret (kr 3) tt : {measure set mR R -> \bar R}. Goal (ret (kr 3) : R.-sfker _ ~> (mR R)) tt [set: R] = 1%:E. Proof. rewrite /= diracE in_setT //. Qed. -Example pgm1 : expD [::] (sprob sbool) := exp_norm ( - Let "x" <= exp_sample_bern [::] (2 / 7%:R)%:nng p27 In - Let "r" <= If (@exp_var R [:: ("x", sbool)] "x" _ erefl) - (Ret 3%:r) (Ret 10%:r) In - Let "_" <= exp_score - (exp_poisson 4 (@exp_var R [:: ("r", sreal); ("x", sbool)] "r" _ erefl)) In Ret %"x"). +Example pgm1 : expD [::] (sprob sbool) := let x := "x" in exp_norm ( + [Let "x" <~ {exp_sample_bern [::] (2 / 7%:R)%:nng p27} In + Let "r" <~ If {(@exp_var R [:: ("x", sbool)] "x" _ erefl)} + Then Ret {3}:r Else Ret {10}:r In + Let "_" <~ {exp_score + (exp_poisson 4 (@exp_var R [:: ("r", sreal); ("x", sbool)] "r" _ erefl))} In Ret %x]). Print pgm1. From 2aad95dd360eebe5edaa7d8bec79ee205d2e29c1 Mon Sep 17 00:00:00 2001 From: AyumuSaito Date: Tue, 11 Apr 2023 06:56:46 +0900 Subject: [PATCH 45/54] intro. weaken --- theories/lang_syntax.v | 176 +++++++++++++++++++++++++++++++++-------- 1 file changed, 141 insertions(+), 35 deletions(-) diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index d455f93183..a0c4915a8c 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -82,18 +82,32 @@ End type_syntax. Arguments typei {R}. Arguments typei2 {R}. +(*Axiom string_lt : string -> string -> bool. + +Axiom ordered : seq string -> bool.*) + Section context. Definition context := seq (string * stype)%type. +(*Inductive context := + mkContext (k : seq (string * stype)%type) + of ordered (map fst k). +Definition add_binding (l : context) + (x : (string * stype)%type) : context. +Admitted. +Definition get_seq (l : context) := + let: mkContext k _ := l in k.*) End context. Section expr. Variables (R : realType). Inductive expD : context -> stype -> Type := +| expWD l st x (e : expD l st) : x \notin l -> expD (x :: l) st | exp_unit l : expD l sunit | exp_bool l : bool -> expD l sbool | exp_real l : R -> expD l sreal | exp_pair l t1 t2 : expD l t1 -> expD l t2 -> expD l (spair t1 t2) -| exp_var l x t : t = nth sunit (map snd l) (seq.index x (map fst l)) -> +| exp_var l x t : + t = nth sunit (map snd l) (seq.index x (map fst l)) -> expD l t | exp_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : expD l (sprob sbool) @@ -101,9 +115,11 @@ Inductive expD : context -> stype -> Type := | exp_norm l t : expP l t -> expD l (sprob t) with expP : context -> stype -> Type := +| expWP l st x (e : expP l st) : x \notin l -> expP (x :: l) st | exp_if l t : expD l sbool -> expP l t -> expP l t -> expP l t | exp_letin l l' t1 t2 (x : string) : l' = (x, t1) :: l -> - expP l t1 -> expP l' t2 -> expP l t2 + expP + l t1 -> expP l' t2 -> expP l t2 (* | exp_sample : forall t l, expD (sprob t) l -> expP t l *) | exp_sample_bern l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : expP l sbool @@ -132,7 +148,7 @@ Arguments exp_return {R l _}. Section eval. Variables (R : realType). -Definition varof (l : context) (i : nat) (li : (i < size l)%nat) : +Definition varof (l : seq (string * stype)%type) (i : nat) (li : (i < size l)%nat) : projT2 (@typei R (sprod (map snd l))) -> projT2 (@typei R (nth sunit (map snd l) i)). revert l i li. @@ -150,11 +166,11 @@ refine (H _ _ _ K.2). exact il. Defined. -Lemma false_index_size (x : string) (l : context) (H : x \in (map fst l)) : +Lemma false_index_size (x : string) (l : seq (string * stype)%type) (H : x \in map fst l) : (seq.index x (map fst l) < size l)%nat. Proof. by rewrite -(size_map fst) index_mem. Qed. -Lemma mvarof (l : context) (i : nat) (li : (i < size l)%nat) : +Lemma mvarof (l : seq (string * stype)%type) (i : nat) (li : (i < size l)%nat) : measurable_fun setT (@varof l i li). Proof. revert l i li. @@ -251,13 +267,20 @@ End measurable_fun_normalize. existT _ _ (@measurable_fun_pair _ _ _ _ _ _ _ _ (projT2 (execD l e1)) (projT2 (execD l e2))) | exp_var l x => forall (H : x \in (map fst l)), existT _ (@varof l (seq.index x (map fst l)) (false_index_size H)) (@mvarof l (seq.index x (map fst l)) (false_index_size H)) - end. *) + end. *) -Lemma mem_cons h (t : context) : h :: t =i h :: t. -Proof. by []. Qed. +Definition eta1 x (l : context) t : (projT2 (@typei R (sprod [seq i.2 | i <- l])) -> projT2 (@typei R t)) -> +projT2 (@typei R (sprod (map snd (x :: l)))) -> projT2 (@typei R t). +Admitted. + +Definition meta1 x (l : context) t (f : projT2 (@typei R (sprod (map snd l))) -> projT2 (@typei R t)) : measurable_fun setT (@eta1 x l t f). +Admitted. + +Definition eta_kernel x (l : context) t (k : R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t) : R.-sfker (@typei2 R (sprod (map snd (x :: l)))) ~> @typei2 R t. +Admitted. Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) - (f : projT2 (typei (sprod (map (snd) l))) -> projT2 (typei T)), + (f : projT2 (typei (sprod (map snd l))) -> projT2 (typei T)), measurable_fun setT f -> Prop := | E_unit l : l |- exp_unit -D-> cst tt # ktt @@ -268,7 +291,7 @@ Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) | E_real l r : l |- exp_real r -D-> cst r # kr r -| E_pair l (G := sprod (map (snd) l)) A B e1 f1 mf1 e2 f2 mf2 : +| E_pair l (G := sprod (map snd l)) A B e1 f1 mf1 e2 f2 mf2 : l |- e1 -D-> f1 # mf1 -> (* (f1 : projT2 (typei G) -> projT2 (typei A)) *) l |- e2 -D-> f2 # mf2 -> (* (f2 : projT2 (typei G) -> projT2 (typei B)) *) @@ -300,11 +323,15 @@ Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) l |- exp_norm e -D-> (normalize k point : _ -> pprobability _ _) # measurable_fun_normalize k +| E_WD l (t : stype) (e : expD l t) x (xl : x \notin l) f mf : + l |- e -D-> f # mf -> + (x :: l) |- expWD e xl -D-> (@eta1 x l t f) # (@meta1 x l t f) + where "l |- e -D-> v # mv" := (@evalD l _ e v mv) with evalP : forall (l : context) (T : stype), expP l T -> - R.-sfker (projT2 (typei (sprod (map (snd) l)))) ~> projT2 (typei T) -> Prop := + R.-sfker (projT2 (typei (sprod (map snd l)))) ~> projT2 (typei T) -> Prop := | E_sample l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : (* @evalD l (sprob T) e (cst p) (measurable_fun_cst p) -> *) l |- @exp_sample_bern R _ r r1 -P-> @@ -330,8 +357,12 @@ with evalP : forall (l : context) (T : stype), (k1 : R.-sfker projT2 (typei G) ~> projT2 (typei t1)) (k2 : R.-sfker (typei2 (spair t1 G)) ~> projT2 (typei t2)) : l |- e1 -P-> k1 -> - ((x, t1)::l)%SEQ |- e2 -P-> k2 -> + ((x, t1) :: l)%SEQ |- e2 -P-> k2 -> l |- exp_letin _ x erefl e1 e2 -P-> letin' k1 k2 + +| E_WP l (t : stype) (e : expP l t) x (xl : x \notin l) k : + l |- e -P-> k -> + (x :: l) |- expWP e xl -P-> (@eta_kernel x l t k) where "l |- e -P-> v" := (@evalP l _ e v). End eval. @@ -362,7 +393,7 @@ apply: (@evalD_mut_ind R (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) (u : R.-sfker projT2 (typei G) ~> projT2 (typei t)) (h1 : evalP e u) => forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), - evalP e v -> u = v) _ _ _ _ _ _ _ _ _ _ _ _ _ l t e); last exact: hu. + evalP e v -> u = v) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e); last exact: hu. - move=> l' {}v {}mv. inversion 1. @@ -415,6 +446,14 @@ do 2 inj H2. do 2 inj H4. subst. by rewrite (IH _ H3). +- (* W *) +move=> l' A e0 x xl f mf ev IH {}v {}mv. +inversion 1. +subst A. +do 2 inj H6. +do 2 inj H8. +subst. +by rewrite (IH _ _ H3). - (* sample *) move=> l' r r1 p. inversion 1. @@ -467,6 +506,13 @@ do 2 inj H13. do 2 inj H11. subst. by rewrite (IH1 _ H4) (IH2 _ H14). +move=> l' A e0 x xl k1 ev IH {}k. +inversion 1. +subst A. +do 2 inj H4. +do 2 inj H5. +subst. +by rewrite (IH _ H3). Qed. (* TODO: factorize proof *) @@ -480,7 +526,7 @@ apply: (@evalP_mut_ind R forall (v : projT2 (typei G) -> projT2 (typei t)) (mv : measurable_fun setT v), evalD e mv -> f = v) (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) (u : R.-sfker projT2 (typei G) ~> projT2 (typei t)) (h1 : evalP e u) => forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), evalP e v -> u = v) - _ _ _ _ _ _ _ _ _ _ _ _ _ l t e); last exact: hu. + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e); last exact: hu. - move=> l' {}v {}mv. inversion 1. @@ -533,6 +579,14 @@ do 2 inj H2. do 2 inj H4. subst. by rewrite (IH _ H3). +- (* W *) +move=> l' A e0 x xl f mf ev IH {}v {}mv. +inversion 1. +subst A. +do 2 inj H6. +do 2 inj H8. +subst. +by rewrite (IH _ _ H3). - (* sample *) move=> l' r r1 ev. inversion 1. @@ -585,6 +639,13 @@ do 2 inj H13. do 4 inj H8. *) subst. by rewrite (IH1 _ H4) (IH2 _ H14). +move=> l' A e0 x xl k1 ev IH {}k. +inversion 1. +subst A. +do 2 inj H4. +do 2 inj H5. +subst. +by rewrite (IH _ H3). Qed. Fixpoint free_varsD l t (e : @expD R l t) : seq string := @@ -597,6 +658,7 @@ Fixpoint free_varsD l t (e : @expD R l t) : seq string := | exp_real _ _ => [::] | exp_bernoulli _ _ _ => [::] | exp_norm _ _ e => free_varsP e + | expWD _ _ _ e _ => free_varsD e end with free_varsP T l (e : expP T l) : seq _ := match e with @@ -605,6 +667,7 @@ with free_varsP T l (e : expP T l) : seq _ := | exp_sample_bern _ _ _ => [::] | exp_score _ e => free_varsD e | exp_return _ _ e => free_varsD e + | expWP _ _ _ e _ => free_varsP e end. Lemma evalD_full (l : context) (t : stype) : @@ -618,7 +681,15 @@ apply: (@expD_mut_ind R exists f (mf : measurable_fun _ f), evalD e mf) (fun (l : context) (t : stype) (e : expP l t) => {subset (free_varsP e) <= map fst l} -> - exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). + exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). +move=> l0 st x e1 H1 xl0 el. +have h1 : {subset free_varsD e1 <= map fst l0}. + admit. +move: H1 => /(_ h1) => H1. +destruct H1 as [f [mf]]. +exists (eta1 f). +exists (meta1 f). +exact/E_WD. do 2 eexists; apply/E_unit. do 2 eexists; apply/E_bool. do 2 eexists; apply/E_real. @@ -668,6 +739,15 @@ destruct H as [k]. exists (normalize k point). exists (measurable_fun_normalize k). exact: E_norm. +move=> l0 st x e1 H1 xl0 el. +have h1 : {subset free_varsP e1 <= map fst l0}. + move=> x0 x0e0. + admit. + (* by apply: el => /=. *) +move: H1 => /(_ h1) => H1. +destruct H1 as [k]. +exists (@eta_kernel R x l0 st k). +exact/E_WP. move=> l0 t0 e1 H1 e2 H2 e3 H3 el. have h1 : {subset free_varsD e1 <= map fst l0}. move=> x xe1. @@ -734,7 +814,8 @@ move: H => /(_ h) => H. destruct H as [f [mf]]. exists (ret mf). exact: E_return. -Qed. +Admitted. +(* Qed. *) Lemma evalP_full (l : context) (t : stype) : forall e, {subset (free_varsP e) <= map fst l} -> @@ -747,7 +828,8 @@ apply: (@expP_mut_ind R exists f (mf : measurable_fun _ f), evalD e mf) (fun (l : context) (t : stype) (e : expP l t) => {subset (free_varsP e) <= map fst l} -> - exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). + exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). +admit. do 2 eexists; apply/E_unit. do 2 eexists; apply/E_bool. do 2 eexists; apply/E_real. @@ -795,6 +877,7 @@ destruct H as [k]. exists (normalize k point). exists (measurable_fun_normalize k). exact: E_norm. +admit. move=> l0 t0 e1 H1 e2 H2 e3 H3 el. have h1 : {subset free_varsD e1 <= map fst l0}. move=> x xe1. @@ -861,7 +944,8 @@ move: H => /(_ h) => H. destruct H as [f [mf]]. exists (ret mf). exact: E_return. -Qed. +Admitted. +(* Qed. *) (* Variables (A B C : stype). Definition X := @typei2 R A. @@ -894,7 +978,10 @@ apply: (@expP_mut_rec R free_varsD e = [::] -> expD [::] t) (fun (l : context) (t : stype) (e : expP l t) => free_varsP e = [::] -> expP [::] t) - _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). +move=> l0 st x e0 H1 xl H2. +(* apply (expWD e0 x). *) +admit. move=> ? ?; exact: exp_unit. move=> ? b ?; exact: (exp_bool b). move=> ? r ?; exact: (exp_real r). @@ -920,6 +1007,7 @@ rewrite /=. move=> ? ? e1 h H. apply: exp_norm. exact: h. +admit. move=> ? ? e1 h1 e2 h2 e3 h3 /= H. apply: exp_if. apply: h1. @@ -968,13 +1056,14 @@ Require Import JMeq. Obligation Tactic := idtac. Program Fixpoint wP {st} {l : context} (x : string * stype) (e : @expP R l st) - : { l' | @expP R l' st /\ l' =i x :: l} := + : @expP R (x :: l) st := match e with | exp_return l0 _ e0 => @exp_return R (x :: l0) _ (wD x e0) | exp_if l0 _ e1 e2 e3 => @exp_if R (x :: l0) _ (wD x e1) (wP x e2) (wP x e3) | exp_letin l0 l1 _ _ x0 H e1 e2 => @exp_letin R (x :: l0) (x :: l1) _ _ x0 _ (wP x e1) (wP _ e2) | exp_sample_bern l0 _ _ => _ | exp_score l0 e1 => _ +| expWP l0 _ x e0 xl => _ end with wD {st} {l : context} x (e : @expD R l st) := match e with | _ => _ @@ -984,11 +1073,13 @@ Admitted. Next Obligation. move=> st l x e l0 l1 ? ? x0 H e1 e2 l0l ? ?. rewrite H. - - - - - +Admitted. +Next Obligation. +Admitted. +Next Obligation. +Admitted. +Next Obligation. +Admitted. Definition vx : R.-sfker munit ~> mR R := execP_cst [:: ("x", sreal)] [::] 1. Definition VX z : set (mR R) -> \bar R := vx z. @@ -1109,31 +1200,46 @@ Qed. evalP (exp_return (exp_real r) : expP [:: (x, sreal)] sreal) v -> forall x0 t, v (x0, t) = u t. *) -Lemma evalP_uniq_sub (st : stype) (u1 : R.-sfker munit ~> _) (u1' : R.-sfker prod_meas_obligation_2 prod_meas - (existT [eta measurableType] _ (typei2 st)) - [::] ~> _) M e1 e1' : +Lemma evalP_uniq_sub (l : context) (st : stype) (u1 : R.-sfker _ ~> _) + (u1' : R.-sfker prod_meas_obligation_2 prod_meas + (existT [eta measurableType] _ (typei2 st)) _ ~> _) + (xtl : ("x", st) \notin l) M e : let x := "x" in (* let y := "y" in *) - x \notin free_varsP e1 -> + x \notin free_varsP e -> measurable M -> - [::] |- [e1] -P-> u1 -> + l |- [e] -P-> u1 -> (* evalP ([e1'] : expP [:: (y, st)] st) u1' -> *) - [:: (x, st)] |- [e1'] : expP [:: (x, st)] st -P-> u1' -> + ((x, st) :: l)%SEQ |- [{@expWP R l st (x, st) e xtl}] : expP ((x, st) :: l)%SEQ st -P-> u1' -> forall y0 t, u1 t M = u1' (y0, t) M. Proof. move=> x xNe1 mst. -move=> H1 H2. +move=> hu. +have:= (@evalP_mut_ind R + (fun (l : _) (G := sprod (map snd l)) (st : stype) (e : expD l st) (f : projT2 (typei G) -> projT2 (typei st)) (mf : measurable_fun setT f) (h1 : l |- [e] -D-> f # mf) => + forall (xtl : ("x", st) \notin l) (v : projT2 (typei G) -> projT2 (typei st)) (mv : measurable_fun setT v), ((x, st) :: l)%SEQ |- (@expWD R l st (x, st) e xtl) -D-> (@eta1 R (x, st) l st v) # (@meta1 R (x, st) l st v) -> f = v) + (* WIP: *) + (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) (u : R.-sfker projT2 (typei G) ~> projT2 (typei t)) (h1 : evalP e u) => + forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), evalP e v -> u = v) + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l st e). + (* ; last exact: hu. *) +(* have: (@evalP_mut_ind R + (fun (l : context) (st : stype) (e1 : expD l _) => + forall (f : _ -> _) (f' : _ -> _) (xtl : ("x", st) \notin l) (xl : x \notin free_varsD e1) (mM : measurable M) (ev1 : l |- [e1] -D-> f # _) y0 t, ((x, st) :: l)%SEQ |- [{@expWD R l st (x, st) e1 xtl}] : expD ((x, st) :: l)%SEQ st -D-> f' # _ -> u1 t M = u1' (y0, t) M) + (fun (st : stype) u1 u1' M (e : expP _ _) (u : R.-sfker typei2 _ ~> projT2 (typei st)) (h1 : evalP e u) => + forall (v : R.-sfker projT2 (typei _) ~> projT2 (typei st)), evalP e v -> u = v) + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ st); last exact: hu. *) (* have -> : u1 = ret (kr r). *) have := @evalP_uniq R [::] st [e1] u1 _ H1. (* apply. apply/E_return /E_real. *) (* suff : u1' = ret (kr r) by move=> ->. *) have := @evalP_uniq R [:: (x, st)] st [e1'] u1' _ H2. -apply. -exact/E_return/E_real. +(* apply. *) +(* exact/E_return/E_real. *) Admitted. -Lemma letinC u1 u1' u2 u2' v1 v2 t M (e1 : expP [::] sreal) e1' (e2 : expP [:: ("x", sreal)] sreal) e2' : +Lemma letinC u1 u1' u2 u2' v1 v2 t M (e1 : expP [::] sreal) e1' (e2 : expP [:: ("x", sreal)] sreal) e2' : let x := "x" in let y := "y" in "x" \notin free_varsP e2 -> From f1ea2f25f24d09fc38b4403cde3200fd1ef49030 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Thu, 13 Apr 2023 12:02:44 +0900 Subject: [PATCH 46/54] eta1 kernel --- theories/lang_syntax.v | 82 ++++++++++++++++++++++++++++++++++++------ 1 file changed, 72 insertions(+), 10 deletions(-) diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index a0c4915a8c..64dc42797d 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -269,17 +269,79 @@ End measurable_fun_normalize. existT _ (@varof l (seq.index x (map fst l)) (false_index_size H)) (@mvarof l (seq.index x (map fst l)) (false_index_size H)) end. *) -Definition eta1 x (l : context) t : (projT2 (@typei R (sprod [seq i.2 | i <- l])) -> projT2 (@typei R t)) -> -projT2 (@typei R (sprod (map snd (x :: l)))) -> projT2 (@typei R t). -Admitted. +Definition eta1 x (l : context) t + (f : projT2 (@typei R (sprod [seq i.2 | i <- l])) -> projT2 (@typei R t)) : + projT2 (@typei R (sprod (map snd (x :: l)))) -> projT2 (@typei R t) := f \o snd. + +Lemma meta1 x (l : context) t + (f : projT2 (@typei R (sprod (map snd l))) -> projT2 (@typei R t)) + (mf : measurable_fun setT f) : + measurable_fun setT (@eta1 x l t f). +Proof. by apply: (measurable_funT_comp mf); exact: measurable_fun_snd. Qed. + +Definition keta1 (x : string * stype) (l : context) t + (k : R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t) : + (@typei2 R (sprod (map snd (x :: l)))) -> {measure set @typei2 R t -> \bar R} := +k \o snd. + +Section kernel_eta1. +Variables (x : string * stype) (l : context) (t : stype) + (k : R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t). + +Let mk U : measurable U -> measurable_fun setT ((@keta1 x l t k) ^~ U). +Proof. +move=> mU; rewrite (_ : (@keta1 x l t k) ^~ U = (k ^~ U) \o snd)//. +apply: measurable_funT_comp. + exact: measurable_kernel. +exact: measurable_fun_snd. +Qed. -Definition meta1 x (l : context) t (f : projT2 (@typei R (sprod (map snd l))) -> projT2 (@typei R t)) : measurable_fun setT (@eta1 x l t f). -Admitted. +HB.instance Definition _ := + isKernel.Build _ _ _ _ _ (@keta1 x l t k) mk. +End kernel_eta1. + +Section sfkernel. +Variables (x : string * stype) (l : context) (t : stype) + (k : R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t). + +Let sk : exists2 s : (R.-ker (@typei2 R (sprod (map snd (x :: l)))) ~> @typei2 R t)^nat, + forall n, measure_fam_uub (s n) & + forall x0 U, measurable U -> (@keta1 x l t k) x0 U = kseries s x0 U . +Proof. +have [s hs] := sfinite k. +exists (fun n => (@keta1 x l t (s n))). +move=> n. +have [M hM] := measure_uub (s n). +exists M => x0. +rewrite /keta1/=. +exact: hM. +move=> x0 U mU. +by rewrite /keta1/= hs. +Qed. + +HB.instance Definition _ := + Kernel_isSFinite_subdef.Build _ _ _ _ _ (@keta1 x l t k) sk. + +End sfkernel. + +Section fkernel_eta1. +Variables (x : string * stype) (l : context) (t : stype) + (k : R.-fker (@typei2 R (sprod (map snd l))) ~> @typei2 R t). + +Let uub : measure_fam_uub (@keta1 x l t k). +Proof. +have [M hM] := measure_uub k. +exists M => x0. +rewrite /keta1/=. +exact: hM. +Qed. + +HB.instance Definition _ := @Kernel_isFinite.Build _ _ _ _ _ + (@keta1 x l t k) uub. +End fkernel_eta1. -Definition eta_kernel x (l : context) t (k : R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t) : R.-sfker (@typei2 R (sprod (map snd (x :: l)))) ~> @typei2 R t. -Admitted. -Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) +Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) (f : projT2 (typei (sprod (map snd l))) -> projT2 (typei T)), measurable_fun setT f -> Prop := | E_unit l : @@ -325,7 +387,7 @@ Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) | E_WD l (t : stype) (e : expD l t) x (xl : x \notin l) f mf : l |- e -D-> f # mf -> - (x :: l) |- expWD e xl -D-> (@eta1 x l t f) # (@meta1 x l t f) + (x :: l) |- expWD e xl -D-> (@eta1 x l t f) # (@meta1 x l t f mf) where "l |- e -D-> v # mv" := (@evalD l _ e v mv) @@ -362,7 +424,7 @@ with evalP : forall (l : context) (T : stype), | E_WP l (t : stype) (e : expP l t) x (xl : x \notin l) k : l |- e -P-> k -> - (x :: l) |- expWP e xl -P-> (@eta_kernel x l t k) + (x :: l) |- expWP e xl -P-> [the R.-sfker _ ~> _ of (@keta1 x l t k)] where "l |- e -P-> v" := (@evalP l _ e v). End eval. From 6a0ec16753bad28d768ccc59052c4963bfe80662 Mon Sep 17 00:00:00 2001 From: AyumuSaito Date: Thu, 13 Apr 2023 12:07:26 +0900 Subject: [PATCH 47/54] evalP_uniq_sub sketch --- theories/lang_syntax.v | 85 ++++++++++++++++++++++++++---------------- 1 file changed, 52 insertions(+), 33 deletions(-) diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index 64dc42797d..bc63a65c9e 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -1262,43 +1262,62 @@ Qed. evalP (exp_return (exp_real r) : expP [:: (x, sreal)] sreal) v -> forall x0 t, v (x0, t) = u t. *) -Lemma evalP_uniq_sub (l : context) (st : stype) (u1 : R.-sfker _ ~> _) - (u1' : R.-sfker prod_meas_obligation_2 prod_meas - (existT [eta measurableType] _ (typei2 st)) _ ~> _) - (xtl : ("x", st) \notin l) M e : +Ltac inj H := apply Classical_Prop.EqdepTheory.inj_pair2 in H. + +Lemma eta1_axiom (l : context) (st : stype) (f : typei2 (sprod (map snd l)) -> typei2 st) x y t : f t = (@eta1 R (x, st) l st f) (y, t). +Admitted. + +Lemma evalP_uniq_sub (l : context) (st : stype) e (u1 : R.-sfker _ ~> _) + (* (u1' : R.-sfker prod_meas_obligation_2 prod_meas + (existT [eta measurableType] _ (typei2 st)) _ ~> _) *) + (xtl : ("x", st) \notin l) M y0 t : let x := "x" in (* let y := "y" in *) x \notin free_varsP e -> measurable M -> - l |- [e] -P-> u1 -> + l |- e -P-> u1 -> (* evalP ([e1'] : expP [:: (y, st)] st) u1' -> *) - ((x, st) :: l)%SEQ |- [{@expWP R l st (x, st) e xtl}] : expP ((x, st) :: l)%SEQ st -P-> u1' -> - forall y0 t, u1 t M = u1' (y0, t) M. + ((x, st) :: l)%SEQ |- (@expWP R l st (x, st) e xtl) : expP ((x, st) :: l)%SEQ st -P-> (eta_kernel (x, st) u1) -> + u1 t M = (eta_kernel (x, st) u1) (y0, t) M. Proof. move=> x xNe1 mst. move=> hu. -have:= (@evalP_mut_ind R - (fun (l : _) (G := sprod (map snd l)) (st : stype) (e : expD l st) (f : projT2 (typei G) -> projT2 (typei st)) (mf : measurable_fun setT f) (h1 : l |- [e] -D-> f # mf) => - forall (xtl : ("x", st) \notin l) (v : projT2 (typei G) -> projT2 (typei st)) (mv : measurable_fun setT v), ((x, st) :: l)%SEQ |- (@expWD R l st (x, st) e xtl) -D-> (@eta1 R (x, st) l st v) # (@meta1 R (x, st) l st v) -> f = v) - (* WIP: *) - (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) (u : R.-sfker projT2 (typei G) ~> projT2 (typei t)) (h1 : evalP e u) => - forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), evalP e v -> u = v) - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l st e). - (* ; last exact: hu. *) -(* have: (@evalP_mut_ind R - (fun (l : context) (st : stype) (e1 : expD l _) => - forall (f : _ -> _) (f' : _ -> _) (xtl : ("x", st) \notin l) (xl : x \notin free_varsD e1) (mM : measurable M) (ev1 : l |- [e1] -D-> f # _) y0 t, ((x, st) :: l)%SEQ |- [{@expWD R l st (x, st) e1 xtl}] : expD ((x, st) :: l)%SEQ st -D-> f' # _ -> u1 t M = u1' (y0, t) M) - (fun (st : stype) u1 u1' M (e : expP _ _) (u : R.-sfker typei2 _ ~> projT2 (typei st)) (h1 : evalP e u) => - forall (v : R.-sfker projT2 (typei _) ~> projT2 (typei st)), evalP e v -> u = v) - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ st); last exact: hu. *) -(* have -> : u1 = ret (kr r). *) -have := @evalP_uniq R [::] st [e1] u1 _ H1. -(* apply. -apply/E_return /E_real. *) -(* suff : u1' = ret (kr r) by move=> ->. *) -have := @evalP_uniq R [:: (x, st)] st [e1'] u1' _ H2. -(* apply. *) -(* exact/E_return/E_real. *) +apply: (@evalP_mut_ind R + (fun (l : _) (st : stype) (e : expD l st) (f : projT2 (typei _) -> projT2 (typei st)) (mf : measurable_fun setT f) (h1 : l |- e -D-> f # mf) => + forall (xtl : (x, st) \notin l) M y0 t, ((x, st) :: l)%SEQ |- (@expWD R l st (x, st) e xtl) -D-> (@eta1 R (x, st) l st f) # (@meta1 R (x, st) l st f) -> f t = (@eta1 R (x, st) l st f) (y0, t) + ) + (fun (l : _) (st : stype) (e : expP l st) (u : R.-sfker _ ~> projT2 (typei st)) (h1 : evalP e u) => + forall (xtl : (x, st) \notin l) M y0 t, ((x, st) :: l)%SEQ |- (@expWP R l st (x, st) e xtl) -P-> (@eta_kernel R (x, st) l st u) -> u t M = (@eta_kernel R (x, st) l st u) (y0, t) M) + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l st e); last exact: hu. +move=> l' ? ? ? ?. +inversion 1. +apply: eta1_axiom. +move=> ? ? ? ? ? ?. +inversion 1. +apply: eta1_axiom. +move=> ? ? ? ? ? ?. +inversion 1. +apply: eta1_axiom. +move=> ??????????????????. +inversion 1. +apply: eta1_axiom. +move=> ????????. +inversion 1. +apply: eta1_axiom. +move=> ???????. +inversion 1. +apply: eta1_axiom. +move=> ???????????. +inversion 1. +apply: eta1_axiom. +move=> ??????????. +inversion 1. +apply: eta1_axiom. +move=> ?????????????. +inversion 1. +apply: eta1_axiom. +move=> ???????. +inversion 1. Admitted. Lemma letinC u1 u1' u2 u2' v1 v2 t M (e1 : expP [::] sreal) e1' (e2 : expP [:: ("x", sreal)] sreal) e2' : @@ -1307,10 +1326,10 @@ Lemma letinC u1 u1' u2 u2' v1 v2 t M (e1 : expP [::] sreal) e1' (e2 : expP [:: ( "x" \notin free_varsP e2 -> "y" \notin free_varsP e1 -> measurable M -> - [::] |- [e1] -P-> u1 -> - [:: ("y", sreal)] |- [e1'] -P-> u1' -> - [:: ("x", sreal)] |- [e2] -P-> u2 -> - [::] |- [e2'] -P-> u2' -> + [::] |- e1 -P-> u1 -> + [:: ("y", sreal)] |- e1' -P-> u1' -> + [:: ("x", sreal)] |- e2 -P-> u2 -> + [::] |- e2' -P-> u2' -> [::] |- [Let x <~ e1 In Let y <~ e2 In Ret (%x , %y)] : @expP R _ _ -P-> v1 From 1b34cbe6b8bbbfb5e25b2858c38beb420e7c65f9 Mon Sep 17 00:00:00 2001 From: AyumuSaito Date: Mon, 17 Apr 2023 10:32:43 +0900 Subject: [PATCH 48/54] fix --- theories/lang_syntax.v | 392 +++++++++++++++++++++++++++-------------- 1 file changed, 263 insertions(+), 129 deletions(-) diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index bc63a65c9e..2b9d0a4021 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -100,13 +100,22 @@ End context. Section expr. Variables (R : realType). + +Fixpoint assoc_get {A : eqType} {B : Type} (a : A) (l : seq (A * B)) : option B := + match l with + | nil => None + | h :: t => if h.1 == a then Some h.2 else assoc_get a t + end. + Inductive expD : context -> stype -> Type := | expWD l st x (e : expD l st) : x \notin l -> expD (x :: l) st | exp_unit l : expD l sunit | exp_bool l : bool -> expD l sbool | exp_real l : R -> expD l sreal | exp_pair l t1 t2 : expD l t1 -> expD l t2 -> expD l (spair t1 t2) -| exp_var l x t : +| exp_var (l : context) x t : + x \in map fst l -> + (* assoc_get x l = Some t -> *) t = nth sunit (map snd l) (seq.index x (map fst l)) -> expD l t | exp_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : @@ -117,9 +126,9 @@ Inductive expD : context -> stype -> Type := with expP : context -> stype -> Type := | expWP l st x (e : expP l st) : x \notin l -> expP (x :: l) st | exp_if l t : expD l sbool -> expP l t -> expP l t -> expP l t -| exp_letin l l' t1 t2 (x : string) : l' = (x, t1) :: l -> - expP - l t1 -> expP l' t2 -> expP l t2 +| exp_letin l t1 t2 (x : string) : +(* l' = (x, t1) :: l -> *) + expP l t1 -> expP ((x, t1) :: l) t2 -> expP l t2 (* | exp_sample : forall t l, expD (sprob t) l -> expP t l *) | exp_sample_bern l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : expP l sbool @@ -340,6 +349,27 @@ HB.instance Definition _ := @Kernel_isFinite.Build _ _ _ _ _ (@keta1 x l t k) uub. End fkernel_eta1. +Fixpoint free_varsD l t (e : @expD R l t) : seq string := + match e with + | exp_var _ x _ _ _ => [:: x] + | exp_poisson _ _ e => free_varsD e + | exp_pair _ _ _ e1 e2 => free_varsD e1 ++ free_varsD e2 + | exp_unit _ => [::] + | exp_bool _ _ => [::] + | exp_real _ _ => [::] + | exp_bernoulli _ _ _ => [::] + | exp_norm _ _ e => free_varsP e + | expWD _ _ x e _ => rem x.1 (free_varsD e) + end +with free_varsP T l (e : expP T l) : seq _ := + match e with + | exp_if _ _ e1 e2 e3 => free_varsD e1 ++ free_varsP e2 ++ free_varsP e3 + | exp_letin _ _ _ x e1 e2 => free_varsP e1 ++ rem x (free_varsP e2) + | exp_sample_bern _ _ _ => [::] + | exp_score _ e => free_varsD e + | exp_return _ _ e => free_varsD e + | expWP _ _ _ e _ => free_varsP e + end. Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) (f : projT2 (typei (sprod (map snd l))) -> projT2 (typei T)), @@ -365,9 +395,11 @@ Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) : projT2 (typei G) -> projT2 (typei (spair A B))) *) -| E_var (l : context) (x : string) (H : x \in map fst l) : +| E_var (l : context) (x : string) (H : x \in map fst l) +(* (H' : assoc_get x l = Some _) *) +: let i := seq.index x (map fst l) in - l |- exp_var x _ erefl -D-> @varof l i (false_index_size H) # + l |- exp_var x _ H erefl -D-> @varof l i (false_index_size H) # @mvarof l i (false_index_size H) | E_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : @@ -386,6 +418,7 @@ Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) measurable_fun_normalize k | E_WD l (t : stype) (e : expD l t) x (xl : x \notin l) f mf : + (* x.1 \notin free_varsD e -> *) l |- e -D-> f # mf -> (x :: l) |- expWD e xl -D-> (@eta1 x l t f) # (@meta1 x l t f mf) @@ -420,7 +453,7 @@ with evalP : forall (l : context) (T : stype), (k2 : R.-sfker (typei2 (spair t1 G)) ~> projT2 (typei t2)) : l |- e1 -P-> k1 -> ((x, t1) :: l)%SEQ |- e2 -P-> k2 -> - l |- exp_letin _ x erefl e1 e2 -P-> letin' k1 k2 + l |- exp_letin x e1 e2 -P-> letin' k1 k2 | E_WP l (t : stype) (e : expP l t) x (xl : x \notin l) k : l |- e -P-> k -> @@ -484,8 +517,8 @@ by rewrite (IH1 _ _ e1f0) (IH2 _ _ e2f3). - (* var *) move=> l' x H n {}v {}mv. inversion 1. -do 2 inj H8. -by have -> : (H = H1) by exact: Prop_irrelevance. +do 2 inj H9. +by have -> : (H = H7) by exact: Prop_irrelevance. - (* bernoulli *) move=> l' r r1 {}v {}mv. inversion 1. @@ -509,13 +542,19 @@ do 2 inj H4. subst. by rewrite (IH _ H3). - (* W *) -move=> l' A e0 x xl f mf ev IH {}v {}mv. -inversion 1. -subst A. -do 2 inj H6. -do 2 inj H8. +move=> l' A e0 x xl f mf ev IH {}v {}mv H. +simple inversion H => // ev0. subst. -by rewrite (IH _ _ H3). +case: H1 => ? ?. +subst. +do 2 inj H3. +do 2 inj H4. +rewrite /eta1. +subst. +case: H3=> H4. +do 2 inj H4. +subst. +by rewrite (IH _ _ ev0). - (* sample *) move=> l' r r1 p. inversion 1. @@ -562,12 +601,10 @@ move=> l' G0 A B x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. inversion 1. subst. do 2 inj H10. -(* inj H5. -inj H6. *) -do 2 inj H13. -do 2 inj H11. +do 2 inj H7. +do 4 inj H8. subst. -by rewrite (IH1 _ H4) (IH2 _ H14). +by rewrite (IH1 _ H4) (IH2 _ H11). move=> l' A e0 x xl k1 ev IH {}k. inversion 1. subst A. @@ -617,8 +654,8 @@ by rewrite (IH1 _ _ e1f0) (IH2 _ _ e2f3). - (* var *) move=> l' x H n {}v {}mv. inversion 1. -do 2 inj H8. -by have -> : (H = H1) by exact: Prop_irrelevance. +do 2 inj H9. +by have -> : (H = H7) by exact: Prop_irrelevance. - (* bernoulli *) move=> l' r r1 {}v {}mv. inversion 1. @@ -642,13 +679,19 @@ do 2 inj H4. subst. by rewrite (IH _ H3). - (* W *) -move=> l' A e0 x xl f mf ev IH {}v {}mv. -inversion 1. -subst A. -do 2 inj H6. -do 2 inj H8. +move=> l' A e0 x xl f mf ev IH {}v {}mv H. +simple inversion H => // ev0. subst. -by rewrite (IH _ _ H3). +case: H1 => ? ?. +subst. +do 2 inj H3. +do 2 inj H4. +rewrite /eta1. +subst. +case: H3=> H4. +do 2 inj H4. +subst. +by rewrite (IH _ _ ev0). - (* sample *) move=> l' r r1 ev. inversion 1. @@ -695,12 +738,10 @@ move=> l' G0 A B x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. inversion 1. subst. do 2 inj H10. -do 2 inj H11. -do 2 inj H13. -(* do 2 inj H7. -do 4 inj H8. *) +do 2 inj H7. +do 4 inj H8. subst. -by rewrite (IH1 _ H4) (IH2 _ H14). +by rewrite (IH1 _ H4) (IH2 _ H11). move=> l' A e0 x xl k1 ev IH {}k. inversion 1. subst A. @@ -710,47 +751,98 @@ subst. by rewrite (IH _ H3). Qed. -Fixpoint free_varsD l t (e : @expD R l t) : seq string := - match e with - | exp_var _ x _ _ => [:: x] - | exp_poisson _ _ e => free_varsD e - | exp_pair _ _ _ e1 e2 => free_varsD e1 ++ free_varsD e2 - | exp_unit _ => [::] - | exp_bool _ _ => [::] - | exp_real _ _ => [::] - | exp_bernoulli _ _ _ => [::] - | exp_norm _ _ e => free_varsP e - | expWD _ _ _ e _ => free_varsD e - end -with free_varsP T l (e : expP T l) : seq _ := - match e with - | exp_if _ _ e1 e2 e3 => free_varsD e1 ++ free_varsP e2 ++ free_varsP e3 - | exp_letin _ _ _ _ x _ e1 e2 => free_varsP e1 ++ rem x (free_varsP e2) - | exp_sample_bern _ _ _ => [::] - | exp_score _ e => free_varsD e - | exp_return _ _ e => free_varsD e - | expWP _ _ _ e _ => free_varsP e - end. - Lemma evalD_full (l : context) (t : stype) : - forall e, {subset (free_varsD e) <= map fst l} -> + forall e, + (* {subset (free_varsD e) <= map fst l} -> *) exists f (mf : measurable_fun _ f), @evalD R l t e f mf. Proof. move=> e. apply: (@expD_mut_ind R (fun (l : context) (t : stype) (e : expD l t) => - {subset (free_varsD e) <= map fst l} -> + (*{subset (free_varsD e) <= map fst l} ->*) exists f (mf : measurable_fun _ f), evalD e mf) (fun (l : context) (t : stype) (e : expP l t) => - {subset (free_varsP e) <= map fst l} -> + (* {subset (free_varsP e) <= map fst l} -> *) exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). -move=> l0 st x e1 H1 xl0 el. -have h1 : {subset free_varsD e1 <= map fst l0}. +move=> l0 st x e1 H1 xl0. +destruct H1 as [f [mf]]. +exists (eta1 f). +exists (meta1 mf). +exact/E_WD. +do 2 eexists; apply/E_unit. +do 2 eexists; apply/E_bool. +do 2 eexists; apply/E_real. +move=> l0 t1 t2 e1 H1 e2 H2. +destruct H1 as [f1 [mf1]]. +destruct H2 as [f2 [mf2]]. +exists (fun x => (f1 x, f2 x)). +eexists; exact: E_pair. +move=> l0 x t0 xl0 t0E. +subst t0. +(* exists (@varof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). +exists (@mvarof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). +by apply/E_var. *) +admit. +move=> r r1. +eexists. +eexists. +exact: E_bernoulli. +move=> l0 k e0 H. +destruct H as [f [mf]]. +exists (poisson k \o f). +exists (measurable_funT_comp (mpoisson k) mf). +exact: E_poisson. +move=> l0 t0 e0 H. +destruct H as [k]. +exists (normalize k point). +exists (measurable_fun_normalize k). +exact: E_norm. +move=> l0 st x e1 H1 xl0. +destruct H1 as [k]. +exists (@keta1 R x l0 st k). +exact/E_WP. +move=> l0 t0 e1 H1 e2 H2 e3 H3. +destruct H1 as [f [mf]]. +destruct H2 as [k2]. +destruct H3 as [k3]. +exists (ite mf k2 k3). +exact: E_ifP. +move=> l0 t1 t2 x e1 H1 e2 H2. +destruct H1 as [k1 ev1]. +destruct H2 as [k2 ev2]. +subst. +exists (letin' k1 k2). +exact: E_letin. +move=> l0 r r1. +exists (sample [the pprobability _ _ of bernoulli r1]). +exact: E_sample. +move=> l0 e0 H. +destruct H as [f [mf]]. +exists (score mf). +exact: E_score. +move=> l0 t0 e0 H. +destruct H as [f [mf]]. +exists (ret mf). +exact: E_return. +Admitted. + +(* move=> l0 st x e1 H1 xl0. +have h1 : {subset free_varsD e1 <= map fst (x :: l0)}. + move=> x0 x0e1. + (* have [|] := eqVneq x0 x.1. + have /= := el x0. + have : (x0 \in free_varsD (expWD (x:=x) e1 xl0)). + rewrite /free_varsD. + fold (free_varsD e1). + rewrite inE =>/orP[|//]. *) admit. -move: H1 => /(_ h1) => H1. +have h2 : {subset l0 <= x :: l0}. + +move: H1 => /(_ _ h1) => H1. destruct H1 as [f [mf]]. exists (eta1 f). -exists (meta1 f). +eexists. +(* exists (meta1 f). *) exact/E_WD. do 2 eexists; apply/E_unit. do 2 eexists; apply/E_bool. @@ -876,22 +968,84 @@ move: H => /(_ h) => H. destruct H as [f [mf]]. exists (ret mf). exact: E_return. -Admitted. -(* Qed. *) +Admitted. *) Lemma evalP_full (l : context) (t : stype) : - forall e, {subset (free_varsP e) <= map fst l} -> + forall e, + (* {subset (free_varsP e) <= map fst l} -> *) exists (k : R.-sfker _ ~> _), @evalP R l t e k. Proof. move=> e. apply: (@expP_mut_ind R (fun (l : context) (t : stype) (e : expD l t) => - {subset (free_varsD e) <= map fst l} -> + (* {subset (free_varsD e) <= map fst l} -> *) exists f (mf : measurable_fun _ f), evalD e mf) (fun (l : context) (t : stype) (e : expP l t) => - {subset (free_varsP e) <= map fst l} -> + (* {subset (free_varsP e) <= map fst l} -> *) exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). +move=> l0 st x e1 H1 xl0. +destruct H1 as [f [mf]]. +exists (eta1 f). +exists (meta1 mf). +exact/E_WD. +do 2 eexists; apply/E_unit. +do 2 eexists; apply/E_bool. +do 2 eexists; apply/E_real. +move=> l0 t1 t2 e1 H1 e2 H2. +destruct H1 as [f1 [mf1]]. +destruct H2 as [f2 [mf2]]. +exists (fun x => (f1 x, f2 x)). +eexists; exact: E_pair. +move=> l0 x t0 xl0 t0E. +subst t0. +(* exists (@varof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). +exists (@mvarof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). +by apply/E_var. *) admit. +move=> r r1. +eexists. +eexists. +exact: E_bernoulli. +move=> l0 k e0 H. +destruct H as [f [mf]]. +exists (poisson k \o f). +exists (measurable_funT_comp (mpoisson k) mf). +exact: E_poisson. +move=> l0 t0 e0 H. +destruct H as [k]. +exists (normalize k point). +exists (measurable_fun_normalize k). +exact: E_norm. +move=> l0 st x e1 H1 xl0. +destruct H1 as [k]. +exists (@keta1 R x l0 st k). +exact/E_WP. +move=> l0 t0 e1 H1 e2 H2 e3 H3. +destruct H1 as [f [mf]]. +destruct H2 as [k2]. +destruct H3 as [k3]. +exists (ite mf k2 k3). +exact: E_ifP. +move=> l0 t1 t2 x e1 H1 e2 H2. +destruct H1 as [k1 ev1]. +destruct H2 as [k2 ev2]. +subst. +exists (letin' k1 k2). +exact: E_letin. +move=> l0 r r1. +exists (sample [the pprobability _ _ of bernoulli r1]). +exact: E_sample. +move=> l0 e0 H. +destruct H as [f [mf]]. +exists (score mf). +exact: E_score. +move=> l0 t0 e0 H. +destruct H as [f [mf]]. +exists (ret mf). +exact: E_return. +Admitted. + +(* admit. do 2 eexists; apply/E_unit. do 2 eexists; apply/E_bool. do 2 eexists; apply/E_real. @@ -1006,8 +1160,7 @@ move: H => /(_ h) => H. destruct H as [f [mf]]. exists (ret mf). exact: E_return. -Admitted. -(* Qed. *) +Admitted. *) (* Variables (A B C : stype). Definition X := @typei2 R A. @@ -1017,7 +1170,7 @@ Definition Z := @typei2 R C. *) Definition execP l t (e : @expP R l t) (H : {subset free_varsP e <= map fst l}): R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t. Proof. -have /cid h := @evalP_full l t e H. +have /cid h := @evalP_full l t e. exact: (proj1_sig h). Defined. @@ -1026,7 +1179,7 @@ Definition execP_cst (l l' : context) (r : R) : Proof. have H0 : {subset free_varsP (exp_return (exp_real r) : expP [::] _) <= map (@fst string stype) l'}. by move=> x /=. -have /cid h := @evalP_full l' _ (exp_return (exp_real r)) H0. +have /cid h := @evalP_full l' _ (exp_return (exp_real r)). exact: (proj1_sig h). Defined. @@ -1051,7 +1204,7 @@ move=> t1 t2 ? e1 t1nil e2 t2nil H. rewrite /= in H. apply: exp_pair. apply: t1nil. -by destruct (free_varsD e1). +(* by destruct (free_varsD e1). apply: t2nil. destruct (free_varsD e2). reflexivity. @@ -1084,7 +1237,7 @@ destruct (free_varsP e3) => //=. move/(congr1 size) : H. by rewrite !size_cat/= !addnS. rewrite /=. -move=> ? t1 t2 x e1 h1 e2 h2 H. +move=> ? t1 t2 x e1 h1 e2 h2 H. *) Abort. (* Variables (dT : measure_display) (T : measurableType dT). @@ -1122,7 +1275,7 @@ Program Fixpoint wP {st} {l : context} (x : string * stype) (e : @expP R l st) match e with | exp_return l0 _ e0 => @exp_return R (x :: l0) _ (wD x e0) | exp_if l0 _ e1 e2 e3 => @exp_if R (x :: l0) _ (wD x e1) (wP x e2) (wP x e3) -| exp_letin l0 l1 _ _ x0 H e1 e2 => @exp_letin R (x :: l0) (x :: l1) _ _ x0 _ (wP x e1) (wP _ e2) +| exp_letin l0 _ _ x0 e1 e2 => @exp_letin R (x :: l0) _ _ x0 (wP x e1) (wP _ e2) | exp_sample_bern l0 _ _ => _ | exp_score l0 e1 => _ | expWP l0 _ x e0 xl => _ @@ -1133,8 +1286,9 @@ end. Next Obligation. Admitted. Next Obligation. -move=> st l x e l0 l1 ? ? x0 H e1 e2 l0l ? ?. -rewrite H. +move=> st l x e l0 ? ? x0 e1 e2 l0l ? ?. +Admitted. +Next Obligation. Admitted. Next Obligation. Admitted. @@ -1173,9 +1327,9 @@ Declare Custom Entry expr. Notation "[ e ]" := e (e custom expr at level 5). Notation "x ':r'" := (@exp_real _ _ x%R) (in custom expr at level 1). Notation "'Ret' x" := (@exp_return _ _ _ x) (in custom expr at level 2). -Notation "% x" := (exp_var x _ erefl) (in custom expr at level 1). +Notation "% x # H" := (exp_var x _ H erefl) (in custom expr at level 1). Notation "( x , y )" := (exp_pair x y) (in custom expr at level 1). -Notation "'Let' x '<~' e 'In' f" := (exp_letin _ x erefl e f) +Notation "'Let' x '<~' e 'In' f" := (exp_letin x e f) (in custom expr at level 3, x constr, (* e custom expr at level 2, *) @@ -1189,17 +1343,24 @@ Notation "x" := x (in custom expr at level 0, x ident). Section letinC. Variable R : realType. -Lemma letinC12 v1 v2 t M : +(* Check [Let "x" <~ Ret {1}:r In Ret %{"x"}]. +Check [Let "x" <~ Ret {1}:r In + Let "y" <~ Ret {2}:r In + Ret (%{"x"} # {[:: ("y", sreal); ("x", sreal)]}, %{"y"} # {[:: ("y", sreal); ("x", sreal)]})]. *) + +(* Lemma letinC12 v1 v2 t M : let x := "x" in let y := "y" in + (* let s1 := [:: (y, sreal); (x, sreal)] in + let s2 := [:: (x, sreal); (y, sreal)] in *) measurable M -> [::] |- [Let x <~ Ret {1}:r In Let y <~ Ret {2}:r In - Ret (%x , %y)] : @expP R _ _ -P-> v1 + Ret (%x, %y)] : @expP R _ _ -P-> v1 -> [::] |- [Let y <~ Ret {2}:r In Let x <~ Ret {1}:r In - Ret (%x , %y)] -P-> v2 -> + Ret (%x, %y)] -P-> v2 -> v1 t M = v2 t M. Proof. set d := (x in (projT1 x).-measurable _). @@ -1251,7 +1412,7 @@ move=> x0 t0. apply/esym/evalP_uni_new. exact: er2. exact: er1. -Qed. +Qed. *) (* Lemma evalP_uni_new x r (u : R.-sfker munit ~> mR R) @@ -1264,9 +1425,6 @@ Qed. Ltac inj H := apply Classical_Prop.EqdepTheory.inj_pair2 in H. -Lemma eta1_axiom (l : context) (st : stype) (f : typei2 (sprod (map snd l)) -> typei2 st) x y t : f t = (@eta1 R (x, st) l st f) (y, t). -Admitted. - Lemma evalP_uniq_sub (l : context) (st : stype) e (u1 : R.-sfker _ ~> _) (* (u1' : R.-sfker prod_meas_obligation_2 prod_meas (existT [eta measurableType] _ (typei2 st)) _ ~> _) *) @@ -1277,66 +1435,42 @@ Lemma evalP_uniq_sub (l : context) (st : stype) e (u1 : R.-sfker _ ~> _) measurable M -> l |- e -P-> u1 -> (* evalP ([e1'] : expP [:: (y, st)] st) u1' -> *) - ((x, st) :: l)%SEQ |- (@expWP R l st (x, st) e xtl) : expP ((x, st) :: l)%SEQ st -P-> (eta_kernel (x, st) u1) -> - u1 t M = (eta_kernel (x, st) u1) (y0, t) M. + ((x, st) :: l)%SEQ |- (@expWP R l st (x, st) e xtl) : expP ((x, st) :: l)%SEQ st -P-> (keta1 u1) -> + u1 t M = (@keta1 R (x, st) _ _ u1) (y0, t) M. Proof. move=> x xNe1 mst. move=> hu. +by rewrite /keta1 /=. +(* apply: (@evalP_mut_ind R (fun (l : _) (st : stype) (e : expD l st) (f : projT2 (typei _) -> projT2 (typei st)) (mf : measurable_fun setT f) (h1 : l |- e -D-> f # mf) => - forall (xtl : (x, st) \notin l) M y0 t, ((x, st) :: l)%SEQ |- (@expWD R l st (x, st) e xtl) -D-> (@eta1 R (x, st) l st f) # (@meta1 R (x, st) l st f) -> f t = (@eta1 R (x, st) l st f) (y0, t) + forall (xtl : (x, st) \notin l) M y0 t, ((x, st) :: l)%SEQ |- (@expWD R l st (x, st) e xtl) -D-> (@eta1 R (x, st) l st f) # (meta1 mf) -> f t = (@eta1 R (x, st) l st f) (y0, t) ) (fun (l : _) (st : stype) (e : expP l st) (u : R.-sfker _ ~> projT2 (typei st)) (h1 : evalP e u) => - forall (xtl : (x, st) \notin l) M y0 t, ((x, st) :: l)%SEQ |- (@expWP R l st (x, st) e xtl) -P-> (@eta_kernel R (x, st) l st u) -> u t M = (@eta_kernel R (x, st) l st u) (y0, t) M) + forall (xtl : (x, st) \notin l) M y0 t, ((x, st) :: l)%SEQ |- (@expWP R l st (x, st) e xtl) -P-> (@keta1 R (x, st) l st u) -> u t M = (@keta1 R (x, st) l st u) (y0, t) M) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l st e); last exact: hu. move=> l' ? ? ? ?. -inversion 1. -apply: eta1_axiom. -move=> ? ? ? ? ? ?. -inversion 1. -apply: eta1_axiom. -move=> ? ? ? ? ? ?. -inversion 1. -apply: eta1_axiom. -move=> ??????????????????. -inversion 1. -apply: eta1_axiom. -move=> ????????. -inversion 1. -apply: eta1_axiom. -move=> ???????. -inversion 1. -apply: eta1_axiom. -move=> ???????????. -inversion 1. -apply: eta1_axiom. -move=> ??????????. -inversion 1. -apply: eta1_axiom. -move=> ?????????????. -inversion 1. -apply: eta1_axiom. -move=> ???????. -inversion 1. -Admitted. +by inversion 1.*) +Qed. -Lemma letinC u1 u1' u2 u2' v1 v2 t M (e1 : expP [::] sreal) e1' (e2 : expP [:: ("x", sreal)] sreal) e2' : +Lemma letinC (l : context) st v1 v2 t M (e1 : @expP R l st) (e2 : expP l st) +(Hx1 : "x" \in map fst ([:: ("y", st); ("x", st)] ++ l)%SEQ) +(Hy1 : "y" \in map fst ([:: ("y", st); ("x", st)] ++ l)%SEQ) +(Hx2 : "x" \in map fst ([:: ("x", st); ("y", st)] ++ l)%SEQ) +(Hy2 : "y" \in map fst ([:: ("x", st); ("y", st)] ++ l)%SEQ) +(xtl : ("x", st) \notin l) (ytl : ("y", st) \notin l) : let x := "x" in let y := "y" in "x" \notin free_varsP e2 -> "y" \notin free_varsP e1 -> measurable M -> - [::] |- e1 -P-> u1 -> - [:: ("y", sreal)] |- e1' -P-> u1' -> - [:: ("x", sreal)] |- e2 -P-> u2 -> - [::] |- e2' -P-> u2' -> - [::] |- [Let x <~ e1 In - Let y <~ e2 In - Ret (%x , %y)] : @expP R _ _ -P-> v1 + l |- [Let x <~ e1 In + Let y <~ {(@expWP R l st (x, st) e2 xtl)} In + Ret (%x # Hx1, %y # Hy1)] : @expP R _ _ -P-> v1 -> - [::] |- [Let y <~ e2' In - Let x <~ e1' In - Ret (%x , %y)] -P-> v2 -> + l |- [Let y <~ e2 In + Let x <~ {(@expWP R l st (y, st) e1 ytl)} In + Ret (%x # Hx2, %y # Hy2)] -P-> v2 -> v1 t M = v2 t M. Proof. rewrite /=. From 7bea44d30eacc9f184edcdb626fd71247d403867 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 19 Apr 2023 08:51:25 +0900 Subject: [PATCH 49/54] using canonical structures and typeclasses to type check pgm1 --- theories/lang_syntax.v | 1067 +++++++++++++++++++++------------------- 1 file changed, 561 insertions(+), 506 deletions(-) diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index 2b9d0a4021..2aed026675 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -36,23 +36,13 @@ Canonical string_eqType := EqType string string_eqMixin. End string_eq. -Local Obligation Tactic := idtac. -Program Fixpoint prod_meas (l : list {d & measurableType d}) : {d & measurableType d} := +Fixpoint prod_meas (l : list {d & measurableType d}) + : {d & measurableType d} := match l with - | [::] => existT measurableType _ munit - | h :: t => - let t' := prod_meas t in - existT _ _ _ + | [::] => existT measurableType _ munit + | h :: t => let t' := prod_meas t in + existT _ _ [the measurableType _ of (projT2 h * projT2 t')%type] end. -Next Obligation. -move=> ? l h t htl t'. -exact: (measure_prod_display (projT1 h, projT1 t')). -Defined. -Next Obligation. -move=> ? l h t htl t'. -simpl. -exact: [the measurableType _ of (projT2 h * projT2 t')%type]. -Defined. Inductive stype := | sunit : stype @@ -70,42 +60,29 @@ Fixpoint typei (t : stype) : {d & measurableType d} := | sbool => existT _ _ mbool | sreal => existT _ _ (mR R) | spair A B => existT _ _ - [the measurableType ((projT1 (typei A),projT1 (typei B)).-prod)%mdisp of (projT2 (typei A) * projT2 (typei B))%type] + [the measurableType ((projT1 (typei A), projT1 (typei B)).-prod)%mdisp of + (projT2 (typei A) * projT2 (typei B))%type] | sprob A => existT _ _ (pprobability (projT2 (typei A)) R) - | sprod l => prod_meas (map typei l) + | sprod l => prod_meas (map typei l) end. -Definition typei2 (t : stype) := projT2 (typei t). +Definition typei2 t := projT2 (typei t). End type_syntax. Arguments typei {R}. Arguments typei2 {R}. -(*Axiom string_lt : string -> string -> bool. - -Axiom ordered : seq string -> bool.*) - -Section context. Definition context := seq (string * stype)%type. -(*Inductive context := - mkContext (k : seq (string * stype)%type) - of ordered (map fst k). -Definition add_binding (l : context) - (x : (string * stype)%type) : context. -Admitted. -Definition get_seq (l : context) := - let: mkContext k _ := l in k.*) -End context. Section expr. Variables (R : realType). -Fixpoint assoc_get {A : eqType} {B : Type} (a : A) (l : seq (A * B)) : option B := +(*Fixpoint assoc_get {A : eqType} {B : Type} (a : A) (l : seq (A * B)) : option B := match l with | nil => None | h :: t => if h.1 == a then Some h.2 else assoc_get a t - end. + end.*) Inductive expD : context -> stype -> Type := | expWD l st x (e : expD l st) : x \notin l -> expD (x :: l) st @@ -113,28 +90,21 @@ Inductive expD : context -> stype -> Type := | exp_bool l : bool -> expD l sbool | exp_real l : R -> expD l sreal | exp_pair l t1 t2 : expD l t1 -> expD l t2 -> expD l (spair t1 t2) -| exp_var (l : context) x t : - x \in map fst l -> - (* assoc_get x l = Some t -> *) - t = nth sunit (map snd l) (seq.index x (map fst l)) -> - expD l t -| exp_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : - expD l (sprob sbool) +| exp_var (l : context) x t : (* x \in map fst l -> *) + t = nth sunit (map snd l) (seq.index x (map fst l)) -> + expD l t +| exp_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : expD l (sprob sbool) | exp_poisson l : nat -> expD l sreal -> expD l sreal | exp_norm l t : expP l t -> expD l (sprob t) - with expP : context -> stype -> Type := | expWP l st x (e : expP l st) : x \notin l -> expP (x :: l) st | exp_if l t : expD l sbool -> expP l t -> expP l t -> expP l t -| exp_letin l t1 t2 (x : string) : -(* l' = (x, t1) :: l -> *) - expP l t1 -> expP ((x, t1) :: l) t2 -> expP l t2 +| exp_letin l t1 t2 (x : string) : + expP l t1 -> expP ((x, t1) :: l) t2 -> expP l t2 (* | exp_sample : forall t l, expD (sprob t) l -> expP t l *) -| exp_sample_bern l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : - expP l sbool +| exp_sample_bern l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : expP l sbool | exp_score l : expD l sreal -> expP l sunit -| exp_return l t : expD l t -> expP l t -. +| exp_return l t : expD l t -> expP l t. End expr. @@ -157,7 +127,35 @@ Arguments exp_return {R l _}. Section eval. Variables (R : realType). -Definition varof (l : seq (string * stype)%type) (i : nat) (li : (i < size l)%nat) : +Fixpoint varof (l : seq (string * stype)) (i : nat) : + projT2 (typei (sprod (map snd l))) -> projT2 (@typei R (nth sunit (map snd l) i)) := + match + l return (projT2 (typei (sprod (map snd l))) -> projT2 (typei (nth sunit (map snd l) i))) + with + | [::] => match i with | O => id | j.+1 => id end + | _ :: _ => match i with + | O => fst + | j.+1 => fun H => varof j H.2 + end + end. + +(*Definition varof (l : seq (string * stype)%type) (i : nat) : + projT2 (@typei R (sprod (map snd l))) -> + projT2 (@typei R (nth sunit (map snd l) i)). +revert l i. +fix H 1. +destruct l. + by destruct i. +destruct i. +simpl. +intro K. +exact: K.1. +simpl. +move=> K. +refine (H _ _ K.2). +Defined.*) + +(*Definition varof (l : seq (string * stype)%type) (i : nat) (li : (i < size l)%nat) : projT2 (@typei R (sprod (map snd l))) -> projT2 (@typei R (nth sunit (map snd l) i)). revert l i li. @@ -173,25 +171,31 @@ move=> il. move=> K. refine (H _ _ _ K.2). exact il. -Defined. +Defined.*) -Lemma false_index_size (x : string) (l : seq (string * stype)%type) (H : x \in map fst l) : +(*Lemma false_index_size (x : string) (l : seq (string * stype)%type) (H : x \in map fst l) : (seq.index x (map fst l) < size l)%nat. -Proof. by rewrite -(size_map fst) index_mem. Qed. +Proof. by rewrite -(size_map fst) index_mem. Qed.*) -Lemma mvarof (l : seq (string * stype)%type) (i : nat) (li : (i < size l)%nat) : - measurable_fun setT (@varof l i li). +(*Lemma mvarof (l : seq (string * stype)%type) (i : nat) (*(li : (i < size l)%nat)*) : + measurable_fun setT (@varof l i (*li*)). Proof. -revert l i li. +revert l i (*li*). induction l. by destruct i. destruct i. -simpl => _. intro K. exact: measurable_fun_fst. -move=> il K. -apply: (measurable_funT_comp (IHl _ _) (@measurable_fun_snd _ _ _ _)). +move=> K. +apply: (measurable_funT_comp (IHl _) (@measurable_fun_snd _ _ _ _)). apply: K. +Qed.*) + +Lemma mvarof (l : seq (string * stype)%type) (i : nat) : + measurable_fun setT (@varof l i). +Proof. +elim: l i => //= h t ih [|j]; first exact: measurable_fun_fst. +exact: (measurable_funT_comp (ih _) (@measurable_fun_snd _ _ _ _)). Qed. Lemma eq_probability d (Y : measurableType d) (m1 m2 : probability Y R) : @@ -266,21 +270,21 @@ End measurable_fun_normalize. | exp_var l x => nth sunit (map snd l) (seq.index x (map fst l)) end. *) -(* Fixpoint execD (l : context) (t : stype) (e : expD t) +(* Fixpoint execD (l : context) (t : stype) (e : expD t) : {f : @typei2 R (sprod (map snd l)) -> typei2 (denoteType e) & measurable_fun _ f} := match e return {f : @typei2 R (sprod (map snd l)) -> typei2 (denoteType e) & measurable_fun _ f} with | exp_unit => existT _ (cst tt) ktt | exp_bool b => existT _ (cst b) (kb b) | exp_real r => existT _ (cst r) (kr r) - | exp_pair _ _ e1 e2 => + | exp_pair _ _ e1 e2 => existT _ _ (@measurable_fun_pair _ _ _ _ _ _ _ _ (projT2 (execD l e1)) (projT2 (execD l e2))) | exp_var l x => forall (H : x \in (map fst l)), existT _ (@varof l (seq.index x (map fst l)) (false_index_size H)) (@mvarof l (seq.index x (map fst l)) (false_index_size H)) - end. *) + end. *) Definition eta1 x (l : context) t - (f : projT2 (@typei R (sprod [seq i.2 | i <- l])) -> projT2 (@typei R t)) : - projT2 (@typei R (sprod (map snd (x :: l)))) -> projT2 (@typei R t) := f \o snd. + (f : projT2 (@typei R (sprod (map snd l))) -> projT2 (@typei R t)) : + projT2 (typei (sprod (map snd (x :: l)))) -> projT2 (@typei R t) := f \o snd. Lemma meta1 x (l : context) t (f : projT2 (@typei R (sprod (map snd l))) -> projT2 (@typei R t)) @@ -290,8 +294,8 @@ Proof. by apply: (measurable_funT_comp mf); exact: measurable_fun_snd. Qed. Definition keta1 (x : string * stype) (l : context) t (k : R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t) : - (@typei2 R (sprod (map snd (x :: l)))) -> {measure set @typei2 R t -> \bar R} := -k \o snd. + (@typei2 R (sprod (map snd (x :: l)))) -> {measure set @typei2 R t -> \bar R} + := k \o snd. Section kernel_eta1. Variables (x : string * stype) (l : context) (t : stype) @@ -318,12 +322,11 @@ Let sk : exists2 s : (R.-ker (@typei2 R (sprod (map snd (x :: l)))) ~> @typei2 R forall x0 U, measurable U -> (@keta1 x l t k) x0 U = kseries s x0 U . Proof. have [s hs] := sfinite k. -exists (fun n => (@keta1 x l t (s n))). -move=> n. -have [M hM] := measure_uub (s n). -exists M => x0. -rewrite /keta1/=. -exact: hM. +exists (fun n => @keta1 x l t (s n)). + move=> n. + have [M hM] := measure_uub (s n). + exists M => x0. + exact: hM. move=> x0 U mU. by rewrite /keta1/= hs. Qed. @@ -341,7 +344,6 @@ Let uub : measure_fam_uub (@keta1 x l t k). Proof. have [M hM] := measure_uub k. exists M => x0. -rewrite /keta1/=. exact: hM. Qed. @@ -351,7 +353,7 @@ End fkernel_eta1. Fixpoint free_varsD l t (e : @expD R l t) : seq string := match e with - | exp_var _ x _ _ _ => [:: x] + | exp_var _ x (*_*) _ _ => [:: x] | exp_poisson _ _ e => free_varsD e | exp_pair _ _ _ e1 e2 => free_varsD e1 ++ free_varsD e2 | exp_unit _ => [::] @@ -387,20 +389,20 @@ Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) l |- e1 -D-> f1 # mf1 -> (* (f1 : projT2 (typei G) -> projT2 (typei A)) *) l |- e2 -D-> f2 # mf2 -> (* (f2 : projT2 (typei G) -> projT2 (typei B)) *) - l |- exp_pair e1 e2 -D-> fun x => (f1 x, f2 x) # - (@measurable_fun_pair _ _ _ (projT2 (typei G)) (projT2 (typei A)) + l |- exp_pair e1 e2 -D-> fun x => (f1 x, f2 x) # + (@measurable_fun_pair _ _ _ (projT2 (typei G)) (projT2 (typei A)) (projT2 (typei B)) f1 f2 mf1 mf2) - (* - ((fun x : projT2 (typei G) => (f1 x, f2 x)) - : projT2 (typei G) -> projT2 (typei (spair A B))) + (* + ((fun x : projT2 (typei G) => (f1 x, f2 x)) + : projT2 (typei G) -> projT2 (typei (spair A B))) *) -| E_var (l : context) (x : string) (H : x \in map fst l) +| E_var (l : context) (x : string) (*(H : x \in map fst l) *) (* (H' : assoc_get x l = Some _) *) : let i := seq.index x (map fst l) in - l |- exp_var x _ H erefl -D-> @varof l i (false_index_size H) # - @mvarof l i (false_index_size H) + l |- exp_var x _ erefl -D-> @varof l i (*(false_index_size H)*) # + @mvarof l i (*(false_index_size H)*) | E_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : l |- exp_bernoulli r r1 -D-> @@ -447,7 +449,7 @@ with evalP : forall (l : context) (T : stype), l |- e -D-> f # mf -> l |- exp_return e : expP l T -P-> ret mf -| E_letin (l : context) (G := sprod (map snd l)) (t1 t2 : stype) +| E_letin (l : context) (G := sprod (map snd l)) (t1 t2 : stype) (x : string) (e1 : expP l t1) (e2 : expP ((x, t1) :: l) t2) (k1 : R.-sfker projT2 (typei G) ~> projT2 (typei t1)) (k2 : R.-sfker (typei2 (spair t1 G)) ~> projT2 (typei t2)) : @@ -475,284 +477,265 @@ with evalP_mut_ind := Induction for evalP Sort Prop. Scheme expD_mut_ind := Induction for expD Sort Prop with expP_mut_ind := Induction for expP Sort Prop. -Lemma evalD_uniq (l : context) (G := sprod (map snd l)) (t : stype) - (e : expD l t) (u v : projT2 (typei G) -> projT2 (typei t)) +Lemma evalD_uniq (l : context) (G := sprod (map snd l)) (t : stype) + (e : expD l t) (u v : projT2 (typei G) -> projT2 (typei t)) (mu : measurable_fun _ u) (mv : measurable_fun _ v) : @evalD R l t e u mu -> evalD e mv -> u = v. Proof. move=> hu. apply: (@evalD_mut_ind R - (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expD l t) - (f : projT2 (typei G) -> projT2 (typei t)) (mf : measurable_fun setT f) - (h1 : evalD e mf) => forall (v : projT2 (typei G) -> projT2 (typei t)) (mv : measurable_fun setT v), evalD e mv -> f = v) - (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) + (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expD l t) + (f : projT2 (typei G) -> projT2 (typei t)) (mf : measurable_fun setT f) + (h1 : evalD e mf) => forall (v : projT2 (typei G) -> projT2 (typei t)) + (mv : measurable_fun setT v), evalD e mv -> f = v) + (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) (u : R.-sfker projT2 (typei G) ~> projT2 (typei t)) (h1 : evalP e u) => - forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), + forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), evalP e v -> u = v) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e); last exact: hu. -- -move=> l' {}v {}mv. -inversion 1. -by do 2 inj H3. -- -move=> l' b {}v {}mv. -inversion 1. -by do 2 inj H3. -- -move=> l' r {}v {}mv. -inversion 1. -subst. -by do 2 inj H3. -- (* pair *) -move=> l' G0 A B e1 f1 mf1 e2 f2 mf2 ev1 IH1 ev2 IH2 {}v {}mv H. -simple inversion H => //. -injection H3 => ? ?; subst A0 B0 l0. -inj H4. -injection H4 => He1 He2. -do 2 inj He1. -do 2 inj He2. -subst e0 e3. -do 2 inj H5. -move=> e1f0 e2f3. -by rewrite (IH1 _ _ e1f0) (IH2 _ _ e2f3). -- (* var *) -move=> l' x H n {}v {}mv. -inversion 1. -do 2 inj H9. -by have -> : (H = H7) by exact: Prop_irrelevance. -- (* bernoulli *) -move=> l' r r1 {}v {}mv. -inversion 1. -subst. -do 2 inj H3. -subst. -by have -> : (r1 = r3) by exact: Prop_irrelevance. -- (* poisson *) -move=> l' k e0 f mf ev IH {}v {}mv. -inversion 1. -subst. -inj H2. -do 2 inj H4. -subst. -by rewrite (IH _ _ H3). -- (* norm *) -move=> l' A e0 k ev IH {}v {}mv. -inversion 1. -do 2 inj H2. -do 2 inj H4. -subst. -by rewrite (IH _ H3). -- (* W *) -move=> l' A e0 x xl f mf ev IH {}v {}mv H. -simple inversion H => // ev0. -subst. -case: H1 => ? ?. -subst. -do 2 inj H3. -do 2 inj H4. -rewrite /eta1. -subst. -case: H3=> H4. -do 2 inj H4. -subst. -by rewrite (IH _ _ ev0). -- (* sample *) -move=> l' r r1 p. -inversion 1. -(* do 2 inj H0. *) -do 2 inj H3. -subst. -by have -> : (r1 = r3) by apply: Prop_irrelevance. -- (* if *) -move=> l' G0 e0 f1 mf1 e2 k2 e3 k3 ev1 IH1 ev2 IH2 ev3 IH3 k. -inversion 1. -inj H0. -do 2 inj H1. -do 2 inj H2. -subst. -do 2 inj H5. -have ? := IH1 _ _ H6. -subst f1. -have -> : (mf1 = mf) by exact: Prop_irrelevance. -by rewrite (IH2 _ H7) (IH3 _ H8). -- (* score *) -move=> l' G0 e0 f mf ev IH k H. -simple inversion H => // ev0. -subst. -do 2 inj H4. -do 2 inj H3. -injection H3 => H5. -inj H5. -subst. -have ? := IH _ _ ev0. -subst f0. -by have -> : (mf = mf0) by exact: Prop_irrelevance. -- (* return *) -move=> l' A e0 f mf ev IH k. -inversion 1. -subst. -do 2 inj H5. -do 2 inj H7. -subst. -have ? := IH _ _ H3. -subst f1. -by have -> : (mf = mf1) by exact: Prop_irrelevance. -- (* letin *) -move=> l' G0 A B x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. -inversion 1. -subst. -do 2 inj H10. -do 2 inj H7. -do 4 inj H8. -subst. -by rewrite (IH1 _ H4) (IH2 _ H11). -move=> l' A e0 x xl k1 ev IH {}k. -inversion 1. -subst A. -do 2 inj H4. -do 2 inj H5. -subst. -by rewrite (IH _ H3). +- move=> l' {}v {}mv. + inversion 1. + by do 2 inj H3. +- move=> l' b {}v {}mv. + inversion 1. + by do 2 inj H3. +- move=> l' r {}v {}mv. + inversion 1. + subst. + by do 2 inj H3. +- (* pair *) move=> l' G0 A B e1 f1 mf1 e2 f2 mf2 ev1 IH1 ev2 IH2 {}v {}mv H. + simple inversion H => //. + injection H3 => ? ?; subst A0 B0 l0. + inj H4. + injection H4 => He1 He2. + do 2 inj He1. + do 2 inj He2. + subst e0 e3. + do 2 inj H5. + move=> e1f0 e2f3. + by rewrite (IH1 _ _ e1f0) (IH2 _ _ e2f3). +- (* var *) move=> l' x (*H*) n {}v {}mv. + inversion 1. + do 2 inj H7. + do 2 inj H6. + done. + (*by have -> : (n = H0) by exact: Prop_irrelevance.*) +- (* bernoulli *) move=> l' r r1 {}v {}mv. + inversion 1. + subst. + do 2 inj H3. + subst. + by have -> : (r1 = r3) by exact: Prop_irrelevance. +- (* poisson *) move=> l' k e0 f mf ev IH {}v {}mv. + inversion 1. + subst. + inj H2. + do 2 inj H4. + subst. + by rewrite (IH _ _ H3). +- (* norm *) move=> l' A e0 k ev IH {}v {}mv. + inversion 1. + do 2 inj H2. + do 2 inj H4. + subst. + by rewrite (IH _ H3). +- (* W *) move=> l' A e0 x xl f mf ev IH {}v {}mv H. + simple inversion H => // ev0. + subst. + case: H1 => ? ?. + subst. + do 2 inj H3. + do 2 inj H4. + rewrite /eta1. + subst. + case: H3=> H4. + do 2 inj H4. + subst. + by rewrite (IH _ _ ev0). +- (* sample *) move=> l' r r1 p. + inversion 1. + (* do 2 inj H0. *) + do 2 inj H3. + subst. + by have -> : (r1 = r3) by apply: Prop_irrelevance. +- (* if *) move=> l' G0 e0 f1 mf1 e2 k2 e3 k3 ev1 IH1 ev2 IH2 ev3 IH3 k. + inversion 1. + inj H0. + do 2 inj H1. + do 2 inj H2. + subst. + do 2 inj H5. + have ? := IH1 _ _ H6. + subst f1. + have -> : (mf1 = mf) by exact: Prop_irrelevance. + by rewrite (IH2 _ H7) (IH3 _ H8). +- (* score *) move=> l' G0 e0 f mf ev IH k H. + simple inversion H => // ev0. + subst. + do 2 inj H4. + do 2 inj H3. + injection H3 => H5. + inj H5. + subst. + have ? := IH _ _ ev0. + subst f0. + by have -> : (mf = mf0) by exact: Prop_irrelevance. +- (* return *) move=> l' A e0 f mf ev IH k. + inversion 1. + subst. + do 2 inj H5. + do 2 inj H7. + subst. + have ? := IH _ _ H3. + subst f1. + by have -> : (mf = mf1) by exact: Prop_irrelevance. +- (* letin *) move=> l' G0 A B x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. + inversion 1. + subst. + do 2 inj H10. + do 2 inj H7. + do 4 inj H8. + subst. + by rewrite (IH1 _ H4) (IH2 _ H11). +- move=> l' A e0 x xl k1 ev IH {}k. + inversion 1. + subst A. + do 2 inj H4. + do 2 inj H5. + subst. + by rewrite (IH _ H3). Qed. (* TODO: factorize proof *) -Lemma evalP_uniq (l : context) (t : stype) (e : expP l t) +Lemma evalP_uniq (l : context) (t : stype) (e : expP l t) (u v : R.-sfker typei2 (sprod (map snd l)) ~> typei2 t) : evalP e u -> evalP e v -> u = v. Proof. move=> hu. apply: (@evalP_mut_ind R - (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expD l t) (f : projT2 (typei G) -> projT2 (typei t)) (mf : measurable_fun setT f) (h1 : evalD e mf) => - forall (v : projT2 (typei G) -> projT2 (typei t)) (mv : measurable_fun setT v), evalD e mv -> f = v) - (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) (u : R.-sfker projT2 (typei G) ~> projT2 (typei t)) (h1 : evalP e u) => - forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), evalP e v -> u = v) + (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expD l t) + (f : projT2 (typei G) -> projT2 (typei t)) + (mf : measurable_fun setT f) (h1 : evalD e mf) => + forall (v : projT2 (typei G) -> projT2 (typei t)) (mv : measurable_fun setT v), + evalD e mv -> f = v) + (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) + (u : R.-sfker projT2 (typei G) ~> projT2 (typei t)) (h1 : evalP e u) => + forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), + evalP e v -> u = v) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e); last exact: hu. -- -move=> l' {}v {}mv. -inversion 1. -by do 2 inj H3. -- -move=> l' b {}v {}mv. -inversion 1. -by do 2 inj H3. -- -move=> l' r {}v {}mv. -inversion 1. -subst. -by do 2 inj H3. -- (* pair *) -move=> l' G0 A B e1 f1 mf1 e2 f2 mf2 ev1 IH1 ev2 IH2 {}v {}mv H. -simple inversion H => //. -injection H3 => ? ?; subst A0 B0 l0. -inj H4. -injection H4 => He1 He2. -do 2 inj He1. -do 2 inj He2. -subst e0 e3. -do 2 inj H5. -move=> e1f0 e2f3. -by rewrite (IH1 _ _ e1f0) (IH2 _ _ e2f3). -- (* var *) -move=> l' x H n {}v {}mv. -inversion 1. -do 2 inj H9. -by have -> : (H = H7) by exact: Prop_irrelevance. -- (* bernoulli *) -move=> l' r r1 {}v {}mv. -inversion 1. -subst. -do 2 inj H3. -subst. -by have -> : (r1 = r3) by exact: Prop_irrelevance. -- (* poisson *) -move=> l' k e0 f mf ev IH {}v {}mv. -inversion 1. -subst. -inj H2. -do 2 inj H4; clear H5. -subst. -by rewrite (IH _ _ H3). -- (* norm *) -move=> l' A e0 k ev IH {}v {}mv. -inversion 1. -do 2 inj H2. -do 2 inj H4. -subst. -by rewrite (IH _ H3). -- (* W *) -move=> l' A e0 x xl f mf ev IH {}v {}mv H. -simple inversion H => // ev0. -subst. -case: H1 => ? ?. -subst. -do 2 inj H3. -do 2 inj H4. -rewrite /eta1. -subst. -case: H3=> H4. -do 2 inj H4. -subst. -by rewrite (IH _ _ ev0). -- (* sample *) -move=> l' r r1 ev. -inversion 1. -(* do 2 inj H0. *) -do 2 inj H3. -subst. -by have -> : (r1 = r3) by exact: Prop_irrelevance. -- (* if *) -move=> l' G0 e0 f1 mf1 e2 k2 e3 k3 ev1 IH1 ev2 IH2 ev3 IH3 k. -inversion 1. -inj H0. -do 2 inj H1. -do 2 inj H2. -subst. -do 2 inj H5. -have ? := IH1 _ _ H6. -subst f1. -have -> : (mf1 = mf) by exact: Prop_irrelevance. -by rewrite (IH2 _ H7) (IH3 _ H8). -- (* score *) -move=> l' G0 e0 f mf ev IH k H. -simple inversion H => // ev0. -subst. -do 2 inj H4. -do 2 inj H3. -injection H3 => H5. -inj H5. -subst. -have ? := IH _ _ ev0. -subst f0. -by have -> : (mf = mf0) by exact: Prop_irrelevance. -- (* return *) -move=> l' A e0 f mf ev IH k. -inversion 1. -subst. -do 2 inj H5. -do 2 inj H7. -subst. -have ? := IH _ _ H3. -subst f1. -by have -> : (mf = mf1) by exact: Prop_irrelevance. -- (* letin *) -move=> l' G0 A B x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. -inversion 1. -subst. -do 2 inj H10. -do 2 inj H7. -do 4 inj H8. -subst. -by rewrite (IH1 _ H4) (IH2 _ H11). -move=> l' A e0 x xl k1 ev IH {}k. -inversion 1. -subst A. -do 2 inj H4. -do 2 inj H5. -subst. -by rewrite (IH _ H3). +- move=> l' {}v {}mv. + inversion 1. + by do 2 inj H3. +- move=> l' b {}v {}mv. + inversion 1. + by do 2 inj H3. +- move=> l' r {}v {}mv. + inversion 1. + subst. + by do 2 inj H3. +- (* pair *) move=> l' G0 A B e1 f1 mf1 e2 f2 mf2 ev1 IH1 ev2 IH2 {}v {}mv H. + simple inversion H => //. + injection H3 => ? ?; subst A0 B0 l0. + inj H4. + injection H4 => He1 He2. + do 2 inj He1. + do 2 inj He2. + subst e0 e3. + do 2 inj H5. + move=> e1f0 e2f3. + by rewrite (IH1 _ _ e1f0) (IH2 _ _ e2f3). +- (* var *) move=> l' x (*H*) n {}v {}mv. + inversion 1. + do 2 inj H7. + do 2 inj H6. + done. + (*by have -> : (n = H0) by exact: Prop_irrelevance.*) +- (* bernoulli *) move=> l' r r1 {}v {}mv. + inversion 1. + subst. + do 2 inj H3. + subst. + by have -> : (r1 = r3) by exact: Prop_irrelevance. +- (* poisson *) move=> l' k e0 f mf ev IH {}v {}mv. + inversion 1. + subst. + inj H2. + do 2 inj H4; clear H5. + subst. + by rewrite (IH _ _ H3). +- (* norm *) move=> l' A e0 k ev IH {}v {}mv. + inversion 1. + do 2 inj H2. + do 2 inj H4. + subst. + by rewrite (IH _ H3). +- (* W *) move=> l' A e0 x xl f mf ev IH {}v {}mv H. + simple inversion H => // ev0. + subst. + case: H1 => ? ?. + subst. + do 2 inj H3. + do 2 inj H4. + rewrite /eta1. + subst. + case: H3=> H4. + do 2 inj H4. + subst. + by rewrite (IH _ _ ev0). +- (* sample *) move=> l' r r1 ev. + inversion 1. + (* do 2 inj H0. *) + do 2 inj H3. + subst. + by have -> : r1 = r3 by exact: Prop_irrelevance. +- (* if *) move=> l' G0 e0 f1 mf1 e2 k2 e3 k3 ev1 IH1 ev2 IH2 ev3 IH3 k. + inversion 1. + inj H0. + do 2 inj H1. + do 2 inj H2. + subst. + do 2 inj H5. + have ? := IH1 _ _ H6. + subst f1. + have -> : mf1 = mf by exact: Prop_irrelevance. + by rewrite (IH2 _ H7) (IH3 _ H8). +- (* score *) move=> l' G0 e0 f mf ev IH k H. + simple inversion H => // ev0. + subst. + do 2 inj H4. + do 2 inj H3. + injection H3 => H5. + inj H5. + subst. + have ? := IH _ _ ev0. + subst f0. + by have -> : mf = mf0 by exact: Prop_irrelevance. +- (* return *) move=> l' A e0 f mf ev IH k. + inversion 1. + subst. + do 2 inj H5. + do 2 inj H7. + subst. + have ? := IH _ _ H3. + subst f1. + by have -> : mf = mf1 by exact: Prop_irrelevance. +- (* letin *) move=> l' G0 A B x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. + inversion 1. + subst. + do 2 inj H10. + do 2 inj H7. + do 4 inj H8. + subst. + by rewrite (IH1 _ H4) (IH2 _ H11). +- move=> l' A e0 x xl k1 ev IH {}k. + inversion 1. + subst A. + do 2 inj H4. + do 2 inj H5. + subst. + by rewrite (IH _ H3). Qed. -Lemma evalD_full (l : context) (t : stype) : - forall e, +Lemma evalD_full (l : context) (t : stype) : forall e, (* {subset (free_varsD e) <= map fst l} -> *) exists f (mf : measurable_fun _ f), @evalD R l t e f mf. Proof. @@ -764,67 +747,65 @@ apply: (@expD_mut_ind R (fun (l : context) (t : stype) (e : expP l t) => (* {subset (free_varsP e) <= map fst l} -> *) exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). -move=> l0 st x e1 H1 xl0. -destruct H1 as [f [mf]]. -exists (eta1 f). -exists (meta1 mf). -exact/E_WD. -do 2 eexists; apply/E_unit. -do 2 eexists; apply/E_bool. -do 2 eexists; apply/E_real. -move=> l0 t1 t2 e1 H1 e2 H2. -destruct H1 as [f1 [mf1]]. -destruct H2 as [f2 [mf2]]. -exists (fun x => (f1 x, f2 x)). -eexists; exact: E_pair. -move=> l0 x t0 xl0 t0E. -subst t0. -(* exists (@varof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). -exists (@mvarof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). -by apply/E_var. *) -admit. -move=> r r1. -eexists. -eexists. -exact: E_bernoulli. -move=> l0 k e0 H. -destruct H as [f [mf]]. -exists (poisson k \o f). -exists (measurable_funT_comp (mpoisson k) mf). -exact: E_poisson. -move=> l0 t0 e0 H. -destruct H as [k]. -exists (normalize k point). -exists (measurable_fun_normalize k). -exact: E_norm. -move=> l0 st x e1 H1 xl0. -destruct H1 as [k]. -exists (@keta1 R x l0 st k). -exact/E_WP. -move=> l0 t0 e1 H1 e2 H2 e3 H3. -destruct H1 as [f [mf]]. -destruct H2 as [k2]. -destruct H3 as [k3]. -exists (ite mf k2 k3). -exact: E_ifP. -move=> l0 t1 t2 x e1 H1 e2 H2. -destruct H1 as [k1 ev1]. -destruct H2 as [k2 ev2]. -subst. -exists (letin' k1 k2). -exact: E_letin. -move=> l0 r r1. -exists (sample [the pprobability _ _ of bernoulli r1]). -exact: E_sample. -move=> l0 e0 H. -destruct H as [f [mf]]. -exists (score mf). -exact: E_score. -move=> l0 t0 e0 H. -destruct H as [f [mf]]. -exists (ret mf). -exact: E_return. -Admitted. +- move=> l0 st x e1 H1 xl0. + destruct H1 as [f [mf]]. + exists (eta1 f). + exists (meta1 mf). + exact/E_WD. +- by do 2 eexists; apply/E_unit. +- by do 2 eexists; apply/E_bool. +- by do 2 eexists; apply/E_real. +- move=> l0 t1 t2 e1 H1 e2 H2. + destruct H1 as [f1 [mf1]]. + destruct H2 as [f2 [mf2]]. + exists (fun x => (f1 x, f2 x)). + eexists. + exact: E_pair. +- move=> l0 x t0 (*xl0*) t0E. + subst t0. + eexists. + eexists. + by apply/E_var. +- move=> r r1. + eexists. + eexists. + exact: E_bernoulli. +- move=> l0 k e0 H. + destruct H as [f [mf]]. + exists (poisson k \o f). + exists (measurable_funT_comp (mpoisson k) mf). + exact: E_poisson. +- move=> l0 t0 e0 H. + destruct H as [k]. + exists (normalize k point). + exists (measurable_fun_normalize k). + exact: E_norm. +- move=> l0 st x e1 H1 xl0. + destruct H1 as [k]. + exists (@keta1 R x l0 st k). + exact/E_WP. +- move=> l0 t0 e1 H1 e2 H2 e3 H3. + destruct H1 as [f [mf]]. + destruct H2 as [k2]. + destruct H3 as [k3]. + exists (ite mf k2 k3). + exact: E_ifP. +- move=> l0 t1 t2 x e1 H1 e2 H2. + destruct H1 as [k1 ev1]. + destruct H2 as [k2 ev2]. + subst. + exists (letin' k1 k2). + exact: E_letin. +- move=> l0 r r1. + exists (sample [the pprobability _ _ of bernoulli r1]). + exact: E_sample. +- move=> l0 e0 [f [mf f_mf]]. + exists (score mf). + exact: E_score. +- move=> l0 t0 e0 [f [mf f_mf]]. + exists (ret mf). + exact: E_return. +Qed. (* move=> l0 st x e1 H1 xl0. have h1 : {subset free_varsD e1 <= map fst (x :: l0)}. @@ -970,12 +951,10 @@ exists (ret mf). exact: E_return. Admitted. *) -Lemma evalP_full (l : context) (t : stype) : - forall e, +Lemma evalP_full (l : context) (t : stype) e : (* {subset (free_varsP e) <= map fst l} -> *) exists (k : R.-sfker _ ~> _), @evalP R l t e k. Proof. -move=> e. apply: (@expP_mut_ind R (fun (l : context) (t : stype) (e : expD l t) => (* {subset (free_varsD e) <= map fst l} -> *) @@ -983,67 +962,66 @@ apply: (@expP_mut_ind R (fun (l : context) (t : stype) (e : expP l t) => (* {subset (free_varsP e) <= map fst l} -> *) exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). -move=> l0 st x e1 H1 xl0. -destruct H1 as [f [mf]]. -exists (eta1 f). -exists (meta1 mf). -exact/E_WD. -do 2 eexists; apply/E_unit. -do 2 eexists; apply/E_bool. -do 2 eexists; apply/E_real. -move=> l0 t1 t2 e1 H1 e2 H2. -destruct H1 as [f1 [mf1]]. -destruct H2 as [f2 [mf2]]. -exists (fun x => (f1 x, f2 x)). -eexists; exact: E_pair. -move=> l0 x t0 xl0 t0E. -subst t0. -(* exists (@varof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). -exists (@mvarof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). -by apply/E_var. *) -admit. -move=> r r1. -eexists. -eexists. -exact: E_bernoulli. -move=> l0 k e0 H. -destruct H as [f [mf]]. -exists (poisson k \o f). -exists (measurable_funT_comp (mpoisson k) mf). -exact: E_poisson. -move=> l0 t0 e0 H. -destruct H as [k]. -exists (normalize k point). -exists (measurable_fun_normalize k). -exact: E_norm. -move=> l0 st x e1 H1 xl0. -destruct H1 as [k]. -exists (@keta1 R x l0 st k). -exact/E_WP. -move=> l0 t0 e1 H1 e2 H2 e3 H3. -destruct H1 as [f [mf]]. -destruct H2 as [k2]. -destruct H3 as [k3]. -exists (ite mf k2 k3). -exact: E_ifP. -move=> l0 t1 t2 x e1 H1 e2 H2. -destruct H1 as [k1 ev1]. -destruct H2 as [k2 ev2]. -subst. -exists (letin' k1 k2). -exact: E_letin. -move=> l0 r r1. -exists (sample [the pprobability _ _ of bernoulli r1]). -exact: E_sample. -move=> l0 e0 H. -destruct H as [f [mf]]. -exists (score mf). -exact: E_score. -move=> l0 t0 e0 H. -destruct H as [f [mf]]. -exists (ret mf). -exact: E_return. -Admitted. +- move=> l0 st x e1 H1 xl0. + destruct H1 as [f [mf]]. + exists (eta1 f). + exists (meta1 mf). + exact/E_WD. +- by do 2 eexists; apply/E_unit. +- by do 2 eexists; apply/E_bool. +- by do 2 eexists; apply/E_real. +- move=> l0 t1 t2 e1 H1 e2 H2. + destruct H1 as [f1 [mf1]]. + destruct H2 as [f2 [mf2]]. + exists (fun x => (f1 x, f2 x)). + eexists; exact: E_pair. +- move=> l0 x t0 (*xl0*) t0E. + subst t0. + eexists. + eexists. + by apply/E_var. +- move=> r r1. + eexists. + eexists. + exact: E_bernoulli. +- move=> l0 k e0 H. + destruct H as [f [mf]]. + exists (poisson k \o f). + exists (measurable_funT_comp (mpoisson k) mf). + exact: E_poisson. +- move=> l0 t0 e0 H. + destruct H as [k]. + exists (normalize k point). + exists (measurable_fun_normalize k). + exact: E_norm. +- move=> l0 st x e1 H1 xl0. + destruct H1 as [k]. + exists (@keta1 R x l0 st k). + exact/E_WP. +- move=> l0 t0 e1 H1 e2 H2 e3 H3. + destruct H1 as [f [mf]]. + destruct H2 as [k2]. + destruct H3 as [k3]. + exists (ite mf k2 k3). + exact: E_ifP. +- move=> l0 t1 t2 x e1 H1 e2 H2. + destruct H1 as [k1 ev1]. + destruct H2 as [k2 ev2]. + subst. + exists (letin' k1 k2). + exact: E_letin. +- move=> l0 r r1. + exists (sample [the pprobability _ _ of bernoulli r1]). + exact: E_sample. +- move=> l0 e0 H. + destruct H as [f [mf]]. + exists (score mf). + exact: E_score. +- move=> l0 t0 e0 H. + destruct H as [f [mf]]. + exists (ret mf). + exact: E_return. +Qed. (* admit. do 2 eexists; apply/E_unit. @@ -1194,7 +1172,7 @@ apply: (@expP_mut_rec R (fun (l : context) (t : stype) (e : expP l t) => free_varsP e = [::] -> expP [::] t) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). -move=> l0 st x e0 H1 xl H2. +- move=> l0 st x e0 H1 xl H2. (* apply (expWD e0 x). *) admit. move=> ? ?; exact: exp_unit. @@ -1246,11 +1224,10 @@ Abort. Axiom same_expP : forall (l l' : context) (T : stype) (e : @expP R T l) (e' : @expP R T l'), Prop. *) + Lemma evalP_uni_new x r (u : R.-sfker munit ~> mR R) - (v : R.-sfker prod_meas_obligation_2 prod_meas - (existT [eta measurableType] default_measure_display (mR R)) - [::] ~> mR R) : + (v : R.-sfker projT2 (typei (sprod [seq i.2 | i <- [:: (x, sreal)]])) ~> mR R) : evalP (exp_return (exp_real r) : expP [::] sreal) u -> evalP (exp_return (exp_real r) : expP [:: (x, sreal)] sreal) v -> forall x0 t, v (x0, t) = u t. @@ -1270,8 +1247,8 @@ Require Import JMeq. Obligation Tactic := idtac. -Program Fixpoint wP {st} {l : context} (x : string * stype) (e : @expP R l st) - : @expP R (x :: l) st := +Program Fixpoint wP {st} {l : context} (x : string * stype) (e : @expP R l st) + : @expP R (x :: l) st := match e with | exp_return l0 _ e0 => @exp_return R (x :: l0) _ (wD x e0) | exp_if l0 _ e1 e2 e3 => @exp_if R (x :: l0) _ (wD x e1) (wP x e2) (wP x e3) @@ -1303,7 +1280,7 @@ Let VX0 z : (VX z) set0 = 0. Proof. by []. Qed. Let VX_ge0 z x : 0 <= (VX z) x. Proof. by []. Qed. Let VX_semi_sigma_additive z : semi_sigma_additive (VX z). Proof. exact: measure_semi_sigma_additive. Qed. -HB.instance Definition _ z := @isMeasure.Build _ R (mR R) (VX z) (VX0 z) +HB.instance Definition _ z := @isMeasure.Build _ R (mR R) (VX z) (VX0 z) (VX_ge0 z) (@VX_semi_sigma_additive z). Let sfinVX z : sfinite_measure (VX z). Proof. exact: sfinite_kernel_measure. Qed. HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ (mR R) R @@ -1315,7 +1292,7 @@ Let VY0 z : (VY z) set0 = 0. Proof. by []. Qed. Let VY_ge0 z x : 0 <= (VY z) x. Proof. by []. Qed. Let VY_semi_sigma_additive z : semi_sigma_additive (VY z). Proof. exact: measure_semi_sigma_additive. Qed. -HB.instance Definition _ z := @isMeasure.Build _ R (mR R) (VY z) (VY0 z) +HB.instance Definition _ z := @isMeasure.Build _ R (mR R) (VY z) (VY0 z) (VY_ge0 z) (@VY_semi_sigma_additive z). Let sfinVY z : sfinite_measure (VY z). Proof. exact: sfinite_kernel_measure. Qed. HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ (mR R) R @@ -1323,11 +1300,14 @@ HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ (mR R) R End eval_prop. +Definition context_of_expP R (l : context) (s : stype) (e : @expP R l s) := l. + Declare Custom Entry expr. Notation "[ e ]" := e (e custom expr at level 5). Notation "x ':r'" := (@exp_real _ _ x%R) (in custom expr at level 1). Notation "'Ret' x" := (@exp_return _ _ _ x) (in custom expr at level 2). -Notation "% x # H" := (exp_var x _ H erefl) (in custom expr at level 1). +Notation "% x" := (@exp_var _ _ x _ erefl) (in custom expr at level 1). +Notation "%WP x # e" := (@expWP _ _ _ (x, _) e erefl) (in custom expr at level 1). Notation "( x , y )" := (exp_pair x y) (in custom expr at level 1). Notation "'Let' x '<~' e 'In' f" := (exp_letin x e f) (in custom expr at level 3, @@ -1369,7 +1349,7 @@ move=> x y mM ev1 ev2. pose vx : R.-sfker munit ~> mR R := execP_cst [:: (x, sreal)] [::] 1. pose vy : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := execP_cst [:: (x, sreal)] [:: (x, sreal)] 2. -have -> : v1 = +have -> : v1 = letin' (vx) (letin' (vy) (ret (measurable_fun_pair var2of3' var1of3'))). apply: (evalP_uniq ev1). apply/E_letin /E_letin. @@ -1425,7 +1405,7 @@ Qed. *) Ltac inj H := apply Classical_Prop.EqdepTheory.inj_pair2 in H. -Lemma evalP_uniq_sub (l : context) (st : stype) e (u1 : R.-sfker _ ~> _) +Lemma evalP_uniq_sub (l : context) (st : stype) e (u1 : R.-sfker _ ~> _) (* (u1' : R.-sfker prod_meas_obligation_2 prod_meas (existT [eta measurableType] _ (typei2 st)) _ ~> _) *) (xtl : ("x", st) \notin l) M y0 t : @@ -1441,7 +1421,7 @@ Proof. move=> x xNe1 mst. move=> hu. by rewrite /keta1 /=. -(* +(* apply: (@evalP_mut_ind R (fun (l : _) (st : stype) (e : expD l st) (f : projT2 (typei _) -> projT2 (typei st)) (mf : measurable_fun setT f) (h1 : l |- e -D-> f # mf) => forall (xtl : (x, st) \notin l) M y0 t, ((x, st) :: l)%SEQ |- (@expWD R l st (x, st) e xtl) -D-> (@eta1 R (x, st) l st f) # (meta1 mf) -> f t = (@eta1 R (x, st) l st f) (y0, t) @@ -1453,10 +1433,24 @@ move=> l' ? ? ? ?. by inversion 1.*) Qed. -Lemma letinC (l : context) st v1 v2 t M (e1 : @expP R l st) (e2 : expP l st) +Lemma letinC ta tb (l0 := [:: ("a", ta); ("b", tb)]) st + (e1 : @expP R l0 st) (e2 : expP l0 st) v1 v2 : + "x" \notin free_varsP e2 -> + "y" \notin free_varsP e1 -> + l0 |- [Let "x" <~ e1 In + Let "y" <~ %WP {"x"} # e2 In + Ret (%{"x"}, %{"y"})] -P-> v1 + -> + l0 |- [Let "y" <~ e2 In + Let "x" <~ %WP {"y"} # e1 In + Ret (%{"x"}, %{"y"})] -P-> v2 -> + v1 = v2. +Admitted. + +(*Lemma letinC (l : context) st v1 v2 t M (e1 : @expP R l st) (e2 : expP l st) (Hx1 : "x" \in map fst ([:: ("y", st); ("x", st)] ++ l)%SEQ) (Hy1 : "y" \in map fst ([:: ("y", st); ("x", st)] ++ l)%SEQ) -(Hx2 : "x" \in map fst ([:: ("x", st); ("y", st)] ++ l)%SEQ) +(Hx2 : "x" \in map fst ([:: ("x", st); ("y", st)] ++ l)%SEQ) (Hy2 : "y" \in map fst ([:: ("x", st); ("y", st)] ++ l)%SEQ) (xtl : ("x", st) \notin l) (ytl : ("y", st) \notin l) : let x := "x" in @@ -1474,7 +1468,7 @@ Lemma letinC (l : context) st v1 v2 t M (e1 : @expP R l st) (e2 : expP l st) v1 t M = v2 t M. Proof. rewrite /=. -Admitted. +Admitted.*) End letinC. @@ -1494,44 +1488,105 @@ Check ret (kr 3) tt : {measure set mR R -> \bar R}. Goal (ret (kr 3) : R.-sfker _ ~> (mR R)) tt [set: R] = 1%:E. Proof. rewrite /= diracE in_setT //. Qed. -Example pgm1 : expD [::] (sprob sbool) := let x := "x" in exp_norm ( - [Let "x" <~ {exp_sample_bern [::] (2 / 7%:R)%:nng p27} In - Let "r" <~ If {(@exp_var R [:: ("x", sbool)] "x" _ erefl)} - Then Ret {3}:r Else Ret {10}:r In - Let "_" <~ {exp_score - (exp_poisson 4 (@exp_var R [:: ("r", sreal); ("x", sbool)] "r" _ erefl))} In Ret %x]). +Structure tagged_context := Tag {untag : context}. + +Definition recurse_tag h := Tag h. +Canonical found_tag h := recurse_tag h. + +Structure find (s : string) (t : stype) := Find { + context_of : tagged_context ; + ctxt_prf : t = nth sunit (map snd (untag context_of)) + (seq.index s (map fst (untag context_of)))}. + +Lemma left_pf (s : string) (t : stype) (l : context) : + t = nth sunit (map snd ((s, t) :: l)) (seq.index s (map fst ((s, t) :: l))). +Proof. +by rewrite /= !eqxx/=. +Qed. + +Canonical found_struct s t (l : context) : find s t := + Eval hnf in @Find s t (found_tag ((s, t) :: l)) (@left_pf s t l). + +Lemma right_pf (s : string) (t : stype) (l : context) u t' : + s != u -> + t' = nth sunit (map snd l) (seq.index u (map fst l)) -> + t' = nth sunit (map snd ((s, t) :: l)) (seq.index u (map fst ((s, t) :: l))). +Proof. +move=> su ut'l /=. +case: ifPn => //=. +by rewrite (negbTE su). +Qed. + +Definition varx := "x". +Definition varr := "r". +Definition var_ := "_". + +Class diff (s tu : string) := Diff { + diff_su : s != tu +}. + +Global Instance diff_x : diff "_" varx := @Diff "_" varx erefl. +Global Instance diff_r : diff "_" _ := @Diff "_" varr erefl. +Global Instance diffx_ : diff "x" _ := @Diff "x" var_ erefl. +Global Instance diffxr : diff "x" _ := @Diff "x" varr erefl. +Global Instance diffrx : diff "r" _ := @Diff "r" varx erefl. +Global Instance diffr_ : diff "r" _ := @Diff "r" var_ erefl. + +Canonical recurse_struct s t t' u {su : diff s u} (l : find u t') : find u t' := + Eval hnf in @Find u t' (recurse_tag ((s, t) :: untag (context_of l))) + (@right_pf s t (untag (context_of l)) u t' (@diff_su _ _ su) (ctxt_prf l)). + +Definition exp_var' (x : string) (t : stype) (g : find x t) := + @exp_var R (untag (context_of g)) x t (ctxt_prf g). + +Notation "%1 x" := (@exp_var' x%string _ _) (in custom expr at level 1). + +Example pgm1 := exp_norm ( + [Let "x" <~ {exp_sample_bern [::] (2 / 7%:R)%:nng p27} In + Let "r" <~ If %1{"x"} Then Ret {3}:r Else Ret {10}:r In + Let "_" <~ {exp_score (exp_poisson 4 [%1{"r"}])} In + Ret %1{"x"}]). Print pgm1. -Definition sample_bern : R.-sfker munit ~> mbool := +Definition sample_bern : R.-sfker munit ~> mbool := sample [the probability _ _ of bernoulli p27]. -Definition ite_3_10 : +Definition ite_3_10 : R.-sfker [the measurableType _ of (mbool * munit)%type] ~> (mR R) := ite var1of4' (ret k3) (ret k10). Definition score_poi : R.-sfker [the measurableType _ of ((mR R) * (mbool * munit)%type)%type] ~> munit := score (measurable_funT_comp (mpoisson 4) var1of4'). -Local Definition kstaton_bus'' := - letin' sample_bern - (letin' ite_3_10 +Local Definition kstaton_bus'' := + letin' sample_bern + (letin' ite_3_10 (letin' score_poi (ret var3of4'))). Example ev1 : @evalD R [::] _ pgm1 _ (measurable_fun_normalize kstaton_bus''). Proof. apply/E_norm /E_letin /E_letin /E_letin. -apply/E_sample. -apply/E_ifP. -have -> : (var1of4' = (@mvarof R [:: ("x", sbool)] 0 (false_index_size (_ : "x" \in map fst [:: ("x", sbool)])))) by done. -exact: (@E_var R [:: ("x", sbool)] "x"). -apply/E_return /E_real. -apply/E_return /E_real. -apply/E_score /E_poisson. -have -> : (var1of4' = (@mvarof R [:: ("r", sreal); ("x", sbool)] 0 (false_index_size (_ : "r" \in map fst [:: ("r", sreal); ("x", sbool)])))) by done. -exact: (@E_var R [:: ("r", sreal); ("x", sbool)] "r"). -apply/E_return. -have -> : (var3of4' = (@mvarof R [:: ("_", sunit); ("r", sreal); ("x", sbool)] 2 (false_index_size (_ : "x" \in map fst [:: ("_", sunit); ("r", sreal); ("x", sbool)])))) by done. -exact: (@E_var R [:: ("_", sunit); ("r", sreal); ("x", sbool)] "x"). +- by apply/E_sample. +- apply/E_ifP. + + rewrite /exp_var' /=. + set l := (X in X |- _ -D-> _ # _). + rewrite (_ : left_pf _ _ _ = erefl) //. + rewrite (_ : var1of2 = @mvarof R l 0)//. + exact: (@E_var R l "x"). + + by apply/E_return /E_real. + + by apply/E_return /E_real. +- apply/E_score /E_poisson. + set l := (X in X |- _ -D-> _ # _). + rewrite /exp_var'/=. + rewrite (_ : left_pf _ _ _ = erefl) //. + rewrite (_ : var1of2 = @mvarof R l 0)//. + exact: (@E_var R l "r"). +- apply/E_return. + set l := (X in X |- _ -D-> _ # _). + rewrite /exp_var'/=. + rewrite (_ : right_pf _ _ _ = erefl) //. + rewrite (_ : var3of4' = @mvarof R l 2)//. + exact: (@E_var R l "x"). Qed. End example. From 8f8f33c50114e66a2442e7d7e206c9af27a34c5f Mon Sep 17 00:00:00 2001 From: AyumuSaito Date: Mon, 24 Apr 2023 19:24:26 +0900 Subject: [PATCH 50/54] letinC --- theories/lang_syntax.v | 444 +++++++++++++++++++++++++++++------------ 1 file changed, 313 insertions(+), 131 deletions(-) diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index 2aed026675..2f71530722 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -1145,7 +1145,7 @@ Definition X := @typei2 R A. Definition Y := @typei2 R B. Definition Z := @typei2 R C. *) -Definition execP l t (e : @expP R l t) (H : {subset free_varsP e <= map fst l}): +Definition execP l t (e : @expP R l t) : R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t. Proof. have /cid h := @evalP_full l t e. @@ -1320,6 +1320,126 @@ Notation "'If' e1 'Then' e2 'Else' e3" := (exp_if e1 e2 e3) (in custom expr at l Notation "{ x }" := x (in custom expr, x constr). Notation "x" := x (in custom expr at level 0, x ident). + +Section example. + +Local Open Scope ring_scope. +Variables (R : realType). + +Example __ : @evalD R [::] _ [{3}:r] (cst 3) (kr 3). +Proof. apply/E_real. Qed. + +Example ex_ret : @evalP R [::] _ [Ret {3}:r] (ret (kr 3)). +Proof. apply/E_return/E_real. Qed. + +Check ret (kr 3) : R.-sfker _ ~> (mR R). +Check ret (kr 3) tt : {measure set mR R -> \bar R}. +Goal (ret (kr 3) : R.-sfker _ ~> (mR R)) tt [set: R] = 1%:E. +Proof. rewrite /= diracE in_setT //. Qed. + +Structure tagged_context := Tag {untag : context}. + +Definition recurse_tag h := Tag h. +Canonical found_tag h := recurse_tag h. + +Structure find (s : string) (t : stype) := Find { + context_of : tagged_context ; + ctxt_prf : t = nth sunit (map snd (untag context_of)) + (seq.index s (map fst (untag context_of)))}. + +Lemma left_pf (s : string) (t : stype) (l : context) : + t = nth sunit (map snd ((s, t) :: l)) (seq.index s (map fst ((s, t) :: l))). +Proof. +by rewrite /= !eqxx/=. +Qed. + +Canonical found_struct s t (l : context) : find s t := + Eval hnf in @Find s t (found_tag ((s, t) :: l)) (@left_pf s t l). + +Lemma right_pf (s : string) (t : stype) (l : context) u t' : + s != u -> + t' = nth sunit (map snd l) (seq.index u (map fst l)) -> + t' = nth sunit (map snd ((s, t) :: l)) (seq.index u (map fst ((s, t) :: l))). +Proof. +move=> su ut'l /=. +case: ifPn => //=. +by rewrite (negbTE su). +Qed. + +Definition varx := "x". +Definition varr := "r". +Definition var_ := "_". + +Class diff (s tu : string) := Diff { + diff_su : s != tu +}. + +Global Instance diff_x : diff "_" varx := @Diff "_" varx erefl. +Global Instance diff_r : diff "_" _ := @Diff "_" varr erefl. +Global Instance diffx_ : diff "x" _ := @Diff "x" var_ erefl. +Global Instance diffxr : diff "x" _ := @Diff "x" varr erefl. +Global Instance diffrx : diff "r" _ := @Diff "r" varx erefl. +Global Instance diffr_ : diff "r" _ := @Diff "r" var_ erefl. + +Canonical recurse_struct s t t' u {su : diff s u} (l : find u t') : find u t' := + Eval hnf in @Find u t' (recurse_tag ((s, t) :: untag (context_of l))) + (@right_pf s t (untag (context_of l)) u t' (@diff_su _ _ su) (ctxt_prf l)). + +Definition exp_var' (x : string) (t : stype) (g : find x t) := + @exp_var R (untag (context_of g)) x t (ctxt_prf g). + +Notation "%1 x" := (@exp_var' x%string _ _) (in custom expr at level 1). + +Example pgm1 := exp_norm ( + [Let "x" <~ {exp_sample_bern [::] (2 / 7%:R)%:nng p27} In + Let "r" <~ If %1{"x"} Then Ret {3}:r Else Ret {10}:r In + Let "_" <~ {exp_score (exp_poisson 4 [%1{"r"}])} In + Ret %1{"x"}]). + +Print pgm1. + +Definition sample_bern : R.-sfker munit ~> mbool := + sample [the probability _ _ of bernoulli p27]. +Definition ite_3_10 : + R.-sfker [the measurableType _ of (mbool * munit)%type] ~> (mR R) := + ite var1of4' (ret k3) (ret k10). +Definition score_poi : + R.-sfker [the measurableType _ of ((mR R) * (mbool * munit)%type)%type] ~> munit := + score (measurable_funT_comp (mpoisson 4) var1of4'). + +Local Definition kstaton_bus'' := + letin' sample_bern + (letin' ite_3_10 + (letin' score_poi (ret var3of4'))). + +Example ev1 : @evalD R [::] _ pgm1 _ (measurable_fun_normalize kstaton_bus''). +Proof. +apply/E_norm /E_letin /E_letin /E_letin. +- by apply/E_sample. +- apply/E_ifP. + + rewrite /exp_var' /=. + set l := (X in X |- _ -D-> _ # _). + rewrite (_ : left_pf _ _ _ = erefl) //. + rewrite (_ : var1of2 = @mvarof R l 0)//. + exact: (@E_var R l "x"). + + by apply/E_return /E_real. + + by apply/E_return /E_real. +- apply/E_score /E_poisson. + set l := (X in X |- _ -D-> _ # _). + rewrite /exp_var'/=. + rewrite (_ : left_pf _ _ _ = erefl) //. + rewrite (_ : var1of2 = @mvarof R l 0)//. + exact: (@E_var R l "r"). +- apply/E_return. + set l := (X in X |- _ -D-> _ # _). + rewrite /exp_var'/=. + rewrite (_ : right_pf _ _ _ = erefl) //. + rewrite (_ : var3of4' = @mvarof R l 2)//. + exact: (@E_var R l "x"). +Qed. + +End example. + Section letinC. Variable R : realType. @@ -1328,7 +1448,7 @@ Check [Let "x" <~ Ret {1}:r In Let "y" <~ Ret {2}:r In Ret (%{"x"} # {[:: ("y", sreal); ("x", sreal)]}, %{"y"} # {[:: ("y", sreal); ("x", sreal)]})]. *) -(* Lemma letinC12 v1 v2 t M : +Lemma letinC12 v1 v2 t M : let x := "x" in let y := "y" in (* let s1 := [:: (y, sreal); (x, sreal)] in @@ -1358,10 +1478,10 @@ by case: cid => // ? h. rewrite /vy /execP_cst /sval/=. by case: cid => // ? h. apply/E_return /E_pair. -have -> : (var2of3' = (@mvarof R [:: (y, sreal); (x, sreal)] 1 (false_index_size (_ : (x \in map fst [:: (y, sreal); (x, sreal)]))))) by []. +have -> : (var2of3' = (@mvarof R [:: (y, sreal); (x, sreal)] 1 )) by []. apply/(@E_var R [:: (y, sreal); (x, sreal)] x). -have -> : (var1of4' = (@mvarof R [:: (y, sreal); (x, sreal)] 0 (false_index_size (_ : (y \in map fst [:: (y, sreal); (x, sreal)]))))) by []. -apply/(@E_var R [:: (y, sreal); (x, sreal)] y is_true_true). +have -> : (var1of4' = (@mvarof R [:: (y, sreal); (x, sreal)] 0 )) by []. +apply/(@E_var R [:: (y, sreal); (x, sreal)] y). pose vy' : R.-sfker munit ~> mR R := execP_cst [::] [::] 2. pose vx' : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := execP_cst [:: (y, sreal)] [:: (y, sreal)] 1. have -> : v2 = letin' (vy') (letin' (vx') (ret (measurable_fun_pair var1of3' var2of3'))). @@ -1372,10 +1492,10 @@ case: cid => //. rewrite /vx' /execP_cst /sval/=. case: cid => //. apply/E_return /E_pair. -have -> : (var1of3' = (@mvarof R [:: (x, sreal); (y, sreal)] 0 (false_index_size (_ : (x \in map fst [:: (x, sreal); (y, sreal)]))))) by []. -apply/(@E_var R [:: (x, sreal); (y, sreal)] x is_true_true). -have -> : (var2of3' = (@mvarof R [:: (x, sreal); (y, sreal)] 1 (false_index_size (_ : (y \in map fst [:: (x, sreal); (y, sreal)]))))) by []. -apply/(@E_var R [:: (x, sreal); (y, sreal)] y is_true_true). +have -> : (var1of3' = (@mvarof R [:: (x, sreal); (y, sreal)] 0 )) by []. +apply/(@E_var R [:: (x, sreal); (y, sreal)] x). +have -> : (var2of3' = (@mvarof R [:: (x, sreal); (y, sreal)] 1 )) by []. +apply/(@E_var R [:: (x, sreal); (y, sreal)] y). apply: letin'C; last by []. move=> x0 t0. rewrite (@evalP_uni_new _ y 1 vx vx'); last 2 first. @@ -1392,7 +1512,7 @@ move=> x0 t0. apply/esym/evalP_uni_new. exact: er2. exact: er1. -Qed. *) +Qed. (* Lemma evalP_uni_new x r (u : R.-sfker munit ~> mR R) @@ -1433,7 +1553,128 @@ move=> l' ? ? ? ?. by inversion 1.*) Qed. -Lemma letinC ta tb (l0 := [:: ("a", ta); ("b", tb)]) st +(* Lemma letinC ta tb (l0 := [:: ("a", ta); ("b", tb)]) st + (e1 : @expP R l0 st) (e2 : expP l0 st) : + "x" \notin free_varsP e2 -> + "y" \notin free_varsP e1 -> + [Let "x" <~ e1 In + Let "y" <~ %WP {"x"} # e2 In + Ret (%{"x"}, %{"y"})] = + [Let "y" <~ e2 In + Let "x" <~ %WP {"y"} # e1 In + Ret (%{"x"}, %{"y"})] :> expP _ _. +Admitted. *) + +Lemma eval_exec l st e1 : l |- e1 -P-> @execP R l st e1. +Proof. +rewrite /execP/= /sval. +by case: cid. +Qed. + +Lemma execP_keta st (e : expP [::] st) (x : string) : execP [%WP x # e] = @keta1 R (x, st) [::] st (execP e). +Proof. +apply: (@evalP_uniq R _ _ [%WP x # e]). +exact/eval_exec. +apply: E_WP. +exact/eval_exec. +Qed. + +(* Lemma prod_measurable (B : set bool) : measurable B. *) + +Lemma letinC st + (e1 : @expP R [::] st) (e2 : expP [::] st) (v1 v2 : R.-sfker munit ~> typei2 (spair st st)) : + (* "x" \notin free_varsP e2 -> + "y" \notin free_varsP e1 -> *) + [::] |- [Let "x" <~ e1 In + Let "y" <~ %WP {"x"} # e2 In + Ret (%{"x"}, %{"y"})] -P-> v1 + -> + [::] |- [Let "y" <~ e2 In + Let "x" <~ %WP {"y"} # e1 In + Ret (%{"x"}, %{"y"})] -P-> v2 -> + v1 = v2. +Proof. +move=> (* xN yN *) ev1 ev2. +set x := "x". +set y := "y". +pose k1 : R.-sfker _ ~> typei2 st := @execP R [::] st e1. +pose k2' : R.-sfker _ ~> _ := @execP R [:: (x, st)] st [%WP x # e2]. +pose vx := letin' k1 + (letin' k2' + (ret + (measurable_fun_pair + (* (T:= (typei2 st * (typei2 st * munit))%type) + (T1 := typei2 st) (T2 := typei2 st) *) + (f := fst \o snd) (g:= fst) var2of4' var1of2))). +have ev1' : [::] |- [Let x <~ e1 In Let y <~ %WP x # e2 In Ret (% x, % y)] -P-> vx. +apply/E_letin. +rewrite /k1. +apply: eval_exec. +apply/E_letin. +rewrite /k2'. +apply: eval_exec. +apply/E_return /E_pair. +have -> : (var2of4' = (@mvarof R [:: (y, st); (x, st)] 1)) by []. +apply (@E_var R [:: (y, st); (x, st)] x). +have -> : (var1of2 = (@mvarof R [:: (y, st); (x, st)] 0)) by []. +apply/(@E_var R [:: (y, st); (x, st)] y). +have -> := (evalP_uniq ev1 ev1'). + +pose k2 : R.-sfker _ ~> typei2 st := @execP R [::] st e2. +pose k1' : R.-sfker _ ~> _ := @execP R [:: (y, st)] st [%WP y # e1]. +pose vy := letin' k2 + (letin' k1' + (ret + (measurable_fun_pair + (* (T:= (typei2 st * (typei2 st * munit))%type) + (T1 := typei2 st) (T2 := typei2 st) *) + (f := fst) (g:= fst \o snd) var1of2 var2of4'))). +have ev2' : [::] |- [Let y <~ e2 In Let x <~ %WP y # e1 In Ret (% x, % y)] -P-> vy. +apply/E_letin. +apply/eval_exec. +apply/E_letin. +apply/eval_exec. +apply/E_return /E_pair. +have -> : (var1of2 = (@mvarof R [:: (x, st); (y, st)] 0)) by []. +apply/(@E_var R [:: (x, st); (y, st)] x). +have -> : (var2of4' = (@mvarof R [:: (x, st); (y, st)] 1)) by []. +apply/(@E_var R [:: (x, st); (y, st)] y). +have -> := (evalP_uniq ev2 ev2'). + +rewrite/vx/vy. +apply: eq_sfkernel => t U. +apply: (@letin'C _ _ _ (typei2 st) (typei2 st) munit). +- by rewrite /k1/k1' execP_keta. +- by rewrite /k2/k2' execP_keta. +- rewrite /= in U *. +rewrite measurable_prod_measurableType. +apply: sub_sigma_algebra. +Admitted. + +Lemma letinC_new st + (e1 : @expP R [::] st) (e2 : expP [::] st) : + "x" \notin free_varsP e2 -> + "y" \notin free_varsP e1 -> + execP [Let "x" <~ e1 In + Let "y" <~ %WP {"x"} # e2 In + Ret (%{"x"}, %{"y"})] = + execP [Let "y" <~ e2 In + Let "x" <~ %WP {"y"} # e1 In + Ret (%{"x"}, %{"y"})]. +Proof. +move=> xn yn. +apply/letinC/eval_exec/eval_exec. +Qed. + +Lemma execP_ketaAB (ta tb : stype) (l0 := [:: ("r", ta); ("_", tb)]) st (e : expP l0 st) : execP [%WP {"x"} # e] = @keta1 R ("x", st) l0 st (execP e). +Proof. +apply: (@evalP_uniq R _ _ [%WP {"x"} # e]). +exact/eval_exec. +apply: E_WP. +exact/eval_exec. +Qed. + +Lemma letinC_g ta tb (l0 := [:: ("r", ta); ("_", tb)]) st (e1 : @expP R l0 st) (e2 : expP l0 st) v1 v2 : "x" \notin free_varsP e2 -> "y" \notin free_varsP e1 -> @@ -1445,6 +1686,66 @@ Lemma letinC ta tb (l0 := [:: ("a", ta); ("b", tb)]) st Let "x" <~ %WP {"y"} # e1 In Ret (%{"x"}, %{"y"})] -P-> v2 -> v1 = v2. +Proof. +move=> _ _ ev1 ev2. +set x := "x". +set y := "y". +pose k1 : R.-sfker _ ~> typei2 st := @execP R l0 st e1. +pose k2' : R.-sfker _ ~> _ := @execP R ((x, st) :: l0) st [%WP x # e2]. +pose vx := letin' k1 + (letin' k2' + (ret + (measurable_fun_pair + (* (T:= (typei2 st * (typei2 st * munit))%type) + (T1 := typei2 st) (T2 := typei2 st) *) + (f := fst \o snd) (g:= fst) var2of4' var1of2))). +have ev1' : l0 |- [Let x <~ e1 In Let y <~ %WP x # e2 In Ret (% x, % y)] -P-> vx. + apply/E_letin. + rewrite /k1. + apply: eval_exec. + apply/E_letin. + rewrite /k2'. + apply: eval_exec. + apply/E_return /E_pair. + have -> : (var2of4' = (@mvarof R [:: (y, st), (x, st) & l0] 1)) by []. + apply (@E_var R [:: (y, st), (x, st) & l0] x). + have -> : (var1of2 = (@mvarof R [:: (y, st), (x, st) & l0] 0)) by []. + by apply/(@E_var R [:: (y, st), (x, st) & l0] y). +have -> := (evalP_uniq ev1 ev1'). + +pose k2 : R.-sfker _ ~> typei2 st := @execP R l0 st e2. +pose k1' : R.-sfker _ ~> _ := @execP R [:: (y, st) & l0] st [%WP y # e1]. +pose vy := letin' k2 + (letin' k1' + (ret + (measurable_fun_pair + (* (T:= (typei2 st * (typei2 st * munit))%type) + (T1 := typei2 st) (T2 := typei2 st) *) + (f := fst) (g:= fst \o snd) var1of2 var2of4'))). +have ev2' : l0 |- [Let y <~ e2 In Let x <~ %WP y # e1 In Ret (% x, % y)] -P-> vy. +apply/E_letin. +apply/eval_exec. +apply/E_letin. +apply/eval_exec. +apply/E_return /E_pair. +have -> : (var1of2 = (@mvarof R [:: (x, st), (y, st) & l0] 0)) by []. +apply (@E_var R [:: (x, st), (y, st) & l0] x). +have -> : (var2of4' = (@mvarof R [:: (x, st), (y, st) & l0] 1)) by []. +apply/(@E_var R [:: (x, st), (y, st) & l0] y). +have -> := (evalP_uniq ev2 ev2'). +rewrite/vx/vy. +apply: eq_sfkernel => t U. +apply: (@letin'C _ _ _ (typei2 st) (typei2 st) _). +Eval compute in free_varsP e1. +- admit. +(* by rewrite /k1/k1' execP_ketaAB. *) +- +by rewrite /k2/k2' execP_ketaAB. +- rewrite /= in U *. +rewrite measurable_prod_measurableType. +apply: sub_sigma_algebra. + + Admitted. (*Lemma letinC (l : context) st v1 v2 t M (e1 : @expP R l st) (e2 : expP l st) @@ -1470,123 +1771,4 @@ Proof. rewrite /=. Admitted.*) -End letinC. - -Section example. - -Local Open Scope ring_scope. -Variables (R : realType). - -Example __ : @evalD R [::] _ [{3}:r] (cst 3) (kr 3). -Proof. apply/E_real. Qed. - -Example ex_ret : @evalP R [::] _ [Ret {3}:r] (ret (kr 3)). -Proof. apply/E_return/E_real. Qed. - -Check ret (kr 3) : R.-sfker _ ~> (mR R). -Check ret (kr 3) tt : {measure set mR R -> \bar R}. -Goal (ret (kr 3) : R.-sfker _ ~> (mR R)) tt [set: R] = 1%:E. -Proof. rewrite /= diracE in_setT //. Qed. - -Structure tagged_context := Tag {untag : context}. - -Definition recurse_tag h := Tag h. -Canonical found_tag h := recurse_tag h. - -Structure find (s : string) (t : stype) := Find { - context_of : tagged_context ; - ctxt_prf : t = nth sunit (map snd (untag context_of)) - (seq.index s (map fst (untag context_of)))}. - -Lemma left_pf (s : string) (t : stype) (l : context) : - t = nth sunit (map snd ((s, t) :: l)) (seq.index s (map fst ((s, t) :: l))). -Proof. -by rewrite /= !eqxx/=. -Qed. - -Canonical found_struct s t (l : context) : find s t := - Eval hnf in @Find s t (found_tag ((s, t) :: l)) (@left_pf s t l). - -Lemma right_pf (s : string) (t : stype) (l : context) u t' : - s != u -> - t' = nth sunit (map snd l) (seq.index u (map fst l)) -> - t' = nth sunit (map snd ((s, t) :: l)) (seq.index u (map fst ((s, t) :: l))). -Proof. -move=> su ut'l /=. -case: ifPn => //=. -by rewrite (negbTE su). -Qed. - -Definition varx := "x". -Definition varr := "r". -Definition var_ := "_". - -Class diff (s tu : string) := Diff { - diff_su : s != tu -}. - -Global Instance diff_x : diff "_" varx := @Diff "_" varx erefl. -Global Instance diff_r : diff "_" _ := @Diff "_" varr erefl. -Global Instance diffx_ : diff "x" _ := @Diff "x" var_ erefl. -Global Instance diffxr : diff "x" _ := @Diff "x" varr erefl. -Global Instance diffrx : diff "r" _ := @Diff "r" varx erefl. -Global Instance diffr_ : diff "r" _ := @Diff "r" var_ erefl. - -Canonical recurse_struct s t t' u {su : diff s u} (l : find u t') : find u t' := - Eval hnf in @Find u t' (recurse_tag ((s, t) :: untag (context_of l))) - (@right_pf s t (untag (context_of l)) u t' (@diff_su _ _ su) (ctxt_prf l)). - -Definition exp_var' (x : string) (t : stype) (g : find x t) := - @exp_var R (untag (context_of g)) x t (ctxt_prf g). - -Notation "%1 x" := (@exp_var' x%string _ _) (in custom expr at level 1). - -Example pgm1 := exp_norm ( - [Let "x" <~ {exp_sample_bern [::] (2 / 7%:R)%:nng p27} In - Let "r" <~ If %1{"x"} Then Ret {3}:r Else Ret {10}:r In - Let "_" <~ {exp_score (exp_poisson 4 [%1{"r"}])} In - Ret %1{"x"}]). - -Print pgm1. - -Definition sample_bern : R.-sfker munit ~> mbool := - sample [the probability _ _ of bernoulli p27]. -Definition ite_3_10 : - R.-sfker [the measurableType _ of (mbool * munit)%type] ~> (mR R) := - ite var1of4' (ret k3) (ret k10). -Definition score_poi : - R.-sfker [the measurableType _ of ((mR R) * (mbool * munit)%type)%type] ~> munit := - score (measurable_funT_comp (mpoisson 4) var1of4'). - -Local Definition kstaton_bus'' := - letin' sample_bern - (letin' ite_3_10 - (letin' score_poi (ret var3of4'))). - -Example ev1 : @evalD R [::] _ pgm1 _ (measurable_fun_normalize kstaton_bus''). -Proof. -apply/E_norm /E_letin /E_letin /E_letin. -- by apply/E_sample. -- apply/E_ifP. - + rewrite /exp_var' /=. - set l := (X in X |- _ -D-> _ # _). - rewrite (_ : left_pf _ _ _ = erefl) //. - rewrite (_ : var1of2 = @mvarof R l 0)//. - exact: (@E_var R l "x"). - + by apply/E_return /E_real. - + by apply/E_return /E_real. -- apply/E_score /E_poisson. - set l := (X in X |- _ -D-> _ # _). - rewrite /exp_var'/=. - rewrite (_ : left_pf _ _ _ = erefl) //. - rewrite (_ : var1of2 = @mvarof R l 0)//. - exact: (@E_var R l "r"). -- apply/E_return. - set l := (X in X |- _ -D-> _ # _). - rewrite /exp_var'/=. - rewrite (_ : right_pf _ _ _ = erefl) //. - rewrite (_ : var3of4' = @mvarof R l 2)//. - exact: (@E_var R l "x"). -Qed. - -End example. +End letinC. \ No newline at end of file From cd1d8bde23b685c6f995273dba6e3e7af7a62c66 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 26 Apr 2023 01:11:36 +0900 Subject: [PATCH 51/54] letinC (cont'd) --- theories/lang_syntax.v | 1716 +++++++++++++--------------------------- theories/prob_lang.v | 9 +- 2 files changed, 562 insertions(+), 1163 deletions(-) diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index 2f71530722..a3f8d9ba1f 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -22,8 +22,10 @@ Local Open Scope string. Import Notations. -Reserved Notation "l |- e -D-> v # mv" (at level 50). -Reserved Notation "l |- e -P-> v" (at level 50). +Declare Scope lang_scope. + +Reserved Notation "l # e -D-> v ; mv" (at level 40). +Reserved Notation "l # e -P-> v" (at level 40). Section type_syntax. Variables (R : realType). @@ -41,7 +43,7 @@ Fixpoint prod_meas (l : list {d & measurableType d}) match l with | [::] => existT measurableType _ munit | h :: t => let t' := prod_meas t in - existT _ _ [the measurableType _ of (projT2 h * projT2 t')%type] + existT _ _ [the measurableType (projT1 h, projT1 t').-prod of (projT2 h * projT2 t')%type] end. Inductive stype := @@ -50,7 +52,7 @@ Inductive stype := | sreal : stype | spair : stype -> stype -> stype | sprob : stype -> stype -| sprod : list stype -> stype. +| slist : list stype -> stype. Canonical stype_eqType := Equality.Pack (@gen_eqMixin stype). @@ -60,10 +62,10 @@ Fixpoint typei (t : stype) : {d & measurableType d} := | sbool => existT _ _ mbool | sreal => existT _ _ (mR R) | spair A B => existT _ _ - [the measurableType ((projT1 (typei A), projT1 (typei B)).-prod)%mdisp of + [the measurableType (projT1 (typei A), projT1 (typei B)).-prod%mdisp of (projT2 (typei A) * projT2 (typei B))%type] | sprob A => existT _ _ (pprobability (projT2 (typei A)) R) - | sprod l => prod_meas (map typei l) + | slist l => prod_meas (map typei l) end. Definition typei2 t := projT2 (typei t). @@ -78,14 +80,8 @@ Definition context := seq (string * stype)%type. Section expr. Variables (R : realType). -(*Fixpoint assoc_get {A : eqType} {B : Type} (a : A) (l : seq (A * B)) : option B := - match l with - | nil => None - | h :: t => if h.1 == a then Some h.2 else assoc_get a t - end.*) - Inductive expD : context -> stype -> Type := -| expWD l st x (e : expD l st) : x \notin l -> expD (x :: l) st +| expWD l st x (e : expD l st) : x.1 \notin map fst l -> expD (x :: l) st | exp_unit l : expD l sunit | exp_bool l : bool -> expD l sbool | exp_real l : R -> expD l sreal @@ -97,7 +93,7 @@ Inductive expD : context -> stype -> Type := | exp_poisson l : nat -> expD l sreal -> expD l sreal | exp_norm l t : expP l t -> expD l (sprob t) with expP : context -> stype -> Type := -| expWP l st x (e : expP l st) : x \notin l -> expP (x :: l) st +| expWP l st x (e : expP l st) : x.1 \notin map fst l -> expP (x :: l) st | exp_if l t : expD l sbool -> expP l t -> expP l t -> expP l t | exp_letin l t1 t2 (x : string) : expP l t1 -> expP ((x, t1) :: l) t2 -> expP l t2 @@ -110,6 +106,7 @@ End expr. Arguments expD {R}. Arguments expP {R}. +Arguments expWD {R l st x}. Arguments exp_unit {R l}. Arguments exp_bool {R l}. Arguments exp_real {R l}. @@ -118,19 +115,38 @@ Arguments exp_var {R _}. Arguments exp_bernoulli {R l}. Arguments exp_poisson {R l}. Arguments exp_norm {R l _}. -Arguments exp_if {R l _}. +Arguments expWP {R l st x}. +Arguments exp_if {R l t}. Arguments exp_letin {R l _ _}. Arguments exp_sample_bern {R} l r. Arguments exp_score {R l}. Arguments exp_return {R l _}. +Declare Custom Entry expr. +Notation "[ e ]" := e (e custom expr at level 5) : lang_scope. +Notation "x ':r'" := (@exp_real _ _ x%R) (in custom expr at level 1) : lang_scope. +Notation "'Ret' x" := (@exp_return _ _ _ x) (in custom expr at level 2) : lang_scope. +Notation "% x" := (@exp_var _ _ x _ erefl) (in custom expr at level 1) : lang_scope. +Notation "%WP x # e" := (@expWP _ _ _ (x, _) e erefl) (in custom expr at level 1) : lang_scope. +Notation "( x , y )" := (exp_pair x y) (in custom expr at level 1) : lang_scope. +Notation "'Let' x '<~' e 'In' f" := (exp_letin x e f) + (in custom expr at level 3, + x constr, + (* e custom expr at level 2, *) + f custom expr at level 3, + left associativity) : lang_scope. +(*Notation "( x )" := x (in custom expr, x at level 50).*) +Notation "'If' e1 'Then' e2 'Else' e3" := (exp_if e1 e2 e3) (in custom expr at level 1) : lang_scope. +Notation "{ x }" := x (in custom expr, x constr) : lang_scope. +Notation "x" := x (in custom expr at level 0, x ident) : lang_scope. + Section eval. Variables (R : realType). Fixpoint varof (l : seq (string * stype)) (i : nat) : - projT2 (typei (sprod (map snd l))) -> projT2 (@typei R (nth sunit (map snd l) i)) := + typei2 (slist (map snd l)) -> @typei2 R (nth sunit (map snd l) i) := match - l return (projT2 (typei (sprod (map snd l))) -> projT2 (typei (nth sunit (map snd l) i))) + l return (typei2 (slist (map snd l)) -> typei2 (nth sunit (map snd l) i)) with | [::] => match i with | O => id | j.+1 => id end | _ :: _ => match i with @@ -139,58 +155,6 @@ Fixpoint varof (l : seq (string * stype)) (i : nat) : end end. -(*Definition varof (l : seq (string * stype)%type) (i : nat) : - projT2 (@typei R (sprod (map snd l))) -> - projT2 (@typei R (nth sunit (map snd l) i)). -revert l i. -fix H 1. -destruct l. - by destruct i. -destruct i. -simpl. -intro K. -exact: K.1. -simpl. -move=> K. -refine (H _ _ K.2). -Defined.*) - -(*Definition varof (l : seq (string * stype)%type) (i : nat) (li : (i < size l)%nat) : - projT2 (@typei R (sprod (map snd l))) -> - projT2 (@typei R (nth sunit (map snd l) i)). -revert l i li. -fix H 1. -destruct l. - by destruct i. -destruct i. -simpl => _. -intro K. -exact: K.1. -simpl. -move=> il. -move=> K. -refine (H _ _ _ K.2). -exact il. -Defined.*) - -(*Lemma false_index_size (x : string) (l : seq (string * stype)%type) (H : x \in map fst l) : - (seq.index x (map fst l) < size l)%nat. -Proof. by rewrite -(size_map fst) index_mem. Qed.*) - -(*Lemma mvarof (l : seq (string * stype)%type) (i : nat) (*(li : (i < size l)%nat)*) : - measurable_fun setT (@varof l i (*li*)). -Proof. -revert l i (*li*). -induction l. - by destruct i. -destruct i. -intro K. -exact: measurable_fun_fst. -move=> K. -apply: (measurable_funT_comp (IHl _) (@measurable_fun_snd _ _ _ _)). -apply: K. -Qed.*) - Lemma mvarof (l : seq (string * stype)%type) (i : nat) : measurable_fun setT (@varof l i). Proof. @@ -261,45 +225,25 @@ Qed. End measurable_fun_normalize. -(* Fixpoint denoteType (t : stype) (e : @expD t) := - match e with - | exp_unit => sunit - | exp_bool _ => sbool - | exp_real R _ => sreal - | exp_pair _ _ e1 e2 => spair (denoteType e1) (denoteType e2) - | exp_var l x => nth sunit (map snd l) (seq.index x (map fst l)) - end. *) - -(* Fixpoint execD (l : context) (t : stype) (e : expD t) - : {f : @typei2 R (sprod (map snd l)) -> typei2 (denoteType e) & measurable_fun _ f} := - match e return {f : @typei2 R (sprod (map snd l)) -> typei2 (denoteType e) & measurable_fun _ f} with - | exp_unit => existT _ (cst tt) ktt - | exp_bool b => existT _ (cst b) (kb b) - | exp_real r => existT _ (cst r) (kr r) - | exp_pair _ _ e1 e2 => - existT _ _ (@measurable_fun_pair _ _ _ _ _ _ _ _ (projT2 (execD l e1)) (projT2 (execD l e2))) - | exp_var l x => forall (H : x \in (map fst l)), - existT _ (@varof l (seq.index x (map fst l)) (false_index_size H)) (@mvarof l (seq.index x (map fst l)) (false_index_size H)) - end. *) - Definition eta1 x (l : context) t - (f : projT2 (@typei R (sprod (map snd l))) -> projT2 (@typei R t)) : - projT2 (typei (sprod (map snd (x :: l)))) -> projT2 (@typei R t) := f \o snd. + (f : @typei2 R (slist (map snd l)) -> @typei2 R t) : + typei2 (slist (map snd (x :: l))) -> @typei2 R t := + f \o snd. Lemma meta1 x (l : context) t - (f : projT2 (@typei R (sprod (map snd l))) -> projT2 (@typei R t)) + (f : @typei2 R (slist (map snd l)) -> @typei2 R t) (mf : measurable_fun setT f) : measurable_fun setT (@eta1 x l t f). -Proof. by apply: (measurable_funT_comp mf); exact: measurable_fun_snd. Qed. +Proof. by apply/(measurable_funT_comp mf); exact: measurable_fun_snd. Qed. Definition keta1 (x : string * stype) (l : context) t - (k : R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t) : - (@typei2 R (sprod (map snd (x :: l)))) -> {measure set @typei2 R t -> \bar R} + (k : R.-sfker (@typei2 R (slist (map snd l))) ~> @typei2 R t) : + @typei2 R (slist (map snd (x :: l))) -> {measure set @typei2 R t -> \bar R} := k \o snd. Section kernel_eta1. Variables (x : string * stype) (l : context) (t : stype) - (k : R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t). + (k : R.-sfker (@typei2 R (slist (map snd l))) ~> @typei2 R t). Let mk U : measurable U -> measurable_fun setT ((@keta1 x l t k) ^~ U). Proof. @@ -315,14 +259,14 @@ End kernel_eta1. Section sfkernel. Variables (x : string * stype) (l : context) (t : stype) - (k : R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t). + (k : R.-sfker (@typei2 R (slist (map snd l))) ~> @typei2 R t). -Let sk : exists2 s : (R.-ker (@typei2 R (sprod (map snd (x :: l)))) ~> @typei2 R t)^nat, +Let sk : exists2 s : (R.-ker (@typei2 R (slist (map snd (x :: l)))) ~> @typei2 R t)^nat, forall n, measure_fam_uub (s n) & forall x0 U, measurable U -> (@keta1 x l t k) x0 U = kseries s x0 U . Proof. have [s hs] := sfinite k. -exists (fun n => @keta1 x l t (s n)). +exists (fun n => [the _.-ker _ ~> _ of @keta1 x l t (s n)]). move=> n. have [M hM] := measure_uub (s n). exists M => x0. @@ -338,7 +282,7 @@ End sfkernel. Section fkernel_eta1. Variables (x : string * stype) (l : context) (t : stype) - (k : R.-fker (@typei2 R (sprod (map snd l))) ~> @typei2 R t). + (k : R.-fker (@typei2 R (slist (map snd l))) ~> @typei2 R t). Let uub : measure_fam_uub (@keta1 x l t k). Proof. @@ -370,106 +314,106 @@ with free_varsP T l (e : expP T l) : seq _ := | exp_sample_bern _ _ _ => [::] | exp_score _ e => free_varsD e | exp_return _ _ e => free_varsD e - | expWP _ _ _ e _ => free_varsP e + | expWP _ _ x e _ => free_varsP e (*NB: why different from expWD case?*) end. Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) - (f : projT2 (typei (sprod (map snd l))) -> projT2 (typei T)), + (f : typei2 (slist (map snd l)) -> typei2 T), measurable_fun setT f -> Prop := | E_unit l : - l |- exp_unit -D-> cst tt # ktt + l # exp_unit -D-> cst tt ; ktt | E_bool l b : - l |- exp_bool b -D-> cst b # kb b + l # exp_bool b -D-> cst b ; kb b | E_real l r : - l |- exp_real r -D-> cst r # kr r - -| E_pair l (G := sprod (map snd l)) A B e1 f1 mf1 e2 f2 mf2 : - l |- e1 -D-> f1 # mf1 -> (* (f1 : projT2 (typei G) -> projT2 (typei A)) *) - l |- e2 -D-> f2 # mf2 -> (* (f2 : projT2 (typei G) -> projT2 (typei B)) *) - - l |- exp_pair e1 e2 -D-> fun x => (f1 x, f2 x) # - (@measurable_fun_pair _ _ _ (projT2 (typei G)) (projT2 (typei A)) - (projT2 (typei B)) f1 f2 mf1 mf2) - (* - ((fun x : projT2 (typei G) => (f1 x, f2 x)) - : projT2 (typei G) -> projT2 (typei (spair A B))) - *) - -| E_var (l : context) (x : string) (*(H : x \in map fst l) *) -(* (H' : assoc_get x l = Some _) *) -: + l # exp_real r -D-> cst r ; kr r + +| E_pair l t1 t2 (G := slist (map snd l)) e1 f1 mf1 e2 f2 mf2 : + l # e1 -D-> f1 ; mf1 -> + l # e2 -D-> f2 ; mf2 -> + + l # exp_pair e1 e2 -D-> fun x => (f1 x, f2 x) ; + @measurable_fun_pair _ _ _ (typei2 G) (typei2 t1) (typei2 t2) f1 f2 mf1 mf2 + +| E_var (l : context) (x : string) : let i := seq.index x (map fst l) in - l |- exp_var x _ erefl -D-> @varof l i (*(false_index_size H)*) # - @mvarof l i (*(false_index_size H)*) + l # exp_var x _ erefl -D-> @varof l i ; @mvarof l i | E_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : - l |- exp_bernoulli r r1 -D-> - cst [the probability _ _ of bernoulli r1] # measurable_fun_cst _ - (* sprob sbool *) + l # exp_bernoulli r r1 -D-> + cst [the probability _ _ of bernoulli r1] ; measurable_fun_cst _ | E_poisson l k e f mf : - l |- e -D-> f # mf -> - l |- exp_poisson k e -D-> poisson k \o f # + l # e -D-> f ; mf -> + l # exp_poisson k e -D-> poisson k \o f ; measurable_funT_comp (mpoisson k) mf -| E_norm l (t : stype) (e : expP l t) (k : R.-sfker _ ~> projT2 (typei t)) : - l |- e -P-> k -> - l |- exp_norm e -D-> (normalize k point : _ -> pprobability _ _) # +| E_norm l (t : stype) (e : expP l t) (k : R.-sfker _ ~> typei2 t) : + l # e -P-> k -> + l # exp_norm e -D-> (normalize k point : _ -> pprobability _ _) ; measurable_fun_normalize k -| E_WD l (t : stype) (e : expD l t) x (xl : x \notin l) f mf : - (* x.1 \notin free_varsD e -> *) - l |- e -D-> f # mf -> - (x :: l) |- expWD e xl -D-> (@eta1 x l t f) # (@meta1 x l t f mf) +| E_WD l (t : stype) (e : expD l t) x (xl : x.1 \notin map fst l) f mf : + l # e -D-> f ; mf -> + (x :: l) # expWD e xl -D-> (@eta1 x l t f) ; (@meta1 x l t f mf) -where "l |- e -D-> v # mv" := (@evalD l _ e v mv) +where "l # e -D-> v ; mv" := (@evalD l _ e v mv) with evalP : forall (l : context) (T : stype), expP l T -> - R.-sfker (projT2 (typei (sprod (map snd l)))) ~> projT2 (typei T) -> Prop := + R.-sfker (typei2 (slist (map snd l))) ~> typei2 T -> Prop := | E_sample l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : - (* @evalD l (sprob T) e (cst p) (measurable_fun_cst p) -> *) - l |- @exp_sample_bern R _ r r1 -P-> + l # @exp_sample_bern R _ r r1 -P-> sample [the probability _ _ of bernoulli r1] | E_ifP l T e1 f1 mf e2 k2 e3 k3 : - l |- e1 -D-> f1 # mf -> - l |- e2 -P-> k2 -> - l |- e3 -P-> k3 -> - l |- exp_if e1 e2 e3 : expP l T -P-> ite mf k2 k3 + l # e1 -D-> f1 ; mf -> + l # e2 -P-> k2 -> + l # e3 -P-> k3 -> + l # exp_if e1 e2 e3 : expP l T -P-> ite mf k2 k3 -| E_score l (G := sprod (map snd l)) e (f : projT2 (typei G) -> R) +| E_score l (G := slist (map snd l)) e (f : typei2 G -> R) (mf : measurable_fun _ f) : - l |- e : expD l sreal -D-> f # mf -> - l |- exp_score e -P-> [the R.-sfker _ ~> _ of kscore mf] + l # e : expD l sreal -D-> f ; mf -> + l # exp_score e -P-> [the R.-sfker _ ~> _ of kscore mf] | E_return l T e (f : _ -> _) (mf : measurable_fun _ f) : - l |- e -D-> f # mf -> - l |- exp_return e : expP l T -P-> ret mf + l # e -D-> f ; mf -> + l # exp_return e : expP l T -P-> ret mf -| E_letin (l : context) (G := sprod (map snd l)) (t1 t2 : stype) +| E_letin (l : context) (G := slist (map snd l)) (t1 t2 : stype) (x : string) (e1 : expP l t1) (e2 : expP ((x, t1) :: l) t2) - (k1 : R.-sfker projT2 (typei G) ~> projT2 (typei t1)) - (k2 : R.-sfker (typei2 (spair t1 G)) ~> projT2 (typei t2)) : - l |- e1 -P-> k1 -> - ((x, t1) :: l)%SEQ |- e2 -P-> k2 -> - l |- exp_letin x e1 e2 -P-> letin' k1 k2 + (k1 : R.-sfker (typei2 G) ~> typei2 t1) + (k2 : R.-sfker (typei2 (spair t1 G)) ~> typei2 t2) : + l # e1 -P-> k1 -> + ((x, t1) :: l)%SEQ # e2 -P-> k2 -> + l # exp_letin x e1 e2 -P-> letin' k1 k2 -| E_WP l (t : stype) (e : expP l t) x (xl : x \notin l) k : - l |- e -P-> k -> - (x :: l) |- expWP e xl -P-> [the R.-sfker _ ~> _ of (@keta1 x l t k)] -where "l |- e -P-> v" := (@evalP l _ e v). +| E_WP l (t : stype) (e : expP l t) x (xl : x.1 \notin map fst l) k : + l # e -P-> k -> + (x :: l) # expWP e xl -P-> [the R.-sfker _ ~> _ of @keta1 x l t k] +where "l # e -P-> v" := (@evalP l _ e v). End eval. -Notation "l |- e -D-> v # mv" := (@evalD _ l _ e v mv). -Notation "l |- e -P-> v" := (@evalP _ l _ e v). - -Section eval_prop. -Variables (R : realType). - -Ltac inj H := apply Classical_Prop.EqdepTheory.inj_pair2 in H. +Notation "l # e -D-> v ; mv" := (@evalD _ l _ e v mv) : lang_scope. +Notation "l # e -P-> v" := (@evalP _ l _ e v) : lang_scope. + +Ltac inj_ex H := revert H; + match goal with + | |- existT ?P ?l (existT ?Q ?t (existT ?R ?u (existT ?T ?v ?v1))) = + existT ?P ?l (existT ?Q ?t (existT ?R ?u (existT ?T ?v ?v2))) -> _ => + (intro H; do 4 apply Classical_Prop.EqdepTheory.inj_pair2 in H) + | |- existT ?P ?l (existT ?Q ?t (existT ?R ?u ?v1)) = + existT ?P ?l (existT ?Q ?t (existT ?R ?u ?v2)) -> _ => + (intro H; do 3 apply Classical_Prop.EqdepTheory.inj_pair2 in H) + | |- existT ?P ?l (existT ?Q ?t ?v1) = + existT ?P ?l (existT ?Q ?t ?v2) -> _ => + (intro H; do 2 apply Classical_Prop.EqdepTheory.inj_pair2 in H) + | |- existT ?P ?l ?v1 = + existT ?P ?l ?v2 -> _ => + (intro H; apply Classical_Prop.EqdepTheory.inj_pair2 in H) +end. Scheme evalD_mut_ind := Induction for evalD Sort Prop with evalP_mut_ind := Induction for evalP Sort Prop. @@ -477,690 +421,295 @@ with evalP_mut_ind := Induction for evalP Sort Prop. Scheme expD_mut_ind := Induction for expD Sort Prop with expP_mut_ind := Induction for expP Sort Prop. -Lemma evalD_uniq (l : context) (G := sprod (map snd l)) (t : stype) - (e : expD l t) (u v : projT2 (typei G) -> projT2 (typei t)) - (mu : measurable_fun _ u) (mv : measurable_fun _ v) : - @evalD R l t e u mu -> evalD e mv -> u = v. +Section eval_prop. +Local Open Scope lang_scope. +Variables (R : realType). + +Lemma evalD_uniq (l : context) (G := slist (map snd l)) t + (e : @expD R l t) (u v : typei2 G -> typei2 t) + (mu : measurable_fun setT u) (mv : measurable_fun setT v) : + l # e -D-> u ; mu -> l # e -D-> v ; mv -> u = v. Proof. move=> hu. apply: (@evalD_mut_ind R - (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expD l t) - (f : projT2 (typei G) -> projT2 (typei t)) (mf : measurable_fun setT f) - (h1 : evalD e mf) => forall (v : projT2 (typei G) -> projT2 (typei t)) - (mv : measurable_fun setT v), evalD e mv -> f = v) - (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) - (u : R.-sfker projT2 (typei G) ~> projT2 (typei t)) (h1 : evalP e u) => - forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), - evalP e v -> u = v) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e); last exact: hu. -- move=> l' {}v {}mv. - inversion 1. - by do 2 inj H3. -- move=> l' b {}v {}mv. - inversion 1. - by do 2 inj H3. -- move=> l' r {}v {}mv. - inversion 1. - subst. - by do 2 inj H3. -- (* pair *) move=> l' G0 A B e1 f1 mf1 e2 f2 mf2 ev1 IH1 ev2 IH2 {}v {}mv H. - simple inversion H => //. - injection H3 => ? ?; subst A0 B0 l0. - inj H4. - injection H4 => He1 He2. - do 2 inj He1. - do 2 inj He2. - subst e0 e3. - do 2 inj H5. - move=> e1f0 e2f3. - by rewrite (IH1 _ _ e1f0) (IH2 _ _ e2f3). -- (* var *) move=> l' x (*H*) n {}v {}mv. - inversion 1. - do 2 inj H7. - do 2 inj H6. - done. - (*by have -> : (n = H0) by exact: Prop_irrelevance.*) -- (* bernoulli *) move=> l' r r1 {}v {}mv. - inversion 1. - subst. - do 2 inj H3. - subst. - by have -> : (r1 = r3) by exact: Prop_irrelevance. -- (* poisson *) move=> l' k e0 f mf ev IH {}v {}mv. - inversion 1. - subst. - inj H2. - do 2 inj H4. - subst. + (fun l (G := slist (map snd l)) t (e : expD l t) (f : typei2 G -> typei2 t) + (mf : measurable_fun setT f) (h1 : evalD e mf) => + forall (v : typei2 G -> typei2 t) (mv : measurable_fun setT v), evalD e mv -> f = v) + (fun l (G := slist (map snd l)) t (e : expP l t) + (u : R.-sfker typei2 G ~> typei2 t) (h1 : evalP e u) => + forall (v : R.-sfker typei2 G ~> typei2 t), evalP e v -> u = v)); last exact: hu. +all: (rewrite {l G t e u v mu mv hu}). +- move=> l {}v {}mv. + inversion 1; subst l0. + by inj_ex H3. +- move=> l b {}v {}mv. + inversion 1; subst l0 b0. + by inj_ex H3. +- move=> l r {}v {}mv. + inversion 1; subst l0 r0. + by inj_ex H3. +- move=> l t1 t2 G e1 f1 mf1 e2 f2 mf2 ev1 IH1 ev2 IH2 {}v {}mv. + simple inversion 1 => //; subst l0. + case: H3 => ? ?; subst t0 t3. + inj_ex H4; case: H4 => He1 He2. + inj_ex He1; subst e0. + inj_ex He2; subst e3. + inj_ex H5; subst v. + by move=> /IH1 <- /IH2 <-. +- move=> l x n {}v {}mv. + inversion 1; subst l0 x0. + inj_ex H6. + by inj_ex H7. +- move=> l r r1 {}v {}mv. + inversion 1; subst l0 r0. + inj_ex H3; subst v. + by have -> : r1 = r3 by exact: Prop_irrelevance. +- move=> l k e0 f mf ev IH {}v {}mv. + inversion 1; subst l0 k0. + inj_ex H2; subst e0. + inj_ex H4; subst v. by rewrite (IH _ _ H3). -- (* norm *) move=> l' A e0 k ev IH {}v {}mv. - inversion 1. - do 2 inj H2. - do 2 inj H4. - subst. +- move=> l t e0 k ev IH {}v {}mv. + inversion 1; subst l0 t0. + inj_ex H2; subst e0. + inj_ex H4; subst v. by rewrite (IH _ H3). -- (* W *) move=> l' A e0 x xl f mf ev IH {}v {}mv H. - simple inversion H => // ev0. - subst. - case: H1 => ? ?. - subst. - do 2 inj H3. - do 2 inj H4. - rewrite /eta1. - subst. - case: H3=> H4. - do 2 inj H4. - subst. - by rewrite (IH _ _ ev0). -- (* sample *) move=> l' r r1 p. - inversion 1. - (* do 2 inj H0. *) - do 2 inj H3. - subst. - by have -> : (r1 = r3) by apply: Prop_irrelevance. -- (* if *) move=> l' G0 e0 f1 mf1 e2 k2 e3 k3 ev1 IH1 ev2 IH2 ev3 IH3 k. - inversion 1. - inj H0. - do 2 inj H1. - do 2 inj H2. - subst. - do 2 inj H5. - have ? := IH1 _ _ H6. - subst f1. - have -> : (mf1 = mf) by exact: Prop_irrelevance. +- move=> l t e0 x xl f mf ev IH {}v {}mv. + simple inversion 1 => //; subst t0. + case: H1 => ? ?; subst x0 l0. + inj_ex H3; case: H3 => H3; inj_ex H3; subst e0. + inj_ex H4; subst v. + by move=> /IH <-. +- move=> l r r1 p. + inversion 1; subst l0 r0. + inj_ex H3; subst p. + by have -> : r1 = r3 by exact: Prop_irrelevance. +- move=> l t e0 f1 mf1 e2 k2 e3 k3 ev1 IH1 ev2 IH2 ev3 IH3 k. + inversion 1; subst l0 T. + inj_ex H0; subst e0. + inj_ex H1; subst e4. + inj_ex H5; subst k. + inj_ex H2; subst e5. + have ? := IH1 _ _ H6; subst f2. + have -> : mf1 = mf by exact: Prop_irrelevance. by rewrite (IH2 _ H7) (IH3 _ H8). -- (* score *) move=> l' G0 e0 f mf ev IH k H. - simple inversion H => // ev0. - subst. - do 2 inj H4. - do 2 inj H3. - injection H3 => H5. - inj H5. - subst. - have ? := IH _ _ ev0. - subst f0. - by have -> : (mf = mf0) by exact: Prop_irrelevance. -- (* return *) move=> l' A e0 f mf ev IH k. - inversion 1. - subst. - do 2 inj H5. - do 2 inj H7. - subst. - have ? := IH _ _ H3. - subst f1. - by have -> : (mf = mf1) by exact: Prop_irrelevance. -- (* letin *) move=> l' G0 A B x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. - inversion 1. - subst. - do 2 inj H10. - do 2 inj H7. - do 4 inj H8. - subst. +- move=> l G e0 f mf ev IH k. + simple inversion 1 => //; subst l0. + inj_ex H4; subst k. + inj_ex H3; case: H3 => H3; inj_ex H3; subst e0. + move/IH => ?; subst f0. + by have -> : mf = mf0 by exact: Prop_irrelevance. +- move=> l t e0 f mf ev IH k. + inversion 1; subst l0 T. + inj_ex H5; subst e1. + inj_ex H7; subst k. + have ? := IH _ _ H3; subst f1. + by have -> : mf = mf1 by exact: Prop_irrelevance. +- move=> l G t1 t2 x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. + inversion 1; subst l0 t0 t3 x0. + inj_ex H10; subst k. + inj_ex H8; subst e5. + inj_ex H7; subst e4. by rewrite (IH1 _ H4) (IH2 _ H11). -- move=> l' A e0 x xl k1 ev IH {}k. - inversion 1. - subst A. - do 2 inj H4. - do 2 inj H5. - subst. +- move=> l t e0 x xl k1 ev IH {}k. + inversion 1; subst l0 t0 x0. + inj_ex H4; subst e0. + inj_ex H5; subst k. by rewrite (IH _ H3). Qed. -(* TODO: factorize proof *) -Lemma evalP_uniq (l : context) (t : stype) (e : expP l t) - (u v : R.-sfker typei2 (sprod (map snd l)) ~> typei2 t) : +Lemma evalP_uniq (l : context) t (e : expP l t) + (u v : R.-sfker typei2 (slist (map snd l)) ~> typei2 t) : evalP e u -> evalP e v -> u = v. Proof. move=> hu. apply: (@evalP_mut_ind R - (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expD l t) - (f : projT2 (typei G) -> projT2 (typei t)) + (fun l (G := slist (map snd l)) t (e : expD l t) (f : typei2 G -> typei2 t) (mf : measurable_fun setT f) (h1 : evalD e mf) => - forall (v : projT2 (typei G) -> projT2 (typei t)) (mv : measurable_fun setT v), - evalD e mv -> f = v) - (fun (l : _) (G := sprod (map snd l)) (t : stype) (e : expP l t) - (u : R.-sfker projT2 (typei G) ~> projT2 (typei t)) (h1 : evalP e u) => - forall (v : R.-sfker projT2 (typei G) ~> projT2 (typei t)), - evalP e v -> u = v) - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e); last exact: hu. -- move=> l' {}v {}mv. - inversion 1. - by do 2 inj H3. -- move=> l' b {}v {}mv. - inversion 1. - by do 2 inj H3. -- move=> l' r {}v {}mv. - inversion 1. - subst. - by do 2 inj H3. -- (* pair *) move=> l' G0 A B e1 f1 mf1 e2 f2 mf2 ev1 IH1 ev2 IH2 {}v {}mv H. - simple inversion H => //. - injection H3 => ? ?; subst A0 B0 l0. - inj H4. - injection H4 => He1 He2. - do 2 inj He1. - do 2 inj He2. - subst e0 e3. - do 2 inj H5. + forall (v : typei2 G -> typei2 t) (mv : measurable_fun setT v), evalD e mv -> f = v) + (fun l (G := slist (map snd l)) t (e : expP l t) + (u : R.-sfker typei2 G ~> typei2 t) (h1 : evalP e u) => + forall (v : R.-sfker typei2 G ~> typei2 t), evalP e v -> u = v)); last exact: hu. +all: rewrite {l t e u v hu}. +- move=> l {}v {}mv. + inversion 1; subst l0. + by inj_ex H3. +- move=> l b {}v {}mv. + inversion 1; subst l0 b0. + by inj_ex H3. +- move=> l r {}v {}mv. + inversion 1; subst l0 r0. + by inj_ex H3. +- move=> l t1 t2 G e1 f1 mf1 e2 f2 mf2 ev1 IH1 ev2 IH2 {}v {}mv. + simple inversion 1 => //; subst l0. + case: H3 => ? ?; subst t0 t3. + inj_ex H4; case: H4 => He1 He2. + inj_ex He1; subst e0. + inj_ex He2; subst e3. + inj_ex H5; subst v. move=> e1f0 e2f3. by rewrite (IH1 _ _ e1f0) (IH2 _ _ e2f3). -- (* var *) move=> l' x (*H*) n {}v {}mv. - inversion 1. - do 2 inj H7. - do 2 inj H6. - done. - (*by have -> : (n = H0) by exact: Prop_irrelevance.*) -- (* bernoulli *) move=> l' r r1 {}v {}mv. - inversion 1. - subst. - do 2 inj H3. - subst. - by have -> : (r1 = r3) by exact: Prop_irrelevance. -- (* poisson *) move=> l' k e0 f mf ev IH {}v {}mv. - inversion 1. - subst. - inj H2. - do 2 inj H4; clear H5. - subst. +- move=> l x n {}v {}mv. + inversion 1; subst l0. + inj_ex H7; subst v. + by inj_ex H6. +- move=> l r r1 {}v {}mv. + inversion 1; subst l0 r0. + inj_ex H3; subst v. + by have -> : r1 = r3 by exact: Prop_irrelevance. +- move=> l k e f mf ev IH {}v {}mv. + inversion 1; subst l0 k0. + inj_ex H2; subst e0. + inj_ex H4; subst v. + inj_ex H5; subst mv. by rewrite (IH _ _ H3). -- (* norm *) move=> l' A e0 k ev IH {}v {}mv. - inversion 1. - do 2 inj H2. - do 2 inj H4. - subst. +- move=> l t e k ev IH {}v {}mv. + inversion 1; subst l0 t0. + inj_ex H2; subst e0. + inj_ex H4; subst v. + inj_ex H5; subst mv. by rewrite (IH _ H3). -- (* W *) move=> l' A e0 x xl f mf ev IH {}v {}mv H. - simple inversion H => // ev0. - subst. - case: H1 => ? ?. - subst. - do 2 inj H3. - do 2 inj H4. - rewrite /eta1. - subst. - case: H3=> H4. - do 2 inj H4. - subst. - by rewrite (IH _ _ ev0). -- (* sample *) move=> l' r r1 ev. - inversion 1. - (* do 2 inj H0. *) - do 2 inj H3. - subst. +- move=> l t e x xl f mf ev IH {}v {}mv. + simple inversion 1 => //; subst t0. + case: H1 => ? ?; subst x0 l0. + inj_ex H3; case: H3 => H3. + inj_ex H3; subst e0. + inj_ex H4; subst v. + inj_ex H5; subst mv. + by move/IH => <-. +- move=> l r r1 ev. + inversion 1; subst l0 r0. + inj_ex H3; subst ev. by have -> : r1 = r3 by exact: Prop_irrelevance. -- (* if *) move=> l' G0 e0 f1 mf1 e2 k2 e3 k3 ev1 IH1 ev2 IH2 ev3 IH3 k. - inversion 1. - inj H0. - do 2 inj H1. - do 2 inj H2. - subst. - do 2 inj H5. - have ? := IH1 _ _ H6. - subst f1. - have -> : mf1 = mf by exact: Prop_irrelevance. - by rewrite (IH2 _ H7) (IH3 _ H8). -- (* score *) move=> l' G0 e0 f mf ev IH k H. - simple inversion H => // ev0. - subst. - do 2 inj H4. - do 2 inj H3. - injection H3 => H5. - inj H5. - subst. - have ? := IH _ _ ev0. - subst f0. +- move=> l t e f mf e1 k1 e2 k2 ev IH ev1 IH1 ev2 IH2 k. + inversion 1; subst l0 T. + inj_ex H0; subst e0. + inj_ex H1; subst e3. + inj_ex H5; subst k. + inj_ex H2; subst e4. + have ? := IH _ _ H6; subst f0. + have -> : mf0 = mf by exact: Prop_irrelevance. + by rewrite (IH1 _ H7) (IH2 _ H8). +- move=> l G e f mf ev IH k. + simple inversion 1 => //; subst l0. + inj_ex H4; subst k. + inj_ex H3; case: H3 => H3; inj_ex H3; subst e0. + move=> /IH ?; subst f0. by have -> : mf = mf0 by exact: Prop_irrelevance. -- (* return *) move=> l' A e0 f mf ev IH k. - inversion 1. - subst. - do 2 inj H5. - do 2 inj H7. - subst. - have ? := IH _ _ H3. - subst f1. +- move=> l t e f mf ev IH k. + inversion 1; subst T l0. + inj_ex H7; subst k. + inj_ex H5; subst e1. + have ? := IH _ _ H3; subst f1. by have -> : mf = mf1 by exact: Prop_irrelevance. -- (* letin *) move=> l' G0 A B x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. - inversion 1. - subst. - do 2 inj H10. - do 2 inj H7. - do 4 inj H8. - subst. +- move=> l G t1 t2 x e1 e2 k1 k2 ev1 IH1 ev2 IH2 k. + inversion 1; subst l0 x0 t3 t0. + inj_ex H10; subst k. + inj_ex H7; subst e4. + inj_ex H8; subst e5. by rewrite (IH1 _ H4) (IH2 _ H11). -- move=> l' A e0 x xl k1 ev IH {}k. - inversion 1. - subst A. - do 2 inj H4. - do 2 inj H5. - subst. +- move=> l t e x xl k1 ev IH {}k. + inversion 1; subst x0 l0 t0. + inj_ex H4; subst e0. + inj_ex H5; subst k. by rewrite (IH _ H3). Qed. -Lemma evalD_full (l : context) (t : stype) : forall e, - (* {subset (free_varsD e) <= map fst l} -> *) +Lemma evalD_full (l : context) (t : stype) e : exists f (mf : measurable_fun _ f), @evalD R l t e f mf. Proof. -move=> e. apply: (@expD_mut_ind R - (fun (l : context) (t : stype) (e : expD l t) => - (*{subset (free_varsD e) <= map fst l} ->*) - exists f (mf : measurable_fun _ f), evalD e mf) - (fun (l : context) (t : stype) (e : expP l t) => - (* {subset (free_varsP e) <= map fst l} -> *) - exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). -- move=> l0 st x e1 H1 xl0. - destruct H1 as [f [mf]]. - exists (eta1 f). - exists (meta1 mf). - exact/E_WD. -- by do 2 eexists; apply/E_unit. -- by do 2 eexists; apply/E_bool. -- by do 2 eexists; apply/E_real. -- move=> l0 t1 t2 e1 H1 e2 H2. - destruct H1 as [f1 [mf1]]. - destruct H2 as [f2 [mf2]]. - exists (fun x => (f1 x, f2 x)). - eexists. - exact: E_pair. -- move=> l0 x t0 (*xl0*) t0E. - subst t0. - eexists. - eexists. - by apply/E_var. -- move=> r r1. - eexists. - eexists. - exact: E_bernoulli. -- move=> l0 k e0 H. - destruct H as [f [mf]]. - exists (poisson k \o f). - exists (measurable_funT_comp (mpoisson k) mf). + (fun l t (e : expD l t) => exists f (mf : measurable_fun setT f), evalD e mf) + (fun l t (e : expP l t) => exists k, evalP e k)). +all: rewrite {l t e}. +- move=> l st x e [f [mf fmf]] xl. + by exists (eta1 f), (meta1 mf); exact/E_WD. +- by do 2 eexists; exact: E_unit. +- by do 2 eexists; exact: E_bool. +- by do 2 eexists; exact: E_real. +- move=> l t1 t2 e1 [f1 [mf1 H1]] e2 [f2 [mf2 H2]]. + by exists (fun x => (f1 x, f2 x)); eexists; exact: E_pair. +- by move=> l x t tE; subst t; eexists; eexists; exact: E_var. +- by move=> r r1; eexists; eexists; exact: E_bernoulli. +- move=> l k e [f [mf H]]. + exists (poisson k \o f), (measurable_funT_comp (mpoisson k) mf). exact: E_poisson. -- move=> l0 t0 e0 H. - destruct H as [k]. - exists (normalize k point). - exists (measurable_fun_normalize k). - exact: E_norm. -- move=> l0 st x e1 H1 xl0. - destruct H1 as [k]. - exists (@keta1 R x l0 st k). - exact/E_WP. -- move=> l0 t0 e1 H1 e2 H2 e3 H3. - destruct H1 as [f [mf]]. - destruct H2 as [k2]. - destruct H3 as [k3]. - exists (ite mf k2 k3). - exact: E_ifP. -- move=> l0 t1 t2 x e1 H1 e2 H2. - destruct H1 as [k1 ev1]. - destruct H2 as [k2 ev2]. - subst. - exists (letin' k1 k2). - exact: E_letin. -- move=> l0 r r1. - exists (sample [the pprobability _ _ of bernoulli r1]). - exact: E_sample. -- move=> l0 e0 [f [mf f_mf]]. - exists (score mf). - exact: E_score. -- move=> l0 t0 e0 [f [mf f_mf]]. - exists (ret mf). - exact: E_return. +- move=> l t e [k H]. + by exists (normalize k point), (measurable_fun_normalize k); exact: E_norm. +- move=> l st x e [k H1] xl. + by exists [the _.-sfker _ ~> _ of keta1 k]; exact: E_WP. +- move=> l t e1 [f [mf H1]] e2 [k2 H2] e3 [k3 H3]. + by exists (ite mf k2 k3); exact: E_ifP. +- move=> l t1 t2 x e1 [k1 ev1] e2 [k2 ev2]. + by exists (letin' k1 k2); exact: E_letin. +- move=> l r r1. + by exists (sample [the pprobability _ _ of bernoulli r1]); exact: E_sample. +- move=> l e [f [mf f_mf]]. + by exists (score mf); exact: E_score. +- by move=> l t e [f [mf f_mf]]; exists (ret mf); exact: E_return. Qed. -(* move=> l0 st x e1 H1 xl0. -have h1 : {subset free_varsD e1 <= map fst (x :: l0)}. - move=> x0 x0e1. - (* have [|] := eqVneq x0 x.1. - have /= := el x0. - have : (x0 \in free_varsD (expWD (x:=x) e1 xl0)). - rewrite /free_varsD. - fold (free_varsD e1). - rewrite inE =>/orP[|//]. *) - admit. -have h2 : {subset l0 <= x :: l0}. - -move: H1 => /(_ _ h1) => H1. -destruct H1 as [f [mf]]. -exists (eta1 f). -eexists. -(* exists (meta1 f). *) -exact/E_WD. -do 2 eexists; apply/E_unit. -do 2 eexists; apply/E_bool. -do 2 eexists; apply/E_real. -move=> l0 t1 t2 e1 H1 e2 H2 el. -have h1 : {subset free_varsD e1 <= [seq i.1 | i <- l0]}. - move=> x xe1. - apply: el => /=. - by rewrite mem_cat xe1. -have h2 : {subset free_varsD e2 <= [seq i.1 | i <- l0]}. - move=> x xe2. - apply: el => /=. - by rewrite mem_cat xe2 orbT. -move: H1 => /(_ h1) => H1. -move: H2 => /(_ h2) => H2. -destruct H1 as [f1 [mf1]]. -destruct H2 as [f2 [mf2]]. -exists (fun x => (f1 x, f2 x)). -eexists; exact: E_pair. -move=> l0 x t0 t0E H. -subst t0. -have xl0 : x \in map fst l0. -apply: H. -by rewrite /= inE. -(* exists (@varof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). *) -(* exists (@mvarof R l0 (seq.index x (map fst l0)) (false_index_size xl0)). *) -do 2 eexists. -by apply/E_var. -move=> r r1. -eexists. -eexists. -exact: E_bernoulli. -move=> l0 k e0 H el. -have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. - move=> x xe0. - by apply: el => /=. -move: H => /(_ h) => H. -destruct H as [f [mf]]. -exists (poisson k \o f). -exists (measurable_funT_comp (mpoisson k) mf). -exact: E_poisson. -move=> l0 t0 e0 H el. -have h : {subset free_varsP e0 <= map fst l0}. - move=> x xe0. - by apply: el => /=. -move: H => /(_ h) => H. -destruct H as [k]. -exists (normalize k point). -exists (measurable_fun_normalize k). -exact: E_norm. -move=> l0 st x e1 H1 xl0 el. -have h1 : {subset free_varsP e1 <= map fst l0}. - move=> x0 x0e0. - admit. - (* by apply: el => /=. *) -move: H1 => /(_ h1) => H1. -destruct H1 as [k]. -exists (@eta_kernel R x l0 st k). -exact/E_WP. -move=> l0 t0 e1 H1 e2 H2 e3 H3 el. -have h1 : {subset free_varsD e1 <= map fst l0}. - move=> x xe1. - apply: el => /=. - by rewrite mem_cat xe1. -have h2 : {subset free_varsP e2 <= map fst l0}. - move=> x xe2. - apply: el => /=. - by rewrite 2!mem_cat xe2 orbT. -have h3 : {subset free_varsP e3 <= map fst l0}. - move=> x xe3. - apply: el => /=. - by rewrite 2!mem_cat xe3 2!orbT. -move: H1 => /(_ h1) => H1. -move: H2 => /(_ h2) => H2. -move: H3 => /(_ h3) => H3. -destruct H1 as [f [mf]]. -destruct H2 as [k2]. -destruct H3 as [k3]. -exists (ite mf k2 k3). -exact: E_ifP. -move=> l0 l1 t1 t2 x l1l0 e1 H1 e2 H2 el. -have h1 : {subset free_varsP e1 <= map fst l0}. - move=> y ye1. - apply: el => /=. - by rewrite mem_cat ye1. -have h2 : {subset free_varsP e2 <= map fst ((x, t1) :: l0)}. - move=> y ye2. - rewrite /= inE. - have [//|/= xy] := eqVneq x y. - apply: el => /=. - rewrite mem_cat. - apply/orP. - right. - move: ye2 xy. - move: (free_varsP e2). - (* TODO: extract lemma *) - elim=> // h tl ih /=; rewrite inE => /orP[/eqP <-|yt xy]. - by move/negbTE; rewrite eq_sym => ->; rewrite mem_head. - by case: ifPn => // hx; rewrite inE ih ?orbT. -subst l1. -move: H1 => /(_ h1) => H1. -move: H2 => /(_ h2) => H2. -destruct H1 as [k1 ev1]. -destruct H2 as [k2 ev2]. -exists (letin' k1 k2). -exact: E_letin. -move=> l0 r r1 el. -exists (sample [the pprobability _ _ of bernoulli r1]). -exact: E_sample. -move=> l0 e0 H el. -have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. - move=> x xe0. - by apply: el => /=. -move: H => /(_ h) => H. -destruct H as [f [mf]]. -exists (score mf). -exact: E_score. -move=> l0 t0 e0 H el. -have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. - move=> x xe0. - by apply: el => /=. -move: H => /(_ h) => H. -destruct H as [f [mf]]. -exists (ret mf). -exact: E_return. -Admitted. *) - Lemma evalP_full (l : context) (t : stype) e : - (* {subset (free_varsP e) <= map fst l} -> *) exists (k : R.-sfker _ ~> _), @evalP R l t e k. Proof. apply: (@expP_mut_ind R - (fun (l : context) (t : stype) (e : expD l t) => - (* {subset (free_varsD e) <= map fst l} -> *) - exists f (mf : measurable_fun _ f), evalD e mf) - (fun (l : context) (t : stype) (e : expP l t) => - (* {subset (free_varsP e) <= map fst l} -> *) - exists k, evalP e k) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l t e). -- move=> l0 st x e1 H1 xl0. - destruct H1 as [f [mf]]. - exists (eta1 f). - exists (meta1 mf). - exact/E_WD. -- by do 2 eexists; apply/E_unit. -- by do 2 eexists; apply/E_bool. -- by do 2 eexists; apply/E_real. -- move=> l0 t1 t2 e1 H1 e2 H2. - destruct H1 as [f1 [mf1]]. - destruct H2 as [f2 [mf2]]. - exists (fun x => (f1 x, f2 x)). - eexists; exact: E_pair. -- move=> l0 x t0 (*xl0*) t0E. - subst t0. - eexists. - eexists. - by apply/E_var. -- move=> r r1. - eexists. - eexists. - exact: E_bernoulli. -- move=> l0 k e0 H. - destruct H as [f [mf]]. - exists (poisson k \o f). - exists (measurable_funT_comp (mpoisson k) mf). + (fun l t (e : expD l t) => exists f (mf : measurable_fun _ f), evalD e mf) + (fun l t (e : expP l t) => exists k, evalP e k)). +all: rewrite {l t e}. +- move=> l t x e [f [mf H]] xl. + by exists (eta1 f), (meta1 mf); exact: E_WD. +- by do 2 eexists; exact: E_unit. +- by do 2 eexists; exact: E_bool. +- by do 2 eexists; exact: E_real. +- move=> l t1 t2 e1 [f1 [mf1 H1]] e2 [f2 [mf2 H2]]. + by exists (fun x => (f1 x, f2 x)); eexists; exact: E_pair. +- by move=> l x t tE; subst t; eexists; eexists; exact: E_var. +- by move=> r r1; eexists; eexists; exact: E_bernoulli. +- move=> l k e [f [mf H]]. + exists (poisson k \o f), (measurable_funT_comp (mpoisson k) mf). exact: E_poisson. -- move=> l0 t0 e0 H. - destruct H as [k]. - exists (normalize k point). - exists (measurable_fun_normalize k). - exact: E_norm. -- move=> l0 st x e1 H1 xl0. - destruct H1 as [k]. - exists (@keta1 R x l0 st k). - exact/E_WP. -- move=> l0 t0 e1 H1 e2 H2 e3 H3. - destruct H1 as [f [mf]]. - destruct H2 as [k2]. - destruct H3 as [k3]. - exists (ite mf k2 k3). - exact: E_ifP. -- move=> l0 t1 t2 x e1 H1 e2 H2. - destruct H1 as [k1 ev1]. - destruct H2 as [k2 ev2]. - subst. - exists (letin' k1 k2). - exact: E_letin. -- move=> l0 r r1. - exists (sample [the pprobability _ _ of bernoulli r1]). - exact: E_sample. -- move=> l0 e0 H. - destruct H as [f [mf]]. - exists (score mf). - exact: E_score. -- move=> l0 t0 e0 H. - destruct H as [f [mf]]. - exists (ret mf). - exact: E_return. +- move=> l t e []k H. + by exists (normalize k point), (measurable_fun_normalize k); exact: E_norm. +- move=> l s x e [k H1] xl. + by exists [the _.-sfker _ ~> _ of keta1 k]; exact: E_WP. +- move=> l t e1 [f [mf H1]] e2 [k2 H2] e3 [k3 H3]. + by exists (ite mf k2 k3); exact: E_ifP. +- move=> l t1 t2 x e1 [k1 ev1] e2 [k2 ev2]. + by exists (letin' k1 k2); exact: E_letin. +- move=> l r r1. + by exists (sample [the pprobability _ _ of bernoulli r1]); exact: E_sample. +- by move=> l e [f [mf H]]; exists (score mf); exact: E_score. +- by move=> l t e [f [mf H]]; exists (ret mf); exact: E_return. Qed. -(* admit. -do 2 eexists; apply/E_unit. -do 2 eexists; apply/E_bool. -do 2 eexists; apply/E_real. -move=> l0 t1 t2 e1 H1 e2 H2 el. -have h1 : {subset free_varsD e1 <= [seq i.1 | i <- l0]}. - move=> x xe1. - apply: el => /=. - by rewrite mem_cat xe1. -have h2 : {subset free_varsD e2 <= [seq i.1 | i <- l0]}. - move=> x xe2. - apply: el => /=. - by rewrite mem_cat xe2 orbT. -move: H1 => /(_ h1) => H1. -move: H2 => /(_ h2) => H2. -destruct H1 as [f1 [mf1]]. -destruct H2 as [f2 [mf2]]. -exists (fun x => (f1 x, f2 x)). -eexists; exact: E_pair. -move=> l0 x t0 t0E H. -subst t0. -have xl0 : x \in map fst l0. -apply: H. -by rewrite /= inE. -do 2 eexists. -by apply/E_var. -move=> r r1. -eexists. -eexists. -exact: E_bernoulli. -move=> l0 k e0 H el. -have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. - move=> x xe0. - by apply: el => /=. -move: H => /(_ h) => H. -destruct H as [f [mf]]. -exists (poisson k \o f). -exists (measurable_funT_comp (mpoisson k) mf). -exact: E_poisson. -move=> l0 t0 e0 H el. -have h : {subset free_varsP e0 <= map fst l0}. - move=> x xe0. - by apply: el => /=. -move: H => /(_ h) => H. -destruct H as [k]. -exists (normalize k point). -exists (measurable_fun_normalize k). -exact: E_norm. -admit. -move=> l0 t0 e1 H1 e2 H2 e3 H3 el. -have h1 : {subset free_varsD e1 <= map fst l0}. - move=> x xe1. - apply: el => /=. - by rewrite mem_cat xe1. -have h2 : {subset free_varsP e2 <= map fst l0}. - move=> x xe2. - apply: el => /=. - by rewrite 2!mem_cat xe2 orbT. -have h3 : {subset free_varsP e3 <= map fst l0}. - move=> x xe3. - apply: el => /=. - by rewrite 2!mem_cat xe3 2!orbT. -move: H1 => /(_ h1) => H1. -move: H2 => /(_ h2) => H2. -move: H3 => /(_ h3) => H3. -destruct H1 as [f [mf]]. -destruct H2 as [k2]. -destruct H3 as [k3]. -exists (ite mf k2 k3). -exact: E_ifP. -move=> l0 l1 t1 t2 x l1l0 e1 H1 e2 H2 el. -have h1 : {subset free_varsP e1 <= map fst l0}. - move=> y ye1. - apply: el => /=. - by rewrite mem_cat ye1. -have h2 : {subset free_varsP e2 <= map fst ((x, t1) :: l0)}. - move=> y ye2. - rewrite /= inE. - have [//|/= xy] := eqVneq x y. - apply: el => /=. - rewrite mem_cat. - apply/orP. - right. - move: ye2 xy. - move: (free_varsP e2). - (* TODO: extract lemma *) - elim=> // h tl ih /=; rewrite inE => /orP[/eqP <-|yt xy]. - by move/negbTE; rewrite eq_sym => ->; rewrite mem_head. - by case: ifPn => // hx; rewrite inE ih ?orbT. -subst l1. -move: H1 => /(_ h1) => H1. -move: H2 => /(_ h2) => H2. -destruct H1 as [k1 ev1]. -destruct H2 as [k2 ev2]. -exists (letin' k1 k2). -exact: E_letin. -move=> l0 r r1 el. -exists (sample [the pprobability _ _ of bernoulli r1]). -exact: E_sample. -move=> l0 e0 H el. -have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. - move=> x xe0. - by apply: el => /=. -move: H => /(_ h) => H. -destruct H as [f [mf]]. -exists (score mf). -exact: E_score. -move=> l0 t0 e0 H el. -have h : {subset free_varsD e0 <= [seq i.1 | i <- l0]}. - move=> x xe0. - by apply: el => /=. -move: H => /(_ h) => H. -destruct H as [f [mf]]. -exists (ret mf). -exact: E_return. -Admitted. *) - -(* Variables (A B C : stype). -Definition X := @typei2 R A. -Definition Y := @typei2 R B. -Definition Z := @typei2 R C. *) - Definition execP l t (e : @expP R l t) : - R.-sfker (@typei2 R (sprod (map snd l))) ~> @typei2 R t. + R.-sfker (@typei2 R (slist (map snd l))) ~> @typei2 R t. Proof. have /cid h := @evalP_full l t e. exact: (proj1_sig h). Defined. -Definition execP_cst (l l' : context) (r : R) : - R.-sfker (@typei2 R (sprod (map (@snd string stype) l'))) ~> @typei2 R sreal. +Lemma evalP_execP l t e : l # e -P-> @execP l t e. +Proof. by rewrite /execP/= /sval /ssr_have/=; case: cid. Qed. + +Definition execD l t (e : @expD R l t) : + {f : (@typei2 R (slist (map snd l))) -> @typei2 R t & measurable_fun setT f}. Proof. -have H0 : {subset free_varsP (exp_return (exp_real r) : expP [::] _) <= map (@fst string stype) l'}. - by move=> x /=. -have /cid h := @evalP_full l' _ (exp_return (exp_real r)). -exact: (proj1_sig h). +have /cid [f /cid[mf H]] := @evalD_full l t e. +by exists f. +Defined. + +Lemma evalD_execD l t e : let: x := @execD l t e in + l # e -D-> projT1 x ; projT2 x. +Proof. +rewrite /execD /ssr_have /= /sval /=; case: cid => f [mf ef]. +by case: cid. Defined. +Definition execP_ret_real (l : context) (r : R) : + R.-sfker (@typei2 R (slist (map snd l))) ~> @typei2 R sreal := + execP (exp_return (exp_real r)). + Scheme expD_mut_rec := Induction for expD Sort Type with expP_mut_rec := Induction for expP Sort Type. @@ -1224,10 +773,9 @@ Abort. Axiom same_expP : forall (l l' : context) (T : stype) (e : @expP R T l) (e' : @expP R T l'), Prop. *) - Lemma evalP_uni_new x r (u : R.-sfker munit ~> mR R) - (v : R.-sfker projT2 (typei (sprod [seq i.2 | i <- [:: (x, sreal)]])) ~> mR R) : + (v : R.-sfker (typei2 (slist [seq i.2 | i <- [:: (x, sreal)]])) ~> mR R) : evalP (exp_return (exp_real r) : expP [::] sreal) u -> evalP (exp_return (exp_real r) : expP [:: (x, sreal)] sreal) v -> forall x0 t, v (x0, t) = u t. @@ -1274,7 +822,7 @@ Admitted. Next Obligation. Admitted. -Definition vx : R.-sfker munit ~> mR R := execP_cst [:: ("x", sreal)] [::] 1. +(*Definition vx : R.-sfker munit ~> mR R := execP_ret_real [::] 1. Definition VX z : set (mR R) -> \bar R := vx z. Let VX0 z : (VX z) set0 = 0. Proof. by []. Qed. Let VX_ge0 z x : 0 <= (VX z) x. Proof. by []. Qed. @@ -1286,7 +834,7 @@ Let sfinVX z : sfinite_measure (VX z). Proof. exact: sfinite_kernel_measure. Qed HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ (mR R) R (VX z) (sfinVX z). -Definition vy' : R.-sfker munit ~> mR R := execP_cst [::] [::] 2. +Definition vy' : R.-sfker munit ~> mR R := execP_ret_real [::] 2. Definition VY z : set (mR R) -> \bar R := vy' z. Let VY0 z : (VY z) set0 = 0. Proof. by []. Qed. Let VY_ge0 z x : 0 <= (VY z) x. Proof. by []. Qed. @@ -1296,34 +844,13 @@ HB.instance Definition _ z := @isMeasure.Build _ R (mR R) (VY z) (VY0 z) (VY_ge0 z) (@VY_semi_sigma_additive z). Let sfinVY z : sfinite_measure (VY z). Proof. exact: sfinite_kernel_measure. Qed. HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ (mR R) R - (VY z) (sfinVY z). + (VY z) (sfinVY z).*) End eval_prop. -Definition context_of_expP R (l : context) (s : stype) (e : @expP R l s) := l. - -Declare Custom Entry expr. -Notation "[ e ]" := e (e custom expr at level 5). -Notation "x ':r'" := (@exp_real _ _ x%R) (in custom expr at level 1). -Notation "'Ret' x" := (@exp_return _ _ _ x) (in custom expr at level 2). -Notation "% x" := (@exp_var _ _ x _ erefl) (in custom expr at level 1). -Notation "%WP x # e" := (@expWP _ _ _ (x, _) e erefl) (in custom expr at level 1). -Notation "( x , y )" := (exp_pair x y) (in custom expr at level 1). -Notation "'Let' x '<~' e 'In' f" := (exp_letin x e f) - (in custom expr at level 3, - x constr, - (* e custom expr at level 2, *) - f custom expr at level 3, - left associativity). -(*Notation "( x )" := x (in custom expr, x at level 50).*) -Notation "'If' e1 'Then' e2 'Else' e3" := (exp_if e1 e2 e3) (in custom expr at level 1). -Notation "{ x }" := x (in custom expr, x constr). -Notation "x" := x (in custom expr at level 0, x ident). - - Section example. - Local Open Scope ring_scope. +Local Open Scope lang_scope. Variables (R : realType). Example __ : @evalD R [::] _ [{3}:r] (cst 3) (kr 3). @@ -1390,21 +917,19 @@ Definition exp_var' (x : string) (t : stype) (g : find x t) := Notation "%1 x" := (@exp_var' x%string _ _) (in custom expr at level 1). -Example pgm1 := exp_norm ( +Example staton_bus_exp := exp_norm ( [Let "x" <~ {exp_sample_bern [::] (2 / 7%:R)%:nng p27} In Let "r" <~ If %1{"x"} Then Ret {3}:r Else Ret {10}:r In Let "_" <~ {exp_score (exp_poisson 4 [%1{"r"}])} In Ret %1{"x"}]). -Print pgm1. - Definition sample_bern : R.-sfker munit ~> mbool := sample [the probability _ _ of bernoulli p27]. Definition ite_3_10 : R.-sfker [the measurableType _ of (mbool * munit)%type] ~> (mR R) := ite var1of4' (ret k3) (ret k10). Definition score_poi : - R.-sfker [the measurableType _ of ((mR R) * (mbool * munit)%type)%type] ~> munit := + R.-sfker [the measurableType _ of (mR R * (mbool * munit))%type] ~> munit := score (measurable_funT_comp (mpoisson 4) var1of4'). Local Definition kstaton_bus'' := @@ -1412,363 +937,234 @@ Local Definition kstaton_bus'' := (letin' ite_3_10 (letin' score_poi (ret var3of4'))). -Example ev1 : @evalD R [::] _ pgm1 _ (measurable_fun_normalize kstaton_bus''). +Example eval_staton_bus_exp : + [::] # staton_bus_exp -D-> _ ; measurable_fun_normalize kstaton_bus''. Proof. -apply/E_norm /E_letin /E_letin /E_letin. -- by apply/E_sample. -- apply/E_ifP. - + rewrite /exp_var' /=. - set l := (X in X |- _ -D-> _ # _). +apply/E_norm/E_letin. +- exact/E_sample. +- apply/E_letin. + + apply/E_ifP. + * rewrite /exp_var' /=. + rewrite (_ : left_pf _ _ _ = erefl) //. + set l := (X in X # _ -D-> _ ; _). + rewrite (_ : var1of2 = @mvarof R l 0)//. + exact: (E_var R l "x"). + * exact/E_return/E_real. + * exact/E_return/E_real. +- apply: E_letin. + + apply/E_score/E_poisson. + rewrite /exp_var'/=. rewrite (_ : left_pf _ _ _ = erefl) //. + set l := (X in X # _ -D-> _ ; _). rewrite (_ : var1of2 = @mvarof R l 0)//. + exact: (@E_var R l "r"). + + apply/E_return. + rewrite /exp_var'/=. + rewrite (_ : right_pf _ _ _ = erefl) //. + set l := (X in X # _ -D-> _ ; _). + rewrite (_ : var3of4' = @mvarof R l 2)//. exact: (@E_var R l "x"). - + by apply/E_return /E_real. - + by apply/E_return /E_real. -- apply/E_score /E_poisson. - set l := (X in X |- _ -D-> _ # _). - rewrite /exp_var'/=. - rewrite (_ : left_pf _ _ _ = erefl) //. - rewrite (_ : var1of2 = @mvarof R l 0)//. - exact: (@E_var R l "r"). -- apply/E_return. - set l := (X in X |- _ -D-> _ # _). - rewrite /exp_var'/=. - rewrite (_ : right_pf _ _ _ = erefl) //. - rewrite (_ : var3of4' = @mvarof R l 2)//. - exact: (@E_var R l "x"). Qed. End example. Section letinC. +Local Open Scope lang_scope. Variable R : realType. -(* Check [Let "x" <~ Ret {1}:r In Ret %{"x"}]. -Check [Let "x" <~ Ret {1}:r In - Let "y" <~ Ret {2}:r In - Ret (%{"x"} # {[:: ("y", sreal); ("x", sreal)]}, %{"y"} # {[:: ("y", sreal); ("x", sreal)]})]. *) - -Lemma letinC12 v1 v2 t M : - let x := "x" in - let y := "y" in - (* let s1 := [:: (y, sreal); (x, sreal)] in - let s2 := [:: (x, sreal); (y, sreal)] in *) - measurable M -> - [::] |- [Let x <~ Ret {1}:r In - Let y <~ Ret {2}:r In - Ret (%x, %y)] : @expP R _ _ -P-> v1 - -> - [::] |- [Let y <~ Ret {2}:r In - Let x <~ Ret {1}:r In - Ret (%x, %y)] -P-> v2 -> - v1 t M = v2 t M. +Lemma execP_WP_keta1 x l (st : stype_eqType) (e : expP l st) (xl : x.1 \notin map fst l) : + execP (@expWP R l st _ e xl) = [the _.-sfker _ ~> _ of keta1 (execP e)]. Proof. -set d := (x in (projT1 x).-measurable _). -rewrite -/d in M v1 v2 *. -move=> x y mM ev1 ev2. -pose vx : R.-sfker munit ~> mR R := execP_cst [:: (x, sreal)] [::] 1. -pose vy : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := - execP_cst [:: (x, sreal)] [:: (x, sreal)] 2. -have -> : v1 = - letin' (vx) (letin' (vy) (ret (measurable_fun_pair var2of3' var1of3'))). -apply: (evalP_uniq ev1). -apply/E_letin /E_letin. -rewrite /vx /execP_cst/= /sval/=. -by case: cid => // ? h. -rewrite /vy /execP_cst /sval/=. -by case: cid => // ? h. -apply/E_return /E_pair. -have -> : (var2of3' = (@mvarof R [:: (y, sreal); (x, sreal)] 1 )) by []. -apply/(@E_var R [:: (y, sreal); (x, sreal)] x). -have -> : (var1of4' = (@mvarof R [:: (y, sreal); (x, sreal)] 0 )) by []. -apply/(@E_var R [:: (y, sreal); (x, sreal)] y). -pose vy' : R.-sfker munit ~> mR R := execP_cst [::] [::] 2. -pose vx' : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := execP_cst [:: (y, sreal)] [:: (y, sreal)] 1. -have -> : v2 = letin' (vy') (letin' (vx') (ret (measurable_fun_pair var1of3' var2of3'))). -apply: (evalP_uniq ev2). -apply/E_letin /E_letin. -rewrite /vy' /execP_cst /sval/=. -case: cid => //. -rewrite /vx' /execP_cst /sval/=. -case: cid => //. -apply/E_return /E_pair. -have -> : (var1of3' = (@mvarof R [:: (x, sreal); (y, sreal)] 0 )) by []. -apply/(@E_var R [:: (x, sreal); (y, sreal)] x). -have -> : (var2of3' = (@mvarof R [:: (x, sreal); (y, sreal)] 1 )) by []. -apply/(@E_var R [:: (x, sreal); (y, sreal)] y). -apply: letin'C; last by []. -move=> x0 t0. -rewrite (@evalP_uni_new _ y 1 vx vx'); last 2 first. - rewrite /vx /execP_cst /sval/=. - by case: cid. - rewrite /vx' /execP_cst /sval/=. - by case: cid. - by []. -move=> x0 t0. - rewrite /vy /vy' /execP_cst /sval/=. - case: cid => sy. - case: cid => sy'. - move=> er1 er2. - apply/esym/evalP_uni_new. - exact: er2. - exact: er1. +apply: evalP_uniq; first exact/evalP_execP. +by apply: E_WP; exact: evalP_execP. Qed. -(* Lemma evalP_uni_new x r - (u : R.-sfker munit ~> mR R) - (v : R.-sfker prod_meas_obligation_2 prod_meas - (existT [eta measurableType] default_measure_display (mR R)) - [::] ~> mR R) : - evalP (exp_return (exp_real r) : expP [::] sreal) u -> - evalP (exp_return (exp_real r) : expP [:: (x, sreal)] sreal) v -> - forall x0 t, v (x0, t) = u t. *) - -Ltac inj H := apply Classical_Prop.EqdepTheory.inj_pair2 in H. - -Lemma evalP_uniq_sub (l : context) (st : stype) e (u1 : R.-sfker _ ~> _) - (* (u1' : R.-sfker prod_meas_obligation_2 prod_meas - (existT [eta measurableType] _ (typei2 st)) _ ~> _) *) - (xtl : ("x", st) \notin l) M y0 t : - let x := "x" in - (* let y := "y" in *) - x \notin free_varsP e -> - measurable M -> - l |- e -P-> u1 -> - (* evalP ([e1'] : expP [:: (y, st)] st) u1' -> *) - ((x, st) :: l)%SEQ |- (@expWP R l st (x, st) e xtl) : expP ((x, st) :: l)%SEQ st -P-> (keta1 u1) -> - u1 t M = (@keta1 R (x, st) _ _ u1) (y0, t) M. +Lemma execP_letin l x t1 t2 (e1 : expP l t1) (e2 : expP ((x, t1) :: l) t2) : + execP [Let x <~ e1 In e2] = letin' (execP e1) (execP e2) :> (R.-sfker _ ~> _). Proof. -move=> x xNe1 mst. -move=> hu. -by rewrite /keta1 /=. -(* -apply: (@evalP_mut_ind R - (fun (l : _) (st : stype) (e : expD l st) (f : projT2 (typei _) -> projT2 (typei st)) (mf : measurable_fun setT f) (h1 : l |- e -D-> f # mf) => - forall (xtl : (x, st) \notin l) M y0 t, ((x, st) :: l)%SEQ |- (@expWD R l st (x, st) e xtl) -D-> (@eta1 R (x, st) l st f) # (meta1 mf) -> f t = (@eta1 R (x, st) l st f) (y0, t) - ) - (fun (l : _) (st : stype) (e : expP l st) (u : R.-sfker _ ~> projT2 (typei st)) (h1 : evalP e u) => - forall (xtl : (x, st) \notin l) M y0 t, ((x, st) :: l)%SEQ |- (@expWP R l st (x, st) e xtl) -P-> (@keta1 R (x, st) l st u) -> u t M = (@keta1 R (x, st) l st u) (y0, t) M) - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ l st e); last exact: hu. -move=> l' ? ? ? ?. -by inversion 1.*) +apply: evalP_uniq; first exact/evalP_execP. +by apply: E_letin; exact/evalP_execP. Qed. -(* Lemma letinC ta tb (l0 := [:: ("a", ta); ("b", tb)]) st - (e1 : @expP R l0 st) (e2 : expP l0 st) : - "x" \notin free_varsP e2 -> - "y" \notin free_varsP e1 -> - [Let "x" <~ e1 In - Let "y" <~ %WP {"x"} # e2 In - Ret (%{"x"}, %{"y"})] = - [Let "y" <~ e2 In - Let "x" <~ %WP {"y"} # e1 In - Ret (%{"x"}, %{"y"})] :> expP _ _. -Admitted. *) - -Lemma eval_exec l st e1 : l |- e1 -P-> @execP R l st e1. +Lemma execP_ret l t (e : @expD R l t) : execP [Ret e] = ret (projT2 (execD e)). Proof. -rewrite /execP/= /sval. -by case: cid. +apply: evalP_uniq; first exact: evalP_execP. +by apply: E_return; exact: evalD_execD. Qed. -Lemma execP_keta st (e : expP [::] st) (x : string) : execP [%WP x # e] = @keta1 R (x, st) [::] st (execP e). +Lemma execD_pair l (G := slist (map snd l)) t1 t2 + (x : @expD R l t1) + (y : @expD R l t2) : + let f := projT1 (execD x) in + let g := projT1 (execD y) in + let mf := projT2 (execD x) in + let mg := projT2 (execD y) in + execD [(x, y)] = + @existT _ _ (fun z => (f z, g z)) + (@measurable_fun_pair _ _ _ (typei2 (slist (map snd l))) (typei2 t1) (typei2 t2) + f g mf mg). Proof. -apply: (@evalP_uniq R _ _ [%WP x # e]). -exact/eval_exec. -apply: E_WP. -exact/eval_exec. +move=> f g mf mg. +rewrite /f /g /mf /mg. +set lhs := LHS. +set rhs := RHS. +have h : projT1 lhs = projT1 rhs. + apply: (@evalD_uniq R l _ [(x, y)] (projT1 lhs) (projT1 rhs) (projT2 lhs) (projT2 rhs)). + exact: evalD_execD. + by apply: E_pair; exact: evalD_execD. +exact: eq_sigT_hprop. Qed. -(* Lemma prod_measurable (B : set bool) : measurable B. *) - -Lemma letinC st - (e1 : @expP R [::] st) (e2 : expP [::] st) (v1 v2 : R.-sfker munit ~> typei2 (spair st st)) : - (* "x" \notin free_varsP e2 -> - "y" \notin free_varsP e1 -> *) - [::] |- [Let "x" <~ e1 In - Let "y" <~ %WP {"x"} # e2 In - Ret (%{"x"}, %{"y"})] -P-> v1 - -> - [::] |- [Let "y" <~ e2 In - Let "x" <~ %WP {"y"} # e1 In - Ret (%{"x"}, %{"y"})] -P-> v2 -> - v1 = v2. -Proof. -move=> (* xN yN *) ev1 ev2. -set x := "x". -set y := "y". -pose k1 : R.-sfker _ ~> typei2 st := @execP R [::] st e1. -pose k2' : R.-sfker _ ~> _ := @execP R [:: (x, st)] st [%WP x # e2]. -pose vx := letin' k1 - (letin' k2' - (ret - (measurable_fun_pair - (* (T:= (typei2 st * (typei2 st * munit))%type) - (T1 := typei2 st) (T2 := typei2 st) *) - (f := fst \o snd) (g:= fst) var2of4' var1of2))). -have ev1' : [::] |- [Let x <~ e1 In Let y <~ %WP x # e2 In Ret (% x, % y)] -P-> vx. -apply/E_letin. -rewrite /k1. -apply: eval_exec. -apply/E_letin. -rewrite /k2'. -apply: eval_exec. -apply/E_return /E_pair. -have -> : (var2of4' = (@mvarof R [:: (y, st); (x, st)] 1)) by []. -apply (@E_var R [:: (y, st); (x, st)] x). -have -> : (var1of2 = (@mvarof R [:: (y, st); (x, st)] 0)) by []. -apply/(@E_var R [:: (y, st); (x, st)] y). -have -> := (evalP_uniq ev1 ev1'). - -pose k2 : R.-sfker _ ~> typei2 st := @execP R [::] st e2. -pose k1' : R.-sfker _ ~> _ := @execP R [:: (y, st)] st [%WP y # e1]. -pose vy := letin' k2 - (letin' k1' - (ret - (measurable_fun_pair - (* (T:= (typei2 st * (typei2 st * munit))%type) - (T1 := typei2 st) (T2 := typei2 st) *) - (f := fst) (g:= fst \o snd) var1of2 var2of4'))). -have ev2' : [::] |- [Let y <~ e2 In Let x <~ %WP y # e1 In Ret (% x, % y)] -P-> vy. -apply/E_letin. -apply/eval_exec. -apply/E_letin. -apply/eval_exec. -apply/E_return /E_pair. -have -> : (var1of2 = (@mvarof R [:: (x, st); (y, st)] 0)) by []. -apply/(@E_var R [:: (x, st); (y, st)] x). -have -> : (var2of4' = (@mvarof R [:: (x, st); (y, st)] 1)) by []. -apply/(@E_var R [:: (x, st); (y, st)] y). -have -> := (evalP_uniq ev2 ev2'). - -rewrite/vx/vy. -apply: eq_sfkernel => t U. -apply: (@letin'C _ _ _ (typei2 st) (typei2 st) munit). -- by rewrite /k1/k1' execP_keta. -- by rewrite /k2/k2' execP_keta. -- rewrite /= in U *. -rewrite measurable_prod_measurableType. -apply: sub_sigma_algebra. -Admitted. - -Lemma letinC_new st - (e1 : @expP R [::] st) (e2 : expP [::] st) : - "x" \notin free_varsP e2 -> - "y" \notin free_varsP e1 -> +Lemma letinC_new l t1 t2 (e1 : @expP R l t1) (e2 : expP l t2) + (xl : "x" \notin map fst l) (yl : "y" \notin map fst l) : + forall U, measurable U -> execP [Let "x" <~ e1 In - Let "y" <~ %WP {"x"} # e2 In - Ret (%{"x"}, %{"y"})] = + Let "y" <~ {@expWP _ _ _ ("x", t1) e2 xl} In + Ret (%{"x"}, %{"y"})] ^~ U = execP [Let "y" <~ e2 In - Let "x" <~ %WP {"y"} # e1 In - Ret (%{"x"}, %{"y"})]. -Proof. -move=> xn yn. -apply/letinC/eval_exec/eval_exec. -Qed. - -Lemma execP_ketaAB (ta tb : stype) (l0 := [:: ("r", ta); ("_", tb)]) st (e : expP l0 st) : execP [%WP {"x"} # e] = @keta1 R ("x", st) l0 st (execP e). + Let "x" <~ {@expWP _ _ _ ("y", t2) e1 yl} In + Ret (%{"x"}, %{"y"})] ^~ U. Proof. -apply: (@evalP_uniq R _ _ [%WP {"x"} # e]). -exact/eval_exec. -apply: E_WP. -exact/eval_exec. -Qed. +move=> U mU; apply/funext => x. +rewrite 4!execP_letin. +rewrite 2!execP_WP_keta1. +rewrite 2!execP_ret /=. +rewrite 2!execD_pair/=. +have := @letin'C _ _ _ _ _ _ _ (execP e1) (execP (@expWP _ _ _ ("y", t2) e1 yl)) _ + (execP e2) (execP (@expWP _ _ _ ("x", t1) e2 xl)) _. +rewrite -/typei. +rewrite !execP_WP_keta1/=. +Abort. -Lemma letinC_g ta tb (l0 := [:: ("r", ta); ("_", tb)]) st - (e1 : @expP R l0 st) (e2 : expP l0 st) v1 v2 : - "x" \notin free_varsP e2 -> - "y" \notin free_varsP e1 -> - l0 |- [Let "x" <~ e1 In - Let "y" <~ %WP {"x"} # e2 In - Ret (%{"x"}, %{"y"})] -P-> v1 +Lemma letinC l t1 t2 (e1 : @expP R l t1) (e2 : expP l t2) + (xl : "x" \notin map fst l) (yl : "y" \notin map fst l) + (v1 v2 : R.-sfker typei2 (slist (map snd l)) ~> typei2 (spair t1 t2)) : + l # [Let "x" <~ e1 In + Let "y" <~ {@expWP _ _ _ ("x", t1) e2 xl} In + Ret (%{"x"}, %{"y"})] -P-> v1 -> - l0 |- [Let "y" <~ e2 In - Let "x" <~ %WP {"y"} # e1 In - Ret (%{"x"}, %{"y"})] -P-> v2 -> - v1 = v2. + l # [Let "y" <~ e2 In + Let "x" <~ {@expWP _ _ _ ("y", t2) e1 yl} In + Ret (%{"x"}, %{"y"})] -P-> v2 -> + forall U, measurable U -> v1 ^~ U = v2 ^~ U. Proof. -move=> _ _ ev1 ev2. -set x := "x". -set y := "y". -pose k1 : R.-sfker _ ~> typei2 st := @execP R l0 st e1. -pose k2' : R.-sfker _ ~> _ := @execP R ((x, st) :: l0) st [%WP x # e2]. -pose vx := letin' k1 - (letin' k2' - (ret - (measurable_fun_pair - (* (T:= (typei2 st * (typei2 st * munit))%type) - (T1 := typei2 st) (T2 := typei2 st) *) - (f := fst \o snd) (g:= fst) var2of4' var1of2))). -have ev1' : l0 |- [Let x <~ e1 In Let y <~ %WP x # e2 In Ret (% x, % y)] -P-> vx. - apply/E_letin. - rewrite /k1. - apply: eval_exec. - apply/E_letin. - rewrite /k2'. - apply: eval_exec. - apply/E_return /E_pair. - have -> : (var2of4' = (@mvarof R [:: (y, st), (x, st) & l0] 1)) by []. - apply (@E_var R [:: (y, st), (x, st) & l0] x). - have -> : (var1of2 = (@mvarof R [:: (y, st), (x, st) & l0] 0)) by []. - by apply/(@E_var R [:: (y, st), (x, st) & l0] y). -have -> := (evalP_uniq ev1 ev1'). - -pose k2 : R.-sfker _ ~> typei2 st := @execP R l0 st e2. -pose k1' : R.-sfker _ ~> _ := @execP R [:: (y, st) & l0] st [%WP y # e1]. -pose vy := letin' k2 - (letin' k1' - (ret - (measurable_fun_pair - (* (T:= (typei2 st * (typei2 st * munit))%type) - (T1 := typei2 st) (T2 := typei2 st) *) - (f := fst) (g:= fst \o snd) var1of2 var2of4'))). -have ev2' : l0 |- [Let y <~ e2 In Let x <~ %WP y # e1 In Ret (% x, % y)] -P-> vy. -apply/E_letin. -apply/eval_exec. -apply/E_letin. -apply/eval_exec. -apply/E_return /E_pair. -have -> : (var1of2 = (@mvarof R [:: (x, st), (y, st) & l0] 0)) by []. -apply (@E_var R [:: (x, st), (y, st) & l0] x). -have -> : (var2of4' = (@mvarof R [:: (x, st), (y, st) & l0] 1)) by []. -apply/(@E_var R [:: (x, st), (y, st) & l0] y). -have -> := (evalP_uniq ev2 ev2'). -rewrite/vx/vy. -apply: eq_sfkernel => t U. -apply: (@letin'C _ _ _ (typei2 st) (typei2 st) _). -Eval compute in free_varsP e1. -- admit. -(* by rewrite /k1/k1' execP_ketaAB. *) -- -by rewrite /k2/k2' execP_ketaAB. -- rewrite /= in U *. -rewrite measurable_prod_measurableType. -apply: sub_sigma_algebra. - - -Admitted. +move=> ev1 ev2. +pose k1 : R.-sfker _ ~> typei2 t1 := execP e1. +pose k2' : R.-sfker _ ~> _ := @execP R (("x", t1) :: l) t2 (@expWP _ _ _ ("x", t1) e2 xl). +pose vx : R.-sfker typei2 (slist (map snd l)) ~> + [the measurableType _ of (typei2 t1 * typei2 t2)%type] := + letin' k1 + (letin' k2' + (ret (measurable_fun_pair + (T:= [the measurableType _ of + (typei2 t2 * (typei2 t1 * (projT2 (prod_meas (map typei (map snd l))))))%type]) + (T1:= typei2 t1) + (f := fst \o snd) (g:= fst) var2of4' var1of2))). +have ev1' : l # [Let "x" <~ e1 In Let "y" <~ {@expWP _ _ _ ("x", t1) e2 xl} In Ret (%{"x"}, %{"y"})] -P-> vx. + apply: E_letin; first exact: evalP_execP. + apply: E_letin; first exact: evalP_execP. + apply/E_return/E_pair. + - have -> : var2of4' = @mvarof R [:: ("y", t2), ("x", t1) & l] 1 by []. + exact: E_var. + - have -> : var1of2 = @mvarof R [:: ("y", t2), ("x", t1) & l] 0 by []. + exact: E_var. +rewrite (evalP_uniq ev1 ev1'). +pose k2 : R.-sfker _ ~> typei2 t2 := @execP R l t2 e2. +pose k1' : R.-sfker _ ~> _ := @execP R [:: ("y", t2) & l] t1 (@expWP _ _ _ ("y", t2) e1 yl). +pose vy : R.-sfker typei2 (slist (map snd l)) ~> + [the measurableType _ of (typei2 t1 * typei2 t2)%type] := + letin' k2 (letin' k1' + (ret (measurable_fun_pair + (T := [the measurableType _ of + typei2 t1 * (typei2 t2 * (projT2 (prod_meas (map typei (map snd l)))))]%type) + (T2 := typei2 t2) (f := fst) (g:= fst \o snd) var1of2 var2of4'))). +have ev2' : l # [Let "y" <~ e2 In Let "x" <~ {@expWP _ _ _ ("y", t2) e1 yl} In Ret (%{"x"}, %{"y"})] -P-> vy. + apply: E_letin; first exact: evalP_execP. + apply: E_letin; first exact: evalP_execP. + apply/E_return/E_pair. + - have -> : var1of2 = @mvarof R [:: ("x", t1), ("y", t2) & l] 0 by []. + exact: E_var. + - have -> : var2of4' = @mvarof R [:: ("x", t1), ("y", t2) & l] 1 by []. + exact: E_var. +rewrite (evalP_uniq ev2 ev2'). +rewrite /vx /vy => t U/=. +apply/funext => x. +apply: (@letin'C _ _ _ (typei2 t1) (typei2 t2)). +- move=> ST /= TATBU. + rewrite /k1' /k1. + by rewrite (@execP_WP_keta1 ("y", t2) _ _ e1). +- move=> ST /= TATBU. + rewrite /k2 /k2'. + by rewrite (@execP_WP_keta1 ("x", t1) _ _ e2). +- by []. +Qed. -(*Lemma letinC (l : context) st v1 v2 t M (e1 : @expP R l st) (e2 : expP l st) -(Hx1 : "x" \in map fst ([:: ("y", st); ("x", st)] ++ l)%SEQ) -(Hy1 : "y" \in map fst ([:: ("y", st); ("x", st)] ++ l)%SEQ) -(Hx2 : "x" \in map fst ([:: ("x", st); ("y", st)] ++ l)%SEQ) -(Hy2 : "y" \in map fst ([:: ("x", st); ("y", st)] ++ l)%SEQ) -(xtl : ("x", st) \notin l) (ytl : ("y", st) \notin l) : - let x := "x" in - let y := "y" in - "x" \notin free_varsP e2 -> - "y" \notin free_varsP e1 -> - measurable M -> - l |- [Let x <~ e1 In - Let y <~ {(@expWP R l st (x, st) e2 xtl)} In - Ret (%x # Hx1, %y # Hy1)] : @expP R _ _ -P-> v1 +Example letinr_ ta tb (l := [:: ("r", ta); ("_", tb)]) t1 t2 + (e1 : @expP R l t1) (e2 : expP l t2) + (v1 v2 : (R.-sfker typei2 (slist (map snd l)) ~> typei2 (spair t1 t2))) : + l # [Let "x" <~ e1 In + Let "y" <~ %WP {"x"} # e2 In + Ret (%{"x"}, %{"y"})] -P-> v1 -> - l |- [Let y <~ e2 In - Let x <~ {(@expWP R l st (y, st) e1 ytl)} In - Ret (%x # Hx2, %y # Hy2)] -P-> v2 -> - v1 t M = v2 t M. + l # [Let "y" <~ e2 In + Let "x" <~ %WP {"y"} # e1 In + Ret (%{"x"}, %{"y"})] -P-> v2 -> + forall U, measurable U -> v1 ^~ U = v2 ^~ U. +Proof. exact: letinC. Abort. + +Example letinC12 (v1 v2 : R.-sfker munit ~> typei2 (spair sreal sreal)) U : + measurable U -> + [::] # [Let "x" <~ Ret {1}:r In + Let "y" <~ Ret {2}:r In + Ret (%{"x"}, %{"y"})] -P-> v1 -> + [::] # [Let "y" <~ Ret {2}:r In + Let "x" <~ Ret {1}:r In + Ret (%{"x"}, %{"y"})] -P-> v2 -> + v1 ^~ U = v2 ^~ U. Proof. -rewrite /=. -Admitted.*) +(*move=> mU hv1 hv2. +have := @letinC [::] sreal sreal + (@exp_return _ _ _ (exp_real 1)) + (@exp_return _ _ _ (exp_real 2)) erefl erefl v1 v2. +apply => //. xxx*) +set d := (x in (projT1 x).-measurable _). +move=> mM ev1 ev2. +pose vx : R.-sfker munit ~> mR R := execP_ret_real [::] 1. +pose vy : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := + execP_ret_real [:: ("x", sreal)] 2. +have -> : v1 = letin' vx (letin' vy (ret (measurable_fun_pair var2of3' var1of3'))). + apply: (evalP_uniq ev1). + apply: E_letin; first exact: evalP_execP. + apply: E_letin; first exact: evalP_execP. + apply/E_return/E_pair. + - have -> : var2of3' = @mvarof R [:: ("y", sreal); ("x", sreal)] 1 by []. + exact: E_var. + - have -> : var1of4' = @mvarof R [:: ("y", sreal); ("x", sreal)] 0 by []. + exact: E_var. +pose vy' : R.-sfker munit ~> mR R := execP_ret_real [::] 2. +pose vx' : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := + execP_ret_real [:: ("y", sreal)] 1. +have -> : v2 = letin' vy' (letin' vx' (ret (measurable_fun_pair var1of3' var2of3'))). + apply: (evalP_uniq ev2). + apply: E_letin; first exact: evalP_execP. + apply: E_letin; first exact: evalP_execP. + apply/E_return/E_pair. + - have -> : var1of3' = @mvarof R [:: ("x", sreal); ("y", sreal)] 0 by []. + exact: E_var. + - have -> : var2of3' = @mvarof R [:: ("x", sreal); ("y", sreal)] 1 by []. + exact: E_var. +apply/funext => -[]. +apply: letin'C; [ | | by []]. +- move=> /= r []. + rewrite /vx /vx'. + rewrite (@evalP_uni_new _ "y" 1 vx vx'); first by []. + + exact: evalP_execP. + + exact: evalP_execP. +- move=> x0 t0. + rewrite /vy /vy'. + apply/esym/evalP_uni_new. + + exact: evalP_execP. + + exact: evalP_execP. +Qed. -End letinC. \ No newline at end of file +End letinC. diff --git a/theories/prob_lang.v b/theories/prob_lang.v index 6e888a7878..65dce052bb 100644 --- a/theories/prob_lang.v +++ b/theories/prob_lang.v @@ -1076,7 +1076,7 @@ Let mkswap_sfinite : forall x U, measurable U -> mkswap k x U = kseries k_ x U. Proof. have [k_ /= kE] := sfinite k. -exists (fun n => mkswap (k_ n)). +exists (fun n => [the R.-ker _ ~> _ of mkswap (k_ n)]). move=> n. have /measure_fam_uubP[M hM] := measure_uub (k_ n). by exists M%:num => x/=; exact: hM. @@ -1111,7 +1111,10 @@ End kswap_finite_kernel_finite. (* Module MSWAP_SFINITE_KERNEL. *) -Notation "l \; k" := (mkcomp l (mkswap k)) : ereal_scope. +Reserved Notation "f .; g" (at level 60, right associativity, + format "f .; '/ ' g"). + +Notation "l .; k" := (mkcomp l [the _.-ker _ ~> _ of mkswap k]) : ereal_scope. (* TODO: move to kernel.v *) @@ -1121,7 +1124,7 @@ Variables (d d' d3 : _) (X : measurableType d) (Y : measurableType d') Definition letin' (l : R.-sfker X ~> Y) (k : R.-sfker [the measurableType (d', d).-prod of (Y * X)%type] ~> Z) := - locked [the R.-sfker X ~> Z of l \; k]. + locked [the R.-sfker X ~> Z of l .; k]. Lemma letin'E (l : R.-sfker X ~> Y) (k : R.-sfker [the measurableType (d', d).-prod of (Y * X)%type] ~> Z) x U : From dd00a41a9bdbcb3a7b703f5b13af0bf864058d78 Mon Sep 17 00:00:00 2001 From: AyumuSaito Date: Wed, 26 Apr 2023 12:23:41 +0900 Subject: [PATCH 52/54] exec_var --- theories/lang_syntax.v | 76 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 74 insertions(+), 2 deletions(-) diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index a3f8d9ba1f..d0861731b9 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -690,7 +690,7 @@ exact: (proj1_sig h). Defined. Lemma evalP_execP l t e : l # e -P-> @execP l t e. -Proof. by rewrite /execP/= /sval /ssr_have/=; case: cid. Qed. +Proof. by rewrite /execP/= /sval ?/ssr_have/=; case: cid. Qed. Definition execD l t (e : @expD R l t) : {f : (@typei2 R (slist (map snd l))) -> @typei2 R t & measurable_fun setT f}. @@ -702,7 +702,7 @@ Defined. Lemma evalD_execD l t e : let: x := @execD l t e in l # e -D-> projT1 x ; projT2 x. Proof. -rewrite /execD /ssr_have /= /sval /=; case: cid => f [mf ef]. +rewrite /execD ?/ssr_have /= /sval /=; case: cid => f [mf ef]. by case: cid. Defined. @@ -972,6 +972,8 @@ Section letinC. Local Open Scope lang_scope. Variable R : realType. +Check [Let "x" <~ Ret %{"y"} In Ret %{"x"}]. + Lemma execP_WP_keta1 x l (st : stype_eqType) (e : expP l st) (xl : x.1 \notin map fst l) : execP (@expWP R l st _ e xl) = [the _.-sfker _ ~> _ of keta1 (execP e)]. Proof. @@ -979,6 +981,33 @@ apply: evalP_uniq; first exact/evalP_execP. by apply: E_WP; exact: evalP_execP. Qed. +Lemma execD_real l r : + @execD R l _ [r :r] = existT _ (cst r) (kr r). +Proof. +rewrite /execD /=. +case: cid => f ?. +case: cid => ? ev1. +have ev2 := (E_real l r). +have fcstr := (evalD_uniq ev1 ev2). +subst. +congr existT. +apply Prop_irrelevance. +Qed. + +Lemma execD_var l x : + let i := seq.index x (map fst l) in + @execD R l _ [%x] = existT _ (varof i) (@mvarof R l i). +Proof. +rewrite /execD /=. +case: cid => f ?. +case: cid => ? ev1. +have ev2 := (E_var R l x). +have fcstr := (evalD_uniq ev1 ev2). +subst. +congr existT. +apply Prop_irrelevance. +Qed. + Lemma execP_letin l x t1 t2 (e1 : expP l t1) (e2 : expP ((x, t1) :: l) t2) : execP [Let x <~ e1 In e2] = letin' (execP e1) (execP e2) :> (R.-sfker _ ~> _). Proof. @@ -1015,6 +1044,49 @@ have h : projT1 lhs = projT1 rhs. exact: eq_sigT_hprop. Qed. +Lemma ex_var_ret l : @execP R l _ [Let "x" <~ Ret {1}:r In Ret %{"x"}] = letin' (ret (kr 1)) (ret var1of2). +Proof. +rewrite execP_letin; congr letin'. +by rewrite execP_ret execD_real. +by rewrite execP_ret execD_var; congr ret. +Qed. + +Lemma letin_pair l : @letin' _ _ _ _ _ _ R (ret (kr 1)) + (letin' (ret (kr 2)) + (ret + (measurable_fun_pair (T:=typei2 (slist [:: sreal, sreal & [seq i.2 | i <- l]])) (T1:= + typei2 sreal) (T2:=typei2 sreal) + (f:=fun H : R * (R * projT2 (prod_meas [seq typei i | i <- [seq i.2 | i <- l]])) => H.2.1) + (g:=fst) (mvarof (R:=R) (l:=[:: ("y", sreal), ("x", sreal) & l]) (i:=1)) + (mvarof (R:=R) (l:=[:: ("y", sreal), ("x", sreal) & l]) (i:=0))))) + = ret (measurable_fun_pair (kr 1) (kr 2)). +Proof. +apply: eq_sfkernel => ? U. +rewrite retE diracE. +rewrite letin'E. +under eq_integral. + move=> x xS. + rewrite letin'E. + under eq_integral do rewrite retE diracE /=. + over. +rewrite !retE !integral_dirac //=. +by rewrite indicT //= 2!mul1e. +apply (@measurable_fun_pair _ _ _ (mR R) _ _ (cst 1) id). +Admitted. + +Lemma ex_var_ret2 l : + @execP R l _ [Let "x" <~ Ret {1}:r In Let "y" <~ Ret {2}:r In + Ret (%{"x"}, %{"y"})] = + @execP R l _ [Let "y" <~ Ret {2}:r In Let "x" <~ Ret {1}:r In + Ret (%{"x"}, %{"y"})]. +Proof. +rewrite !execP_letin !execP_ret !execD_real. +rewrite !execD_pair !execD_var /=. +rewrite letin_pair /=. +by rewrite execP_ret execD_real. +by rewrite execP_ret execD_var; congr ret. +Qed. + Lemma letinC_new l t1 t2 (e1 : @expP R l t1) (e2 : expP l t2) (xl : "x" \notin map fst l) (yl : "y" \notin map fst l) : forall U, measurable U -> From d2c513935b6151fa19c0ad2c1b27dcb6c3207a60 Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 26 Apr 2023 12:21:13 +0900 Subject: [PATCH 53/54] wip Co-authored-by: AyumuSaito --- theories/lang_syntax.v | 84 ++++++++++++++++++++++++++---------------- 1 file changed, 52 insertions(+), 32 deletions(-) diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index d0861731b9..a90947d3ad 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -30,7 +30,6 @@ Reserved Notation "l # e -P-> v" (at level 40). Section type_syntax. Variables (R : realType). - Section string_eq. Definition string_eqMixin := @EqMixin string eqb eqb_spec. @@ -140,13 +139,13 @@ Notation "'If' e1 'Then' e2 'Else' e3" := (exp_if e1 e2 e3) (in custom expr at l Notation "{ x }" := x (in custom expr, x constr) : lang_scope. Notation "x" := x (in custom expr at level 0, x ident) : lang_scope. -Section eval. -Variables (R : realType). +Section varof. +Context {R : realType}. -Fixpoint varof (l : seq (string * stype)) (i : nat) : - typei2 (slist (map snd l)) -> @typei2 R (nth sunit (map snd l) i) := +Fixpoint varof (l : seq stype) (i : nat) : + typei2 (slist l) -> @typei2 R (nth sunit l i) := match - l return (typei2 (slist (map snd l)) -> typei2 (nth sunit (map snd l) i)) + l return (typei2 (slist l) -> typei2 (nth sunit l i)) with | [::] => match i with | O => id | j.+1 => id end | _ :: _ => match i with @@ -155,12 +154,17 @@ Fixpoint varof (l : seq (string * stype)) (i : nat) : end end. -Lemma mvarof (l : seq (string * stype)%type) (i : nat) : - measurable_fun setT (@varof l i). +Lemma mvarof (l : seq stype) (i : nat) : measurable_fun setT (@varof l i). Proof. elim: l i => //= h t ih [|j]; first exact: measurable_fun_fst. exact: (measurable_funT_comp (ih _) (@measurable_fun_snd _ _ _ _)). Qed. +End varof. +Arguments varof {R} l i. +Arguments mvarof {R} l i. + +Section eval. +Variables (R : realType). Lemma eq_probability d (Y : measurableType d) (m1 m2 : probability Y R) : (m1 = m2 :> (set Y -> \bar R)) -> m1 = m2. @@ -338,7 +342,7 @@ Inductive evalD : forall (l : context) (T : stype) (e : @expD R l T) | E_var (l : context) (x : string) : let i := seq.index x (map fst l) in - l # exp_var x _ erefl -D-> @varof l i ; @mvarof l i + l # exp_var x _ erefl -D-> varof (map snd l) i ; mvarof (map snd l) i | E_bernoulli l (r : {nonneg R}) (r1 : (r%:num <= 1)%R) : l # exp_bernoulli r r1 -D-> @@ -947,8 +951,8 @@ apply/E_norm/E_letin. * rewrite /exp_var' /=. rewrite (_ : left_pf _ _ _ = erefl) //. set l := (X in X # _ -D-> _ ; _). - rewrite (_ : var1of2 = @mvarof R l 0)//. - exact: (E_var R l "x"). + rewrite (_ : var1of2 = @mvarof R (map snd l) 0)//. + exact: (E_var _ _ "x"). * exact/E_return/E_real. * exact/E_return/E_real. - apply: E_letin. @@ -956,14 +960,14 @@ apply/E_norm/E_letin. rewrite /exp_var'/=. rewrite (_ : left_pf _ _ _ = erefl) //. set l := (X in X # _ -D-> _ ; _). - rewrite (_ : var1of2 = @mvarof R l 0)//. - exact: (@E_var R l "r"). + rewrite (_ : var1of2 = @mvarof R (map snd l) 0)//. + exact: (E_var _ _ "r"). + apply/E_return. rewrite /exp_var'/=. rewrite (_ : right_pf _ _ _ = erefl) //. set l := (X in X # _ -D-> _ ; _). - rewrite (_ : var3of4' = @mvarof R l 2)//. - exact: (@E_var R l "x"). + rewrite (_ : var3of4' = @mvarof R (map snd l) 2)//. + exact: (E_var _ _ "x"). Qed. End example. @@ -996,7 +1000,7 @@ Qed. Lemma execD_var l x : let i := seq.index x (map fst l) in - @execD R l _ [%x] = existT _ (varof i) (@mvarof R l i). + @execD R l _ [%x] = existT _ (varof (map snd l) i) (@mvarof R (map snd l) i). Proof. rewrite /execD /=. case: cid => f ?. @@ -1051,7 +1055,7 @@ by rewrite execP_ret execD_real. by rewrite execP_ret execD_var; congr ret. Qed. -Lemma letin_pair l : @letin' _ _ _ _ _ _ R (ret (kr 1)) +(* Lemma letin_pair l : @letin' _ _ _ _ _ _ R (ret (kr 1)) (letin' (ret (kr 2)) (ret (measurable_fun_pair (T:=typei2 (slist [:: sreal, sreal & [seq i.2 | i <- l]])) (T1:= @@ -1072,7 +1076,7 @@ under eq_integral. rewrite !retE !integral_dirac //=. by rewrite indicT //= 2!mul1e. apply (@measurable_fun_pair _ _ _ (mR R) _ _ (cst 1) id). -Admitted. +Admitted. *) Lemma ex_var_ret2 l : @execP R l _ [Let "x" <~ Ret {1}:r In Let "y" <~ Ret {2}:r In @@ -1082,10 +1086,10 @@ Lemma ex_var_ret2 l : Proof. rewrite !execP_letin !execP_ret !execD_real. rewrite !execD_pair !execD_var /=. -rewrite letin_pair /=. +(* rewrite letin_pair /=. by rewrite execP_ret execD_real. -by rewrite execP_ret execD_var; congr ret. -Qed. +by rewrite execP_ret execD_var; congr ret. *) +Admitted. Lemma letinC_new l t1 t2 (e1 : @expP R l t1) (e2 : expP l t2) (xl : "x" \notin map fst l) (yl : "y" \notin map fst l) : @@ -1102,10 +1106,26 @@ rewrite 4!execP_letin. rewrite 2!execP_WP_keta1. rewrite 2!execP_ret /=. rewrite 2!execD_pair/=. -have := @letin'C _ _ _ _ _ _ _ (execP e1) (execP (@expWP _ _ _ ("y", t2) e1 yl)) _ - (execP e2) (execP (@expWP _ _ _ ("x", t1) e2 xl)) _. +apply: trans_eq. + apply: trans_eq; last first. + have := @letin'C _ _ _ _ _ _ _ (execP e1) (execP (@expWP _ _ _ ("y", t2) e1 yl)) _ + (execP e2) (execP (@expWP _ _ _ ("x", t1) e2 xl)) _. + apply. + rewrite -/typei. + admit. + admit. + exact: x. + rewrite -/typei. + exact: mU. rewrite -/typei. -rewrite !execP_WP_keta1/=. +rewrite execP_WP_keta1/=. +(*rewrite execD_var/=. +set lhs := measurable_fun_pair _ _. +set rhs := measurable_fun_pair _ _. +have -> : lhs = rhs. + admit. +done. +rewrite -/typei.*) Abort. Lemma letinC l t1 t2 (e1 : @expP R l t1) (e2 : expP l t2) @@ -1136,9 +1156,9 @@ have ev1' : l # [Let "x" <~ e1 In Let "y" <~ {@expWP _ _ _ ("x", t1) e2 xl} In R apply: E_letin; first exact: evalP_execP. apply: E_letin; first exact: evalP_execP. apply/E_return/E_pair. - - have -> : var2of4' = @mvarof R [:: ("y", t2), ("x", t1) & l] 1 by []. + - have -> : var2of4' = @mvarof R (t2 :: t1 :: map snd l) 1 by []. exact: E_var. - - have -> : var1of2 = @mvarof R [:: ("y", t2), ("x", t1) & l] 0 by []. + - have -> : var1of2 = @mvarof R (t2 :: t1 :: map snd l) 0 by []. exact: E_var. rewrite (evalP_uniq ev1 ev1'). pose k2 : R.-sfker _ ~> typei2 t2 := @execP R l t2 e2. @@ -1154,9 +1174,9 @@ have ev2' : l # [Let "y" <~ e2 In Let "x" <~ {@expWP _ _ _ ("y", t2) e1 yl} In R apply: E_letin; first exact: evalP_execP. apply: E_letin; first exact: evalP_execP. apply/E_return/E_pair. - - have -> : var1of2 = @mvarof R [:: ("x", t1), ("y", t2) & l] 0 by []. + - have -> : var1of2 = @mvarof R (t1 :: t2 :: map snd l) 0 by []. exact: E_var. - - have -> : var2of4' = @mvarof R [:: ("x", t1), ("y", t2) & l] 1 by []. + - have -> : var2of4' = @mvarof R (t1 :: t2 :: map snd l) 1 by []. exact: E_var. rewrite (evalP_uniq ev2 ev2'). rewrite /vx /vy => t U/=. @@ -1209,9 +1229,9 @@ have -> : v1 = letin' vx (letin' vy (ret (measurable_fun_pair var2of3' var1of3') apply: E_letin; first exact: evalP_execP. apply: E_letin; first exact: evalP_execP. apply/E_return/E_pair. - - have -> : var2of3' = @mvarof R [:: ("y", sreal); ("x", sreal)] 1 by []. + - have -> : var2of3' = @mvarof R [:: sreal; sreal] 1 by []. exact: E_var. - - have -> : var1of4' = @mvarof R [:: ("y", sreal); ("x", sreal)] 0 by []. + - have -> : var1of4' = @mvarof R [:: sreal; sreal] 0 by []. exact: E_var. pose vy' : R.-sfker munit ~> mR R := execP_ret_real [::] 2. pose vx' : R.-sfker [the measurableType _ of (mR R * munit)%type] ~> mR R := @@ -1221,9 +1241,9 @@ have -> : v2 = letin' vy' (letin' vx' (ret (measurable_fun_pair var1of3' var2of3 apply: E_letin; first exact: evalP_execP. apply: E_letin; first exact: evalP_execP. apply/E_return/E_pair. - - have -> : var1of3' = @mvarof R [:: ("x", sreal); ("y", sreal)] 0 by []. + - have -> : var1of3' = @mvarof R [:: sreal; sreal] 0 by []. exact: E_var. - - have -> : var2of3' = @mvarof R [:: ("x", sreal); ("y", sreal)] 1 by []. + - have -> : var2of3' = @mvarof R [:: sreal; sreal] 1 by []. exact: E_var. apply/funext => -[]. apply: letin'C; [ | | by []]. From 63d3c73b63613866d25e662b5be4d14c99700fca Mon Sep 17 00:00:00 2001 From: Reynald Affeldt Date: Wed, 26 Apr 2023 12:43:29 +0900 Subject: [PATCH 54/54] complete letinC_new --- theories/lang_syntax.v | 94 +++++++++++++++++++++++++++++++++--------- 1 file changed, 75 insertions(+), 19 deletions(-) diff --git a/theories/lang_syntax.v b/theories/lang_syntax.v index a90947d3ad..dc04423006 100644 --- a/theories/lang_syntax.v +++ b/theories/lang_syntax.v @@ -850,9 +850,66 @@ Let sfinVY z : sfinite_measure (VY z). Proof. exact: sfinite_kernel_measure. Qed HB.instance Definition _ z := @Measure_isSFinite_subdef.Build _ (mR R) R (VY z) (sfinVY z).*) +Lemma execP_WP_keta1 x l (st : stype_eqType) (e : expP l st) (xl : x.1 \notin map fst l) : + execP (@expWP R l st _ e xl) = [the _.-sfker _ ~> _ of keta1 (execP e)]. +Proof. +apply: evalP_uniq; first exact/evalP_execP. +by apply: E_WP; exact: evalP_execP. +Qed. + +Lemma execP_letin l x t1 t2 (e1 : expP l t1) (e2 : expP ((x, t1) :: l) t2) : + execP [Let x <~ e1 In e2] = letin' (execP e1) (execP e2) :> (R.-sfker _ ~> _). +Proof. +apply: evalP_uniq; first exact/evalP_execP. +by apply: E_letin; exact/evalP_execP. +Qed. + +Lemma execP_ret l t (e : @expD R l t) : execP [Ret e] = ret (projT2 (execD e)). +Proof. +apply: evalP_uniq; first exact: evalP_execP. +by apply: E_return; exact: evalD_execD. +Qed. + +Lemma execD_pair l (G := slist (map snd l)) t1 t2 + (x : @expD R l t1) + (y : @expD R l t2) : + let f := projT1 (execD x) in + let g := projT1 (execD y) in + let mf := projT2 (execD x) in + let mg := projT2 (execD y) in + execD [(x, y)] = + @existT _ _ (fun z => (f z, g z)) + (@measurable_fun_pair _ _ _ (typei2 (slist (map snd l))) (typei2 t1) (typei2 t2) + f g mf mg). +Proof. +move=> f g mf mg. +rewrite /f /g /mf /mg. +set lhs := LHS. +set rhs := RHS. +have h : projT1 lhs = projT1 rhs. + apply: (@evalD_uniq l _ [(x, y)] (projT1 lhs) (projT1 rhs) (projT2 lhs) (projT2 rhs)). + exact: evalD_execD. + by apply: E_pair; exact: evalD_execD. +exact: eq_sigT_hprop. +Qed. + +Lemma execD_var l (x : string) : + let i := seq.index x (map fst l) in + @execD l _ [% {x} ] = existT _ (varof (map snd l) i) (@mvarof R (map snd l) i). +Proof. +rewrite /execD /=. +case: cid => f ?. +case: cid => ? ev1. +have ev2 := (E_var R l x). +have fcstr := (evalD_uniq ev1 ev2). +subst. +congr existT. +apply Prop_irrelevance. +Qed. + End eval_prop. -Section example. +Section staton_bus. Local Open Scope ring_scope. Local Open Scope lang_scope. Variables (R : realType). @@ -970,7 +1027,7 @@ apply/E_norm/E_letin. exact: (E_var _ _ "x"). Qed. -End example. +End staton_bus. Section letinC. Local Open Scope lang_scope. @@ -1106,27 +1163,26 @@ rewrite 4!execP_letin. rewrite 2!execP_WP_keta1. rewrite 2!execP_ret /=. rewrite 2!execD_pair/=. +rewrite (execD_var _ _ "x")/= (execD_var _ _ "y")/=. apply: trans_eq. apply: trans_eq; last first. - have := @letin'C _ _ _ _ _ _ _ (execP e1) (execP (@expWP _ _ _ ("y", t2) e1 yl)) _ - (execP e2) (execP (@expWP _ _ _ ("x", t1) e2 xl)) _. - apply. - rewrite -/typei. - admit. - admit. - exact: x. - rewrite -/typei. - exact: mU. + apply: (@letin'C _ _ _ _ _ _ _ (execP e1) (execP (@expWP _ _ _ ("y", t2) e1 yl)) _ + (execP e2) (execP (@expWP _ _ _ ("x", t1) e2 xl)) _). + - by rewrite -/typei => y z; rewrite execP_WP_keta1. + - by move=> y z; rewrite execP_WP_keta1. + - exact: x. + - by rewrite -/typei; exact: mU. + rewrite -/typei execP_WP_keta1/=. + set lhs := measurable_fun_pair _ _. + set rhs := measurable_fun_pair _ _. + by have -> : lhs = rhs by exact: Prop_irrelevance. rewrite -/typei. +rewrite (execD_var _ _ "x")/= (execD_var _ _ "y")/=. rewrite execP_WP_keta1/=. -(*rewrite execD_var/=. set lhs := measurable_fun_pair _ _. set rhs := measurable_fun_pair _ _. -have -> : lhs = rhs. - admit. -done. -rewrite -/typei.*) -Abort. +by have -> : lhs = rhs by exact: Prop_irrelevance. +Qed. Lemma letinC l t1 t2 (e1 : @expP R l t1) (e2 : expP l t2) (xl : "x" \notin map fst l) (yl : "y" \notin map fst l) @@ -1184,10 +1240,10 @@ apply/funext => x. apply: (@letin'C _ _ _ (typei2 t1) (typei2 t2)). - move=> ST /= TATBU. rewrite /k1' /k1. - by rewrite (@execP_WP_keta1 ("y", t2) _ _ e1). + by rewrite (@execP_WP_keta1 _ ("y", t2) _ _ e1). - move=> ST /= TATBU. rewrite /k2 /k2'. - by rewrite (@execP_WP_keta1 ("x", t1) _ _ e2). + by rewrite (@execP_WP_keta1 _ ("x", t1) _ _ e2). - by []. Qed.