(*  Title:      HOL/Probability/Probability_Measure.thy
    Author:     Johannes Hölzl, TU München
    Author:     Armin Heller, TU München
*)

section {*Probability measure*}

theory Probability_Measure
  imports Lebesgue_Measure Radon_Nikodym
begin

locale prob_space = finite_measure +
  assumes emeasure_space_1: "emeasure M (space M) = 1"

lemma prob_spaceI[Pure.intro!]:
  assumes *: "emeasure M (space M) = 1"
  shows "prob_space M"
proof -
  interpret finite_measure M
  proof
    show "emeasure M (space M) \<noteq> \<infinity>" using * by simp
  qed
  show "prob_space M" by default fact
qed

abbreviation (in prob_space) "events \<equiv> sets M"
abbreviation (in prob_space) "prob \<equiv> measure M"
abbreviation (in prob_space) "random_variable M' X \<equiv> X \<in> measurable M M'"
abbreviation (in prob_space) "expectation \<equiv> integral\<^sup>L M"
abbreviation (in prob_space) "variance X \<equiv> integral\<^sup>L M (\<lambda>x. (X x - expectation X)\<^sup>2)"

lemma (in prob_space) finite_measure [simp]: "finite_measure M"
  by unfold_locales

lemma (in prob_space) prob_space_distr:
  assumes f: "f \<in> measurable M M'" shows "prob_space (distr M M' f)"
proof (rule prob_spaceI)
  have "f -` space M' \<inter> space M = space M" using f by (auto dest: measurable_space)
  with f show "emeasure (distr M M' f) (space (distr M M' f)) = 1"
    by (auto simp: emeasure_distr emeasure_space_1)
qed

lemma (in prob_space) prob_space: "prob (space M) = 1"
  using emeasure_space_1 unfolding measure_def by (simp add: one_ereal_def)

lemma (in prob_space) prob_le_1[simp, intro]: "prob A \<le> 1"
  using bounded_measure[of A] by (simp add: prob_space)

lemma (in prob_space) not_empty: "space M \<noteq> {}"
  using prob_space by auto

lemma (in prob_space) measure_le_1: "emeasure M X \<le> 1"
  using emeasure_space[of M X] by (simp add: emeasure_space_1)

lemma (in prob_space) AE_I_eq_1:
  assumes "emeasure M {x\<in>space M. P x} = 1" "{x\<in>space M. P x} \<in> sets M"
  shows "AE x in M. P x"
proof (rule AE_I)
  show "emeasure M (space M - {x \<in> space M. P x}) = 0"
    using assms emeasure_space_1 by (simp add: emeasure_compl)
qed (insert assms, auto)

lemma prob_space_restrict_space:
  "S \<in> sets M \<Longrightarrow> emeasure M S = 1 \<Longrightarrow> prob_space (restrict_space M S)"
  by (intro prob_spaceI)
     (simp add: emeasure_restrict_space space_restrict_space)

lemma (in prob_space) prob_compl:
  assumes A: "A \<in> events"
  shows "prob (space M - A) = 1 - prob A"
  using finite_measure_compl[OF A] by (simp add: prob_space)

lemma (in prob_space) AE_in_set_eq_1:
  assumes "A \<in> events" shows "(AE x in M. x \<in> A) \<longleftrightarrow> prob A = 1"
proof
  assume ae: "AE x in M. x \<in> A"
  have "{x \<in> space M. x \<in> A} = A" "{x \<in> space M. x \<notin> A} = space M - A"
    using `A \<in> events`[THEN sets.sets_into_space] by auto
  with AE_E2[OF ae] `A \<in> events` have "1 - emeasure M A = 0"
    by (simp add: emeasure_compl emeasure_space_1)
  then show "prob A = 1"
    using `A \<in> events` by (simp add: emeasure_eq_measure one_ereal_def)
next
  assume prob: "prob A = 1"
  show "AE x in M. x \<in> A"
  proof (rule AE_I)
    show "{x \<in> space M. x \<notin> A} \<subseteq> space M - A" by auto
    show "emeasure M (space M - A) = 0"
      using `A \<in> events` prob
      by (simp add: prob_compl emeasure_space_1 emeasure_eq_measure one_ereal_def)
    show "space M - A \<in> events"
      using `A \<in> events` by auto
  qed
qed

lemma (in prob_space) AE_False: "(AE x in M. False) \<longleftrightarrow> False"
proof
  assume "AE x in M. False"
  then have "AE x in M. x \<in> {}" by simp
  then show False
    by (subst (asm) AE_in_set_eq_1) auto
qed simp

lemma (in prob_space) AE_prob_1:
  assumes "prob A = 1" shows "AE x in M. x \<in> A"
proof -
  from `prob A = 1` have "A \<in> events"
    by (metis measure_notin_sets zero_neq_one)
  with AE_in_set_eq_1 assms show ?thesis by simp
qed

lemma (in prob_space) AE_const[simp]: "(AE x in M. P) \<longleftrightarrow> P"
  by (cases P) (auto simp: AE_False)

lemma (in prob_space) ae_filter_bot: "ae_filter M \<noteq> bot"
  by (simp add: trivial_limit_def)

lemma (in prob_space) AE_contr:
  assumes ae: "AE \<omega> in M. P \<omega>" "AE \<omega> in M. \<not> P \<omega>"
  shows False
proof -
  from ae have "AE \<omega> in M. False" by eventually_elim auto
  then show False by auto
qed

lemma (in prob_space) emeasure_eq_1_AE:
  "S \<in> sets M \<Longrightarrow> AE x in M. x \<in> S \<Longrightarrow> emeasure M S = 1"
  by (subst emeasure_eq_AE[where B="space M"]) (auto simp: emeasure_space_1)

lemma (in prob_space) integral_ge_const:
  fixes c :: real
  shows "integrable M f \<Longrightarrow> (AE x in M. c \<le> f x) \<Longrightarrow> c \<le> (\<integral>x. f x \<partial>M)"
  using integral_mono_AE[of M "\<lambda>x. c" f] prob_space by simp

lemma (in prob_space) integral_le_const:
  fixes c :: real
  shows "integrable M f \<Longrightarrow> (AE x in M. f x \<le> c) \<Longrightarrow> (\<integral>x. f x \<partial>M) \<le> c"
  using integral_mono_AE[of M f "\<lambda>x. c"] prob_space by simp

lemma (in prob_space) nn_integral_ge_const:
  "(AE x in M. c \<le> f x) \<Longrightarrow> c \<le> (\<integral>\<^sup>+x. f x \<partial>M)"
  using nn_integral_mono_AE[of "\<lambda>x. c" f M] emeasure_space_1
  by (simp add: nn_integral_const_If split: split_if_asm)

lemma (in prob_space) nn_integral_le_const:
  "0 \<le> c \<Longrightarrow> (AE x in M. f x \<le> c) \<Longrightarrow> (\<integral>\<^sup>+x. f x \<partial>M) \<le> c"
  using nn_integral_mono_AE[of f "\<lambda>x. c" M] emeasure_space_1
  by (simp add: nn_integral_const_If split: split_if_asm)

lemma (in prob_space) expectation_less:
  fixes X :: "_ \<Rightarrow> real"
  assumes [simp]: "integrable M X"
  assumes gt: "AE x in M. X x < b"
  shows "expectation X < b"
proof -
  have "expectation X < expectation (\<lambda>x. b)"
    using gt emeasure_space_1
    by (intro integral_less_AE_space) auto
  then show ?thesis using prob_space by simp
qed

lemma (in prob_space) expectation_greater:
  fixes X :: "_ \<Rightarrow> real"
  assumes [simp]: "integrable M X"
  assumes gt: "AE x in M. a < X x"
  shows "a < expectation X"
proof -
  have "expectation (\<lambda>x. a) < expectation X"
    using gt emeasure_space_1
    by (intro integral_less_AE_space) auto
  then show ?thesis using prob_space by simp
qed

lemma (in prob_space) jensens_inequality:
  fixes q :: "real \<Rightarrow> real"
  assumes X: "integrable M X" "AE x in M. X x \<in> I"
  assumes I: "I = {a <..< b} \<or> I = {a <..} \<or> I = {..< b} \<or> I = UNIV"
  assumes q: "integrable M (\<lambda>x. q (X x))" "convex_on I q"
  shows "q (expectation X) \<le> expectation (\<lambda>x. q (X x))"
proof -
  let ?F = "\<lambda>x. Inf ((\<lambda>t. (q x - q t) / (x - t)) ` ({x<..} \<inter> I))"
  from X(2) AE_False have "I \<noteq> {}" by auto

  from I have "open I" by auto

  note I
  moreover
  { assume "I \<subseteq> {a <..}"
    with X have "a < expectation X"
      by (intro expectation_greater) auto }
  moreover
  { assume "I \<subseteq> {..< b}"
    with X have "expectation X < b"
      by (intro expectation_less) auto }
  ultimately have "expectation X \<in> I"
    by (elim disjE)  (auto simp: subset_eq)
  moreover
  { fix y assume y: "y \<in> I"
    with q(2) `open I` have "Sup ((\<lambda>x. q x + ?F x * (y - x)) ` I) = q y"
      by (auto intro!: cSup_eq_maximum convex_le_Inf_differential image_eqI [OF _ y] simp: interior_open simp del: Sup_image_eq Inf_image_eq) }
  ultimately have "q (expectation X) = Sup ((\<lambda>x. q x + ?F x * (expectation X - x)) ` I)"
    by simp
  also have "\<dots> \<le> expectation (\<lambda>w. q (X w))"
  proof (rule cSup_least)
    show "(\<lambda>x. q x + ?F x * (expectation X - x)) ` I \<noteq> {}"
      using `I \<noteq> {}` by auto
  next
    fix k assume "k \<in> (\<lambda>x. q x + ?F x * (expectation X - x)) ` I"
    then guess x .. note x = this
    have "q x + ?F x * (expectation X  - x) = expectation (\<lambda>w. q x + ?F x * (X w - x))"
      using prob_space by (simp add: X)
    also have "\<dots> \<le> expectation (\<lambda>w. q (X w))"
      using `x \<in> I` `open I` X(2)
      apply (intro integral_mono_AE integrable_add integrable_mult_right integrable_diff
                integrable_const X q)
      apply (elim eventually_elim1)
      apply (intro convex_le_Inf_differential)
      apply (auto simp: interior_open q)
      done
    finally show "k \<le> expectation (\<lambda>w. q (X w))" using x by auto
  qed
  finally show "q (expectation X) \<le> expectation (\<lambda>x. q (X x))" .
qed

subsection  {* Introduce binder for probability *}

syntax
  "_prob" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("('\<P>'(_ in _. _'))")

translations
  "\<P>(x in M. P)" => "CONST measure M {x \<in> CONST space M. P}"

print_translation {*
  let
    fun to_pattern (Const (@{const_syntax Pair}, _) $ l $ r) =
      Syntax.const @{const_syntax Pair} :: to_pattern l @ to_pattern r
    | to_pattern (t as (Const (@{syntax_const "_bound"}, _)) $ _) = [t]

    fun mk_pattern ((t, n) :: xs) = mk_patterns n xs |>> curry list_comb t
    and mk_patterns 0 xs = ([], xs)
    | mk_patterns n xs =
      let
        val (t, xs') = mk_pattern xs
        val (ts, xs'') = mk_patterns (n - 1) xs'
      in
        (t :: ts, xs'')
      end

    fun unnest_tuples
      (Const (@{syntax_const "_pattern"}, _) $
        t1 $
        (t as (Const (@{syntax_const "_pattern"}, _) $ _ $ _)))
      = let
        val (_ $ t2 $ t3) = unnest_tuples t
      in
        Syntax.const @{syntax_const "_pattern"} $
          unnest_tuples t1 $
          (Syntax.const @{syntax_const "_patterns"} $ t2 $ t3)
      end
    | unnest_tuples pat = pat

    fun tr' [sig_alg, Const (@{const_syntax Collect}, _) $ t] =
      let
        val bound_dummyT = Const (@{syntax_const "_bound"}, dummyT)

        fun go pattern elem
          (Const (@{const_syntax "conj"}, _) $
            (Const (@{const_syntax Set.member}, _) $ elem' $ (Const (@{const_syntax space}, _) $ sig_alg')) $
            u)
          = let
              val _ = if sig_alg aconv sig_alg' andalso to_pattern elem' = rev elem then () else raise Match;
              val (pat, rest) = mk_pattern (rev pattern);
              val _ = case rest of [] => () | _ => raise Match
            in
              Syntax.const @{syntax_const "_prob"} $ unnest_tuples pat $ sig_alg $ u
            end
        | go pattern elem (Abs abs) =
            let
              val (x as (_ $ tx), t) = Syntax_Trans.atomic_abs_tr' abs
            in
              go ((x, 0) :: pattern) (bound_dummyT $ tx :: elem) t
            end
        | go pattern elem (Const (@{const_syntax case_prod}, _) $ t) =
            go
              ((Syntax.const @{syntax_const "_pattern"}, 2) :: pattern)
              (Syntax.const @{const_syntax Pair} :: elem)
              t
      in
        go [] [] t
      end
  in
    [(@{const_syntax Sigma_Algebra.measure}, K tr')]
  end
*}

definition
  "cond_prob M P Q = \<P>(\<omega> in M. P \<omega> \<and> Q \<omega>) / \<P>(\<omega> in M. Q \<omega>)"

syntax
  "_conditional_prob" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("('\<P>'(_ in _. _ \<bar>/ _'))")

translations
  "\<P>(x in M. P \<bar> Q)" => "CONST cond_prob M (\<lambda>x. P) (\<lambda>x. Q)"

lemma (in prob_space) AE_E_prob:
  assumes ae: "AE x in M. P x"
  obtains S where "S \<subseteq> {x \<in> space M. P x}" "S \<in> events" "prob S = 1"
proof -
  from ae[THEN AE_E] guess N .
  then show thesis
    by (intro that[of "space M - N"])
       (auto simp: prob_compl prob_space emeasure_eq_measure)
qed

lemma (in prob_space) prob_neg: "{x\<in>space M. P x} \<in> events \<Longrightarrow> \<P>(x in M. \<not> P x) = 1 - \<P>(x in M. P x)"
  by (auto intro!: arg_cong[where f=prob] simp add: prob_compl[symmetric])

lemma (in prob_space) prob_eq_AE:
  "(AE x in M. P x \<longleftrightarrow> Q x) \<Longrightarrow> {x\<in>space M. P x} \<in> events \<Longrightarrow> {x\<in>space M. Q x} \<in> events \<Longrightarrow> \<P>(x in M. P x) = \<P>(x in M. Q x)"
  by (rule finite_measure_eq_AE) auto

lemma (in prob_space) prob_eq_0_AE:
  assumes not: "AE x in M. \<not> P x" shows "\<P>(x in M. P x) = 0"
proof cases
  assume "{x\<in>space M. P x} \<in> events"
  with not have "\<P>(x in M. P x) = \<P>(x in M. False)"
    by (intro prob_eq_AE) auto
  then show ?thesis by simp
qed (simp add: measure_notin_sets)

lemma (in prob_space) prob_Collect_eq_0:
  "{x \<in> space M. P x} \<in> sets M \<Longrightarrow> \<P>(x in M. P x) = 0 \<longleftrightarrow> (AE x in M. \<not> P x)"
  using AE_iff_measurable[OF _ refl, of M "\<lambda>x. \<not> P x"] by (simp add: emeasure_eq_measure)

lemma (in prob_space) prob_Collect_eq_1:
  "{x \<in> space M. P x} \<in> sets M \<Longrightarrow> \<P>(x in M. P x) = 1 \<longleftrightarrow> (AE x in M. P x)"
  using AE_in_set_eq_1[of "{x\<in>space M. P x}"] by simp

lemma (in prob_space) prob_eq_0:
  "A \<in> sets M \<Longrightarrow> prob A = 0 \<longleftrightarrow> (AE x in M. x \<notin> A)"
  using AE_iff_measurable[OF _ refl, of M "\<lambda>x. x \<notin> A"]
  by (auto simp add: emeasure_eq_measure Int_def[symmetric])

lemma (in prob_space) prob_eq_1:
  "A \<in> sets M \<Longrightarrow> prob A = 1 \<longleftrightarrow> (AE x in M. x \<in> A)"
  using AE_in_set_eq_1[of A] by simp

lemma (in prob_space) prob_sums:
  assumes P: "\<And>n. {x\<in>space M. P n x} \<in> events"
  assumes Q: "{x\<in>space M. Q x} \<in> events"
  assumes ae: "AE x in M. (\<forall>n. P n x \<longrightarrow> Q x) \<and> (Q x \<longrightarrow> (\<exists>!n. P n x))"
  shows "(\<lambda>n. \<P>(x in M. P n x)) sums \<P>(x in M. Q x)"
proof -
  from ae[THEN AE_E_prob] guess S . note S = this
  then have disj: "disjoint_family (\<lambda>n. {x\<in>space M. P n x} \<inter> S)"
    by (auto simp: disjoint_family_on_def)
  from S have ae_S:
    "AE x in M. x \<in> {x\<in>space M. Q x} \<longleftrightarrow> x \<in> (\<Union>n. {x\<in>space M. P n x} \<inter> S)"
    "\<And>n. AE x in M. x \<in> {x\<in>space M. P n x} \<longleftrightarrow> x \<in> {x\<in>space M. P n x} \<inter> S"
    using ae by (auto dest!: AE_prob_1)
  from ae_S have *:
    "\<P>(x in M. Q x) = prob (\<Union>n. {x\<in>space M. P n x} \<inter> S)"
    using P Q S by (intro finite_measure_eq_AE) auto
  from ae_S have **:
    "\<And>n. \<P>(x in M. P n x) = prob ({x\<in>space M. P n x} \<inter> S)"
    using P Q S by (intro finite_measure_eq_AE) auto
  show ?thesis
    unfolding * ** using S P disj
    by (intro finite_measure_UNION) auto
qed

lemma (in prob_space) prob_setsum:
  assumes [simp, intro]: "finite I"
  assumes P: "\<And>n. n \<in> I \<Longrightarrow> {x\<in>space M. P n x} \<in> events"
  assumes Q: "{x\<in>space M. Q x} \<in> events"
  assumes ae: "AE x in M. (\<forall>n\<in>I. P n x \<longrightarrow> Q x) \<and> (Q x \<longrightarrow> (\<exists>!n\<in>I. P n x))"
  shows "\<P>(x in M. Q x) = (\<Sum>n\<in>I. \<P>(x in M. P n x))"
proof -
  from ae[THEN AE_E_prob] guess S . note S = this
  then have disj: "disjoint_family_on (\<lambda>n. {x\<in>space M. P n x} \<inter> S) I"
    by (auto simp: disjoint_family_on_def)
  from S have ae_S:
    "AE x in M. x \<in> {x\<in>space M. Q x} \<longleftrightarrow> x \<in> (\<Union>n\<in>I. {x\<in>space M. P n x} \<inter> S)"
    "\<And>n. n \<in> I \<Longrightarrow> AE x in M. x \<in> {x\<in>space M. P n x} \<longleftrightarrow> x \<in> {x\<in>space M. P n x} \<inter> S"
    using ae by (auto dest!: AE_prob_1)
  from ae_S have *:
    "\<P>(x in M. Q x) = prob (\<Union>n\<in>I. {x\<in>space M. P n x} \<inter> S)"
    using P Q S by (intro finite_measure_eq_AE) (auto intro!: sets.Int)
  from ae_S have **:
    "\<And>n. n \<in> I \<Longrightarrow> \<P>(x in M. P n x) = prob ({x\<in>space M. P n x} \<inter> S)"
    using P Q S by (intro finite_measure_eq_AE) auto
  show ?thesis
    using S P disj
    by (auto simp add: * ** simp del: UN_simps intro!: finite_measure_finite_Union)
qed

lemma (in prob_space) prob_EX_countable:
  assumes sets: "\<And>i. i \<in> I \<Longrightarrow> {x\<in>space M. P i x} \<in> sets M" and I: "countable I"
  assumes disj: "AE x in M. \<forall>i\<in>I. \<forall>j\<in>I. P i x \<longrightarrow> P j x \<longrightarrow> i = j"
  shows "\<P>(x in M. \<exists>i\<in>I. P i x) = (\<integral>\<^sup>+i. \<P>(x in M. P i x) \<partial>count_space I)"
proof -
  let ?N= "\<lambda>x. \<exists>!i\<in>I. P i x"
  have "ereal (\<P>(x in M. \<exists>i\<in>I. P i x)) = \<P>(x in M. (\<exists>i\<in>I. P i x \<and> ?N x))"
    unfolding ereal.inject
  proof (rule prob_eq_AE)
    show "AE x in M. (\<exists>i\<in>I. P i x) = (\<exists>i\<in>I. P i x \<and> ?N x)"
      using disj by eventually_elim blast
  qed (auto intro!: sets.sets_Collect_countable_Ex' sets.sets_Collect_conj sets.sets_Collect_countable_Ex1' I sets)+
  also have "\<P>(x in M. (\<exists>i\<in>I. P i x \<and> ?N x)) = emeasure M (\<Union>i\<in>I. {x\<in>space M. P i x \<and> ?N x})"
    unfolding emeasure_eq_measure by (auto intro!: arg_cong[where f=prob])
  also have "\<dots> = (\<integral>\<^sup>+i. emeasure M {x\<in>space M. P i x \<and> ?N x} \<partial>count_space I)"
    by (rule emeasure_UN_countable)
       (auto intro!: sets.sets_Collect_countable_Ex' sets.sets_Collect_conj sets.sets_Collect_countable_Ex1' I sets
             simp: disjoint_family_on_def)
  also have "\<dots> = (\<integral>\<^sup>+i. \<P>(x in M. P i x) \<partial>count_space I)"
    unfolding emeasure_eq_measure using disj
    by (intro nn_integral_cong ereal.inject[THEN iffD2] prob_eq_AE)
       (auto intro!: sets.sets_Collect_countable_Ex' sets.sets_Collect_conj sets.sets_Collect_countable_Ex1' I sets)+
  finally show ?thesis .
qed

lemma (in prob_space) cond_prob_eq_AE:
  assumes P: "AE x in M. Q x \<longrightarrow> P x \<longleftrightarrow> P' x" "{x\<in>space M. P x} \<in> events" "{x\<in>space M. P' x} \<in> events"
  assumes Q: "AE x in M. Q x \<longleftrightarrow> Q' x" "{x\<in>space M. Q x} \<in> events" "{x\<in>space M. Q' x} \<in> events"
  shows "cond_prob M P Q = cond_prob M P' Q'"
  using P Q
  by (auto simp: cond_prob_def intro!: arg_cong2[where f="op /"] prob_eq_AE sets.sets_Collect_conj)

lemma (in prob_space) joint_distribution_Times_le_fst:
  "random_variable MX X \<Longrightarrow> random_variable MY Y \<Longrightarrow> A \<in> sets MX \<Longrightarrow> B \<in> sets MY
    \<Longrightarrow> emeasure (distr M (MX \<Otimes>\<^sub>M MY) (\<lambda>x. (X x, Y x))) (A \<times> B) \<le> emeasure (distr M MX X) A"
  by (auto simp: emeasure_distr measurable_pair_iff comp_def intro!: emeasure_mono measurable_sets)

lemma (in prob_space) joint_distribution_Times_le_snd:
  "random_variable MX X \<Longrightarrow> random_variable MY Y \<Longrightarrow> A \<in> sets MX \<Longrightarrow> B \<in> sets MY
    \<Longrightarrow> emeasure (distr M (MX \<Otimes>\<^sub>M MY) (\<lambda>x. (X x, Y x))) (A \<times> B) \<le> emeasure (distr M MY Y) B"
  by (auto simp: emeasure_distr measurable_pair_iff comp_def intro!: emeasure_mono measurable_sets)

lemma (in prob_space) variance_eq:
  fixes X :: "'a \<Rightarrow> real"
  assumes [simp]: "integrable M X"
  assumes [simp]: "integrable M (\<lambda>x. (X x)\<^sup>2)"
  shows "variance X = expectation (\<lambda>x. (X x)\<^sup>2) - (expectation X)\<^sup>2"
  by (simp add: field_simps prob_space power2_diff power2_eq_square[symmetric])

lemma (in prob_space) variance_positive: "0 \<le> variance (X::'a \<Rightarrow> real)"
  by (intro integral_nonneg_AE) (auto intro!: integral_nonneg_AE)

lemma (in prob_space) variance_mean_zero:
  "expectation X = 0 \<Longrightarrow> variance X = expectation (\<lambda>x. (X x)^2)"
  by simp

locale pair_prob_space = pair_sigma_finite M1 M2 + M1: prob_space M1 + M2: prob_space M2 for M1 M2

sublocale pair_prob_space \<subseteq> P: prob_space "M1 \<Otimes>\<^sub>M M2"
proof
  show "emeasure (M1 \<Otimes>\<^sub>M M2) (space (M1 \<Otimes>\<^sub>M M2)) = 1"
    by (simp add: M2.emeasure_pair_measure_Times M1.emeasure_space_1 M2.emeasure_space_1 space_pair_measure)
qed

locale product_prob_space = product_sigma_finite M for M :: "'i \<Rightarrow> 'a measure" +
  fixes I :: "'i set"
  assumes prob_space: "\<And>i. prob_space (M i)"

sublocale product_prob_space \<subseteq> M: prob_space "M i" for i
  by (rule prob_space)

locale finite_product_prob_space = finite_product_sigma_finite M I + product_prob_space M I for M I

sublocale finite_product_prob_space \<subseteq> prob_space "\<Pi>\<^sub>M i\<in>I. M i"
proof
  show "emeasure (\<Pi>\<^sub>M i\<in>I. M i) (space (\<Pi>\<^sub>M i\<in>I. M i)) = 1"
    by (simp add: measure_times M.emeasure_space_1 setprod.neutral_const space_PiM)
qed

lemma (in finite_product_prob_space) prob_times:
  assumes X: "\<And>i. i \<in> I \<Longrightarrow> X i \<in> sets (M i)"
  shows "prob (\<Pi>\<^sub>E i\<in>I. X i) = (\<Prod>i\<in>I. M.prob i (X i))"
proof -
  have "ereal (measure (\<Pi>\<^sub>M i\<in>I. M i) (\<Pi>\<^sub>E i\<in>I. X i)) = emeasure (\<Pi>\<^sub>M i\<in>I. M i) (\<Pi>\<^sub>E i\<in>I. X i)"
    using X by (simp add: emeasure_eq_measure)
  also have "\<dots> = (\<Prod>i\<in>I. emeasure (M i) (X i))"
    using measure_times X by simp
  also have "\<dots> = ereal (\<Prod>i\<in>I. measure (M i) (X i))"
    using X by (simp add: M.emeasure_eq_measure setprod_ereal)
  finally show ?thesis by simp
qed

subsection {* Distributions *}

definition "distributed M N X f \<longleftrightarrow> distr M N X = density N f \<and>
  f \<in> borel_measurable N \<and> (AE x in N. 0 \<le> f x) \<and> X \<in> measurable M N"

lemma
  assumes "distributed M N X f"
  shows distributed_distr_eq_density: "distr M N X = density N f"
    and distributed_measurable: "X \<in> measurable M N"
    and distributed_borel_measurable: "f \<in> borel_measurable N"
    and distributed_AE: "(AE x in N. 0 \<le> f x)"
  using assms by (simp_all add: distributed_def)

lemma
  assumes D: "distributed M N X f"
  shows distributed_measurable'[measurable_dest]:
      "g \<in> measurable L M \<Longrightarrow> (\<lambda>x. X (g x)) \<in> measurable L N"
    and distributed_borel_measurable'[measurable_dest]:
      "h \<in> measurable L N \<Longrightarrow> (\<lambda>x. f (h x)) \<in> borel_measurable L"
  using distributed_measurable[OF D] distributed_borel_measurable[OF D]
  by simp_all

lemma
  shows distributed_real_measurable: "distributed M N X (\<lambda>x. ereal (f x)) \<Longrightarrow> f \<in> borel_measurable N"
    and distributed_real_AE: "distributed M N X (\<lambda>x. ereal (f x)) \<Longrightarrow> (AE x in N. 0 \<le> f x)"
  by (simp_all add: distributed_def borel_measurable_ereal_iff)

lemma
  assumes D: "distributed M N X (\<lambda>x. ereal (f x))"
  shows distributed_real_measurable'[measurable_dest]:
      "h \<in> measurable L N \<Longrightarrow> (\<lambda>x. f (h x)) \<in> borel_measurable L"
  using distributed_real_measurable[OF D]
  by simp_all

lemma
  assumes D: "distributed M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x)) f"
  shows joint_distributed_measurable1[measurable_dest]:
      "h1 \<in> measurable N M \<Longrightarrow> (\<lambda>x. X (h1 x)) \<in> measurable N S"
    and joint_distributed_measurable2[measurable_dest]:
      "h2 \<in> measurable N M \<Longrightarrow> (\<lambda>x. Y (h2 x)) \<in> measurable N T"
  using measurable_compose[OF distributed_measurable[OF D] measurable_fst]
  using measurable_compose[OF distributed_measurable[OF D] measurable_snd]
  by auto

lemma distributed_count_space:
  assumes X: "distributed M (count_space A) X P" and a: "a \<in> A" and A: "finite A"
  shows "P a = emeasure M (X -` {a} \<inter> space M)"
proof -
  have "emeasure M (X -` {a} \<inter> space M) = emeasure (distr M (count_space A) X) {a}"
    using X a A by (simp add: emeasure_distr)
  also have "\<dots> = emeasure (density (count_space A) P) {a}"
    using X by (simp add: distributed_distr_eq_density)
  also have "\<dots> = (\<integral>\<^sup>+x. P a * indicator {a} x \<partial>count_space A)"
    using X a by (auto simp add: emeasure_density distributed_def indicator_def intro!: nn_integral_cong)
  also have "\<dots> = P a"
    using X a by (subst nn_integral_cmult_indicator) (auto simp: distributed_def one_ereal_def[symmetric] AE_count_space)
  finally show ?thesis ..
qed

lemma distributed_cong_density:
  "(AE x in N. f x = g x) \<Longrightarrow> g \<in> borel_measurable N \<Longrightarrow> f \<in> borel_measurable N \<Longrightarrow>
    distributed M N X f \<longleftrightarrow> distributed M N X g"
  by (auto simp: distributed_def intro!: density_cong)

lemma subdensity:
  assumes T: "T \<in> measurable P Q"
  assumes f: "distributed M P X f"
  assumes g: "distributed M Q Y g"
  assumes Y: "Y = T \<circ> X"
  shows "AE x in P. g (T x) = 0 \<longrightarrow> f x = 0"
proof -
  have "{x\<in>space Q. g x = 0} \<in> null_sets (distr M Q (T \<circ> X))"
    using g Y by (auto simp: null_sets_density_iff distributed_def)
  also have "distr M Q (T \<circ> X) = distr (distr M P X) Q T"
    using T f[THEN distributed_measurable] by (rule distr_distr[symmetric])
  finally have "T -` {x\<in>space Q. g x = 0} \<inter> space P \<in> null_sets (distr M P X)"
    using T by (subst (asm) null_sets_distr_iff) auto
  also have "T -` {x\<in>space Q. g x = 0} \<inter> space P = {x\<in>space P. g (T x) = 0}"
    using T by (auto dest: measurable_space)
  finally show ?thesis
    using f g by (auto simp add: null_sets_density_iff distributed_def)
qed

lemma subdensity_real:
  fixes g :: "'a \<Rightarrow> real" and f :: "'b \<Rightarrow> real"
  assumes T: "T \<in> measurable P Q"
  assumes f: "distributed M P X f"
  assumes g: "distributed M Q Y g"
  assumes Y: "Y = T \<circ> X"
  shows "AE x in P. g (T x) = 0 \<longrightarrow> f x = 0"
  using subdensity[OF T, of M X "\<lambda>x. ereal (f x)" Y "\<lambda>x. ereal (g x)"] assms by auto

lemma distributed_emeasure:
  "distributed M N X f \<Longrightarrow> A \<in> sets N \<Longrightarrow> emeasure M (X -` A \<inter> space M) = (\<integral>\<^sup>+x. f x * indicator A x \<partial>N)"
  by (auto simp: distributed_AE
                 distributed_distr_eq_density[symmetric] emeasure_density[symmetric] emeasure_distr)

lemma distributed_nn_integral:
  "distributed M N X f \<Longrightarrow> g \<in> borel_measurable N \<Longrightarrow> (\<integral>\<^sup>+x. f x * g x \<partial>N) = (\<integral>\<^sup>+x. g (X x) \<partial>M)"
  by (auto simp: distributed_AE
                 distributed_distr_eq_density[symmetric] nn_integral_density[symmetric] nn_integral_distr)

lemma distributed_integral:
  "distributed M N X f \<Longrightarrow> g \<in> borel_measurable N \<Longrightarrow> (\<integral>x. f x * g x \<partial>N) = (\<integral>x. g (X x) \<partial>M)"
  by (auto simp: distributed_real_AE
                 distributed_distr_eq_density[symmetric] integral_real_density[symmetric] integral_distr)

lemma distributed_transform_integral:
  assumes Px: "distributed M N X Px"
  assumes "distributed M P Y Py"
  assumes Y: "Y = T \<circ> X" and T: "T \<in> measurable N P" and f: "f \<in> borel_measurable P"
  shows "(\<integral>x. Py x * f x \<partial>P) = (\<integral>x. Px x * f (T x) \<partial>N)"
proof -
  have "(\<integral>x. Py x * f x \<partial>P) = (\<integral>x. f (Y x) \<partial>M)"
    by (rule distributed_integral) fact+
  also have "\<dots> = (\<integral>x. f (T (X x)) \<partial>M)"
    using Y by simp
  also have "\<dots> = (\<integral>x. Px x * f (T x) \<partial>N)"
    using measurable_comp[OF T f] Px by (intro distributed_integral[symmetric]) (auto simp: comp_def)
  finally show ?thesis .
qed

lemma (in prob_space) distributed_unique:
  assumes Px: "distributed M S X Px"
  assumes Py: "distributed M S X Py"
  shows "AE x in S. Px x = Py x"
proof -
  interpret X: prob_space "distr M S X"
    using Px by (intro prob_space_distr) simp
  have "sigma_finite_measure (distr M S X)" ..
  with sigma_finite_density_unique[of Px S Py ] Px Py
  show ?thesis
    by (auto simp: distributed_def)
qed

lemma (in prob_space) distributed_jointI:
  assumes "sigma_finite_measure S" "sigma_finite_measure T"
  assumes X[measurable]: "X \<in> measurable M S" and Y[measurable]: "Y \<in> measurable M T"
  assumes [measurable]: "f \<in> borel_measurable (S \<Otimes>\<^sub>M T)" and f: "AE x in S \<Otimes>\<^sub>M T. 0 \<le> f x"
  assumes eq: "\<And>A B. A \<in> sets S \<Longrightarrow> B \<in> sets T \<Longrightarrow>
    emeasure M {x \<in> space M. X x \<in> A \<and> Y x \<in> B} = (\<integral>\<^sup>+x. (\<integral>\<^sup>+y. f (x, y) * indicator B y \<partial>T) * indicator A x \<partial>S)"
  shows "distributed M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x)) f"
  unfolding distributed_def
proof safe
  interpret S: sigma_finite_measure S by fact
  interpret T: sigma_finite_measure T by fact
  interpret ST: pair_sigma_finite S T by default

  from ST.sigma_finite_up_in_pair_measure_generator guess F :: "nat \<Rightarrow> ('b \<times> 'c) set" .. note F = this
  let ?E = "{a \<times> b |a b. a \<in> sets S \<and> b \<in> sets T}"
  let ?P = "S \<Otimes>\<^sub>M T"
  show "distr M ?P (\<lambda>x. (X x, Y x)) = density ?P f" (is "?L = ?R")
  proof (rule measure_eqI_generator_eq[OF Int_stable_pair_measure_generator[of S T]])
    show "?E \<subseteq> Pow (space ?P)"
      using sets.space_closed[of S] sets.space_closed[of T] by (auto simp: space_pair_measure)
    show "sets ?L = sigma_sets (space ?P) ?E"
      by (simp add: sets_pair_measure space_pair_measure)
    then show "sets ?R = sigma_sets (space ?P) ?E"
      by simp
  next
    interpret L: prob_space ?L
      by (rule prob_space_distr) (auto intro!: measurable_Pair)
    show "range F \<subseteq> ?E" "(\<Union>i. F i) = space ?P" "\<And>i. emeasure ?L (F i) \<noteq> \<infinity>"
      using F by (auto simp: space_pair_measure)
  next
    fix E assume "E \<in> ?E"
    then obtain A B where E[simp]: "E = A \<times> B"
      and A[measurable]: "A \<in> sets S" and B[measurable]: "B \<in> sets T" by auto
    have "emeasure ?L E = emeasure M {x \<in> space M. X x \<in> A \<and> Y x \<in> B}"
      by (auto intro!: arg_cong[where f="emeasure M"] simp add: emeasure_distr measurable_Pair)
    also have "\<dots> = (\<integral>\<^sup>+x. (\<integral>\<^sup>+y. (f (x, y) * indicator B y) * indicator A x \<partial>T) \<partial>S)"
      using f by (auto simp add: eq nn_integral_multc intro!: nn_integral_cong)
    also have "\<dots> = emeasure ?R E"
      by (auto simp add: emeasure_density T.nn_integral_fst[symmetric]
               intro!: nn_integral_cong split: split_indicator)
    finally show "emeasure ?L E = emeasure ?R E" .
  qed
qed (auto simp: f)

lemma (in prob_space) distributed_swap:
  assumes "sigma_finite_measure S" "sigma_finite_measure T"
  assumes Pxy: "distributed M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x)) Pxy"
  shows "distributed M (T \<Otimes>\<^sub>M S) (\<lambda>x. (Y x, X x)) (\<lambda>(x, y). Pxy (y, x))"
proof -
  interpret S: sigma_finite_measure S by fact
  interpret T: sigma_finite_measure T by fact
  interpret ST: pair_sigma_finite S T by default
  interpret TS: pair_sigma_finite T S by default

  note Pxy[measurable]
  show ?thesis
    apply (subst TS.distr_pair_swap)
    unfolding distributed_def
  proof safe
    let ?D = "distr (S \<Otimes>\<^sub>M T) (T \<Otimes>\<^sub>M S) (\<lambda>(x, y). (y, x))"
    show 1: "(\<lambda>(x, y). Pxy (y, x)) \<in> borel_measurable ?D"
      by auto
    with Pxy
    show "AE x in distr (S \<Otimes>\<^sub>M T) (T \<Otimes>\<^sub>M S) (\<lambda>(x, y). (y, x)). 0 \<le> (case x of (x, y) \<Rightarrow> Pxy (y, x))"
      by (subst AE_distr_iff)
         (auto dest!: distributed_AE
               simp: measurable_split_conv split_beta
               intro!: measurable_Pair)
    show 2: "random_variable (distr (S \<Otimes>\<^sub>M T) (T \<Otimes>\<^sub>M S) (\<lambda>(x, y). (y, x))) (\<lambda>x. (Y x, X x))"
      using Pxy by auto
    { fix A assume A: "A \<in> sets (T \<Otimes>\<^sub>M S)"
      let ?B = "(\<lambda>(x, y). (y, x)) -` A \<inter> space (S \<Otimes>\<^sub>M T)"
      from sets.sets_into_space[OF A]
      have "emeasure M ((\<lambda>x. (Y x, X x)) -` A \<inter> space M) =
        emeasure M ((\<lambda>x. (X x, Y x)) -` ?B \<inter> space M)"
        by (auto intro!: arg_cong2[where f=emeasure] simp: space_pair_measure)
      also have "\<dots> = (\<integral>\<^sup>+ x. Pxy x * indicator ?B x \<partial>(S \<Otimes>\<^sub>M T))"
        using Pxy A by (intro distributed_emeasure) auto
      finally have "emeasure M ((\<lambda>x. (Y x, X x)) -` A \<inter> space M) =
        (\<integral>\<^sup>+ x. Pxy x * indicator A (snd x, fst x) \<partial>(S \<Otimes>\<^sub>M T))"
        by (auto intro!: nn_integral_cong split: split_indicator) }
    note * = this
    show "distr M ?D (\<lambda>x. (Y x, X x)) = density ?D (\<lambda>(x, y). Pxy (y, x))"
      apply (intro measure_eqI)
      apply (simp_all add: emeasure_distr[OF 2] emeasure_density[OF 1])
      apply (subst nn_integral_distr)
      apply (auto intro!: * simp: comp_def split_beta)
      done
  qed
qed

lemma (in prob_space) distr_marginal1:
  assumes "sigma_finite_measure S" "sigma_finite_measure T"
  assumes Pxy: "distributed M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x)) Pxy"
  defines "Px \<equiv> \<lambda>x. (\<integral>\<^sup>+z. Pxy (x, z) \<partial>T)"
  shows "distributed M S X Px"
  unfolding distributed_def
proof safe
  interpret S: sigma_finite_measure S by fact
  interpret T: sigma_finite_measure T by fact
  interpret ST: pair_sigma_finite S T by default

  note Pxy[measurable]
  show X: "X \<in> measurable M S" by simp

  show borel: "Px \<in> borel_measurable S"
    by (auto intro!: T.nn_integral_fst simp: Px_def)

  interpret Pxy: prob_space "distr M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x))"
    by (intro prob_space_distr) simp
  have "(\<integral>\<^sup>+ x. max 0 (- Pxy x) \<partial>(S \<Otimes>\<^sub>M T)) = (\<integral>\<^sup>+ x. 0 \<partial>(S \<Otimes>\<^sub>M T))"
    using Pxy
    by (intro nn_integral_cong_AE) (auto simp: max_def dest: distributed_AE)

  show "distr M S X = density S Px"
  proof (rule measure_eqI)
    fix A assume A: "A \<in> sets (distr M S X)"
    with X measurable_space[of Y M T]
    have "emeasure (distr M S X) A = emeasure (distr M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x))) (A \<times> space T)"
      by (auto simp add: emeasure_distr intro!: arg_cong[where f="emeasure M"])
    also have "\<dots> = emeasure (density (S \<Otimes>\<^sub>M T) Pxy) (A \<times> space T)"
      using Pxy by (simp add: distributed_def)
    also have "\<dots> = \<integral>\<^sup>+ x. \<integral>\<^sup>+ y. Pxy (x, y) * indicator (A \<times> space T) (x, y) \<partial>T \<partial>S"
      using A borel Pxy
      by (simp add: emeasure_density T.nn_integral_fst[symmetric])
    also have "\<dots> = \<integral>\<^sup>+ x. Px x * indicator A x \<partial>S"
      apply (rule nn_integral_cong_AE)
      using Pxy[THEN distributed_AE, THEN ST.AE_pair] AE_space
    proof eventually_elim
      fix x assume "x \<in> space S" "AE y in T. 0 \<le> Pxy (x, y)"
      moreover have eq: "\<And>y. y \<in> space T \<Longrightarrow> indicator (A \<times> space T) (x, y) = indicator A x"
        by (auto simp: indicator_def)
      ultimately have "(\<integral>\<^sup>+ y. Pxy (x, y) * indicator (A \<times> space T) (x, y) \<partial>T) = (\<integral>\<^sup>+ y. Pxy (x, y) \<partial>T) * indicator A x"
        by (simp add: eq nn_integral_multc cong: nn_integral_cong)
      also have "(\<integral>\<^sup>+ y. Pxy (x, y) \<partial>T) = Px x"
        by (simp add: Px_def ereal_real nn_integral_nonneg)
      finally show "(\<integral>\<^sup>+ y. Pxy (x, y) * indicator (A \<times> space T) (x, y) \<partial>T) = Px x * indicator A x" .
    qed
    finally show "emeasure (distr M S X) A = emeasure (density S Px) A"
      using A borel Pxy by (simp add: emeasure_density)
  qed simp

  show "AE x in S. 0 \<le> Px x"
    by (simp add: Px_def nn_integral_nonneg real_of_ereal_pos)
qed

lemma (in prob_space) distr_marginal2:
  assumes S: "sigma_finite_measure S" and T: "sigma_finite_measure T"
  assumes Pxy: "distributed M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x)) Pxy"
  shows "distributed M T Y (\<lambda>y. (\<integral>\<^sup>+x. Pxy (x, y) \<partial>S))"
  using distr_marginal1[OF T S distributed_swap[OF S T]] Pxy by simp

lemma (in prob_space) distributed_marginal_eq_joint1:
  assumes T: "sigma_finite_measure T"
  assumes S: "sigma_finite_measure S"
  assumes Px: "distributed M S X Px"
  assumes Pxy: "distributed M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x)) Pxy"
  shows "AE x in S. Px x = (\<integral>\<^sup>+y. Pxy (x, y) \<partial>T)"
  using Px distr_marginal1[OF S T Pxy] by (rule distributed_unique)

lemma (in prob_space) distributed_marginal_eq_joint2:
  assumes T: "sigma_finite_measure T"
  assumes S: "sigma_finite_measure S"
  assumes Py: "distributed M T Y Py"
  assumes Pxy: "distributed M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x)) Pxy"
  shows "AE y in T. Py y = (\<integral>\<^sup>+x. Pxy (x, y) \<partial>S)"
  using Py distr_marginal2[OF S T Pxy] by (rule distributed_unique)

lemma (in prob_space) distributed_joint_indep':
  assumes S: "sigma_finite_measure S" and T: "sigma_finite_measure T"
  assumes X[measurable]: "distributed M S X Px" and Y[measurable]: "distributed M T Y Py"
  assumes indep: "distr M S X \<Otimes>\<^sub>M distr M T Y = distr M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x))"
  shows "distributed M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x)) (\<lambda>(x, y). Px x * Py y)"
  unfolding distributed_def
proof safe
  interpret S: sigma_finite_measure S by fact
  interpret T: sigma_finite_measure T by fact
  interpret ST: pair_sigma_finite S T by default

  interpret X: prob_space "density S Px"
    unfolding distributed_distr_eq_density[OF X, symmetric]
    by (rule prob_space_distr) simp
  have sf_X: "sigma_finite_measure (density S Px)" ..

  interpret Y: prob_space "density T Py"
    unfolding distributed_distr_eq_density[OF Y, symmetric]
    by (rule prob_space_distr) simp
  have sf_Y: "sigma_finite_measure (density T Py)" ..

  show "distr M (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x)) = density (S \<Otimes>\<^sub>M T) (\<lambda>(x, y). Px x * Py y)"
    unfolding indep[symmetric] distributed_distr_eq_density[OF X] distributed_distr_eq_density[OF Y]
    using distributed_borel_measurable[OF X] distributed_AE[OF X]
    using distributed_borel_measurable[OF Y] distributed_AE[OF Y]
    by (rule pair_measure_density[OF _ _ _ _ T sf_Y])

  show "random_variable (S \<Otimes>\<^sub>M T) (\<lambda>x. (X x, Y x))" by auto

  show Pxy: "(\<lambda>(x, y). Px x * Py y) \<in> borel_measurable (S \<Otimes>\<^sub>M T)" by auto

  show "AE x in S \<Otimes>\<^sub>M T. 0 \<le> (case x of (x, y) \<Rightarrow> Px x * Py y)"
    apply (intro ST.AE_pair_measure borel_measurable_le Pxy borel_measurable_const)
    using distributed_AE[OF X]
    apply eventually_elim
    using distributed_AE[OF Y]
    apply eventually_elim
    apply auto
    done
qed

lemma distributed_integrable:
  "distributed M N X f \<Longrightarrow> g \<in> borel_measurable N \<Longrightarrow>
    integrable N (\<lambda>x. f x * g x) \<longleftrightarrow> integrable M (\<lambda>x. g (X x))"
  by (auto simp: distributed_real_AE
                    distributed_distr_eq_density[symmetric] integrable_real_density[symmetric] integrable_distr_eq)

lemma distributed_transform_integrable:
  assumes Px: "distributed M N X Px"
  assumes "distributed M P Y Py"
  assumes Y: "Y = (\<lambda>x. T (X x))" and T: "T \<in> measurable N P" and f: "f \<in> borel_measurable P"
  shows "integrable P (\<lambda>x. Py x * f x) \<longleftrightarrow> integrable N (\<lambda>x. Px x * f (T x))"
proof -
  have "integrable P (\<lambda>x. Py x * f x) \<longleftrightarrow> integrable M (\<lambda>x. f (Y x))"
    by (rule distributed_integrable) fact+
  also have "\<dots> \<longleftrightarrow> integrable M (\<lambda>x. f (T (X x)))"
    using Y by simp
  also have "\<dots> \<longleftrightarrow> integrable N (\<lambda>x. Px x * f (T x))"
    using measurable_comp[OF T f] Px by (intro distributed_integrable[symmetric]) (auto simp: comp_def)
  finally show ?thesis .
qed

lemma distributed_integrable_var:
  fixes X :: "'a \<Rightarrow> real"
  shows "distributed M lborel X (\<lambda>x. ereal (f x)) \<Longrightarrow> integrable lborel (\<lambda>x. f x * x) \<Longrightarrow> integrable M X"
  using distributed_integrable[of M lborel X f "\<lambda>x. x"] by simp

lemma (in prob_space) distributed_variance:
  fixes f::"real \<Rightarrow> real"
  assumes D: "distributed M lborel X f"
  shows "variance X = (\<integral>x. x\<^sup>2 * f (x + expectation X) \<partial>lborel)"
proof (subst distributed_integral[OF D, symmetric])
  show "(\<integral> x. f x * (x - expectation X)\<^sup>2 \<partial>lborel) = (\<integral> x. x\<^sup>2 * f (x + expectation X) \<partial>lborel)"
    by (subst lborel_integral_real_affine[where c=1 and t="expectation X"])  (auto simp: ac_simps)
qed simp

lemma (in prob_space) variance_affine:
  fixes f::"real \<Rightarrow> real"
  assumes [arith]: "b \<noteq> 0"
  assumes D[intro]: "distributed M lborel X f"
  assumes [simp]: "prob_space (density lborel f)"
  assumes I[simp]: "integrable M X"
  assumes I2[simp]: "integrable M (\<lambda>x. (X x)\<^sup>2)"
  shows "variance (\<lambda>x. a + b * X x) = b\<^sup>2 * variance X"
  by (subst variance_eq)
     (auto simp: power2_sum power_mult_distrib prob_space variance_eq right_diff_distrib)

definition
  "simple_distributed M X f \<longleftrightarrow> distributed M (count_space (X`space M)) X (\<lambda>x. ereal (f x)) \<and>
    finite (X`space M)"

lemma simple_distributed:
  "simple_distributed M X Px \<Longrightarrow> distributed M (count_space (X`space M)) X Px"
  unfolding simple_distributed_def by auto

lemma simple_distributed_finite[dest]: "simple_distributed M X P \<Longrightarrow> finite (X`space M)"
  by (simp add: simple_distributed_def)

lemma (in prob_space) distributed_simple_function_superset:
  assumes X: "simple_function M X" "\<And>x. x \<in> X ` space M \<Longrightarrow> P x = measure M (X -` {x} \<inter> space M)"
  assumes A: "X`space M \<subseteq> A" "finite A"
  defines "S \<equiv> count_space A" and "P' \<equiv> (\<lambda>x. if x \<in> X`space M then P x else 0)"
  shows "distributed M S X P'"
  unfolding distributed_def
proof safe
  show "(\<lambda>x. ereal (P' x)) \<in> borel_measurable S" unfolding S_def by simp
  show "AE x in S. 0 \<le> ereal (P' x)"
    using X by (auto simp: S_def P'_def simple_distributed_def intro!: measure_nonneg)
  show "distr M S X = density S P'"
  proof (rule measure_eqI_finite)
    show "sets (distr M S X) = Pow A" "sets (density S P') = Pow A"
      using A unfolding S_def by auto
    show "finite A" by fact
    fix a assume a: "a \<in> A"
    then have "a \<notin> X`space M \<Longrightarrow> X -` {a} \<inter> space M = {}" by auto
    with A a X have "emeasure (distr M S X) {a} = P' a"
      by (subst emeasure_distr)
         (auto simp add: S_def P'_def simple_functionD emeasure_eq_measure measurable_count_space_eq2
               intro!: arg_cong[where f=prob])
    also have "\<dots> = (\<integral>\<^sup>+x. ereal (P' a) * indicator {a} x \<partial>S)"
      using A X a
      by (subst nn_integral_cmult_indicator)
         (auto simp: S_def P'_def simple_distributed_def simple_functionD measure_nonneg)
    also have "\<dots> = (\<integral>\<^sup>+x. ereal (P' x) * indicator {a} x \<partial>S)"
      by (auto simp: indicator_def intro!: nn_integral_cong)
    also have "\<dots> = emeasure (density S P') {a}"
      using a A by (intro emeasure_density[symmetric]) (auto simp: S_def)
    finally show "emeasure (distr M S X) {a} = emeasure (density S P') {a}" .
  qed
  show "random_variable S X"
    using X(1) A by (auto simp: measurable_def simple_functionD S_def)
qed

lemma (in prob_space) simple_distributedI:
  assumes X: "simple_function M X" "\<And>x. x \<in> X ` space M \<Longrightarrow> P x = measure M (X -` {x} \<inter> space M)"
  shows "simple_distributed M X P"
  unfolding simple_distributed_def
proof
  have "distributed M (count_space (X ` space M)) X (\<lambda>x. ereal (if x \<in> X`space M then P x else 0))"
    (is "?A")
    using simple_functionD[OF X(1)] by (intro distributed_simple_function_superset[OF X]) auto
  also have "?A \<longleftrightarrow> distributed M (count_space (X ` space M)) X (\<lambda>x. ereal (P x))"
    by (rule distributed_cong_density) auto
  finally show "\<dots>" .
qed (rule simple_functionD[OF X(1)])

lemma simple_distributed_joint_finite:
  assumes X: "simple_distributed M (\<lambda>x. (X x, Y x)) Px"
  shows "finite (X ` space M)" "finite (Y ` space M)"
proof -
  have "finite ((\<lambda>x. (X x, Y x)) ` space M)"
    using X by (auto simp: simple_distributed_def simple_functionD)
  then have "finite (fst ` (\<lambda>x. (X x, Y x)) ` space M)" "finite (snd ` (\<lambda>x. (X x, Y x)) ` space M)"
    by auto
  then show fin: "finite (X ` space M)" "finite (Y ` space M)"
    by (auto simp: image_image)
qed

lemma simple_distributed_joint2_finite:
  assumes X: "simple_distributed M (\<lambda>x. (X x, Y x, Z x)) Px"
  shows "finite (X ` space M)" "finite (Y ` space M)" "finite (Z ` space M)"
proof -
  have "finite ((\<lambda>x. (X x, Y x, Z x)) ` space M)"
    using X by (auto simp: simple_distributed_def simple_functionD)
  then have "finite (fst ` (\<lambda>x. (X x, Y x, Z x)) ` space M)"
    "finite ((fst \<circ> snd) ` (\<lambda>x. (X x, Y x, Z x)) ` space M)"
    "finite ((snd \<circ> snd) ` (\<lambda>x. (X x, Y x, Z x)) ` space M)"
    by auto
  then show fin: "finite (X ` space M)" "finite (Y ` space M)" "finite (Z ` space M)"
    by (auto simp: image_image)
qed

lemma simple_distributed_simple_function:
  "simple_distributed M X Px \<Longrightarrow> simple_function M X"
  unfolding simple_distributed_def distributed_def
  by (auto simp: simple_function_def measurable_count_space_eq2)

lemma simple_distributed_measure:
  "simple_distributed M X P \<Longrightarrow> a \<in> X`space M \<Longrightarrow> P a = measure M (X -` {a} \<inter> space M)"
  using distributed_count_space[of M "X`space M" X P a, symmetric]
  by (auto simp: simple_distributed_def measure_def)

lemma simple_distributed_nonneg: "simple_distributed M X f \<Longrightarrow> x \<in> space M \<Longrightarrow> 0 \<le> f (X x)"
  by (auto simp: simple_distributed_measure measure_nonneg)

lemma (in prob_space) simple_distributed_joint:
  assumes X: "simple_distributed M (\<lambda>x. (X x, Y x)) Px"
  defines "S \<equiv> count_space (X`space M) \<Otimes>\<^sub>M count_space (Y`space M)"
  defines "P \<equiv> (\<lambda>x. if x \<in> (\<lambda>x. (X x, Y x))`space M then Px x else 0)"
  shows "distributed M S (\<lambda>x. (X x, Y x)) P"
proof -
  from simple_distributed_joint_finite[OF X, simp]
  have S_eq: "S = count_space (X`space M \<times> Y`space M)"
    by (simp add: S_def pair_measure_count_space)
  show ?thesis
    unfolding S_eq P_def
  proof (rule distributed_simple_function_superset)
    show "simple_function M (\<lambda>x. (X x, Y x))"
      using X by (rule simple_distributed_simple_function)
    fix x assume "x \<in> (\<lambda>x. (X x, Y x)) ` space M"
    from simple_distributed_measure[OF X this]
    show "Px x = prob ((\<lambda>x. (X x, Y x)) -` {x} \<inter> space M)" .
  qed auto
qed

lemma (in prob_space) simple_distributed_joint2:
  assumes X: "simple_distributed M (\<lambda>x. (X x, Y x, Z x)) Px"
  defines "S \<equiv> count_space (X`space M) \<Otimes>\<^sub>M count_space (Y`space M) \<Otimes>\<^sub>M count_space (Z`space M)"
  defines "P \<equiv> (\<lambda>x. if x \<in> (\<lambda>x. (X x, Y x, Z x))`space M then Px x else 0)"
  shows "distributed M S (\<lambda>x. (X x, Y x, Z x)) P"
proof -
  from simple_distributed_joint2_finite[OF X, simp]
  have S_eq: "S = count_space (X`space M \<times> Y`space M \<times> Z`space M)"
    by (simp add: S_def pair_measure_count_space)
  show ?thesis
    unfolding S_eq P_def
  proof (rule distributed_simple_function_superset)
    show "simple_function M (\<lambda>x. (X x, Y x, Z x))"
      using X by (rule simple_distributed_simple_function)
    fix x assume "x \<in> (\<lambda>x. (X x, Y x, Z x)) ` space M"
    from simple_distributed_measure[OF X this]
    show "Px x = prob ((\<lambda>x. (X x, Y x, Z x)) -` {x} \<inter> space M)" .
  qed auto
qed

lemma (in prob_space) simple_distributed_setsum_space:
  assumes X: "simple_distributed M X f"
  shows "setsum f (X`space M) = 1"
proof -
  from X have "setsum f (X`space M) = prob (\<Union>i\<in>X`space M. X -` {i} \<inter> space M)"
    by (subst finite_measure_finite_Union)
       (auto simp add: disjoint_family_on_def simple_distributed_measure simple_distributed_simple_function simple_functionD
             intro!: setsum.cong arg_cong[where f="prob"])
  also have "\<dots> = prob (space M)"
    by (auto intro!: arg_cong[where f=prob])
  finally show ?thesis
    using emeasure_space_1 by (simp add: emeasure_eq_measure one_ereal_def)
qed

lemma (in prob_space) distributed_marginal_eq_joint_simple:
  assumes Px: "simple_function M X"
  assumes Py: "simple_distributed M Y Py"
  assumes Pxy: "simple_distributed M (\<lambda>x. (X x, Y x)) Pxy"
  assumes y: "y \<in> Y`space M"
  shows "Py y = (\<Sum>x\<in>X`space M. if (x, y) \<in> (\<lambda>x. (X x, Y x)) ` space M then Pxy (x, y) else 0)"
proof -
  note Px = simple_distributedI[OF Px refl]
  have *: "\<And>f A. setsum (\<lambda>x. max 0 (ereal (f x))) A = ereal (setsum (\<lambda>x. max 0 (f x)) A)"
    by (simp add: setsum_ereal[symmetric] zero_ereal_def)
  from distributed_marginal_eq_joint2[OF
    sigma_finite_measure_count_space_finite
    sigma_finite_measure_count_space_finite
    simple_distributed[OF Py] simple_distributed_joint[OF Pxy],
    OF Py[THEN simple_distributed_finite] Px[THEN simple_distributed_finite]]
    y
    Px[THEN simple_distributed_finite]
    Py[THEN simple_distributed_finite]
    Pxy[THEN simple_distributed, THEN distributed_real_AE]
  show ?thesis
    unfolding AE_count_space
    apply (auto simp add: nn_integral_count_space_finite * intro!: setsum.cong split: split_max)
    done
qed

lemma distributedI_real:
  fixes f :: "'a \<Rightarrow> real"
  assumes gen: "sets M1 = sigma_sets (space M1) E" and "Int_stable E"
    and A: "range A \<subseteq> E" "(\<Union>i::nat. A i) = space M1" "\<And>i. emeasure (distr M M1 X) (A i) \<noteq> \<infinity>"
    and X: "X \<in> measurable M M1"
    and f: "f \<in> borel_measurable M1" "AE x in M1. 0 \<le> f x"
    and eq: "\<And>A. A \<in> E \<Longrightarrow> emeasure M (X -` A \<inter> space M) = (\<integral>\<^sup>+ x. f x * indicator A x \<partial>M1)"
  shows "distributed M M1 X f"
  unfolding distributed_def
proof (intro conjI)
  show "distr M M1 X = density M1 f"
  proof (rule measure_eqI_generator_eq[where A=A])
    { fix A assume A: "A \<in> E"
      then have "A \<in> sigma_sets (space M1) E" by auto
      then have "A \<in> sets M1"
        using gen by simp
      with f A eq[of A] X show "emeasure (distr M M1 X) A = emeasure (density M1 f) A"
        by (simp add: emeasure_distr emeasure_density borel_measurable_ereal
                      times_ereal.simps[symmetric] ereal_indicator
                 del: times_ereal.simps) }
    note eq_E = this
    show "Int_stable E" by fact
    { fix e assume "e \<in> E"
      then have "e \<in> sigma_sets (space M1) E" by auto
      then have "e \<in> sets M1" unfolding gen .
      then have "e \<subseteq> space M1" by (rule sets.sets_into_space) }
    then show "E \<subseteq> Pow (space M1)" by auto
    show "sets (distr M M1 X) = sigma_sets (space M1) E"
      "sets (density M1 (\<lambda>x. ereal (f x))) = sigma_sets (space M1) E"
      unfolding gen[symmetric] by auto
  qed fact+
qed (insert X f, auto)

lemma distributedI_borel_atMost:
  fixes f :: "real \<Rightarrow> real"
  assumes [measurable]: "X \<in> borel_measurable M"
    and [measurable]: "f \<in> borel_measurable borel" and f[simp]: "AE x in lborel. 0 \<le> f x"
    and g_eq: "\<And>a. (\<integral>\<^sup>+x. f x * indicator {..a} x \<partial>lborel)  = ereal (g a)"
    and M_eq: "\<And>a. emeasure M {x\<in>space M. X x \<le> a} = ereal (g a)"
  shows "distributed M lborel X f"
proof (rule distributedI_real)
  show "sets (lborel::real measure) = sigma_sets (space lborel) (range atMost)"
    by (simp add: borel_eq_atMost)
  show "Int_stable (range atMost :: real set set)"
    by (auto simp: Int_stable_def)
  have vimage_eq: "\<And>a. (X -` {..a} \<inter> space M) = {x\<in>space M. X x \<le> a}" by auto
  def A \<equiv> "\<lambda>i::nat. {.. real i}"
  then show "range A \<subseteq> range atMost" "(\<Union>i. A i) = space lborel"
    "\<And>i. emeasure (distr M lborel X) (A i) \<noteq> \<infinity>"
    by (auto simp: real_arch_simple emeasure_distr vimage_eq M_eq)

  fix A :: "real set" assume "A \<in> range atMost"
  then obtain a where A: "A = {..a}" by auto
  show "emeasure M (X -` A \<inter> space M) = (\<integral>\<^sup>+x. f x * indicator A x \<partial>lborel)"
    unfolding vimage_eq A M_eq g_eq ..
qed auto

lemma (in prob_space) uniform_distributed_params:
  assumes X: "distributed M MX X (\<lambda>x. indicator A x / measure MX A)"
  shows "A \<in> sets MX" "measure MX A \<noteq> 0"
proof -
  interpret X: prob_space "distr M MX X"
    using distributed_measurable[OF X] by (rule prob_space_distr)

  show "measure MX A \<noteq> 0"
  proof
    assume "measure MX A = 0"
    with X.emeasure_space_1 X.prob_space distributed_distr_eq_density[OF X]
    show False
      by (simp add: emeasure_density zero_ereal_def[symmetric])
  qed
  with measure_notin_sets[of A MX] show "A \<in> sets MX"
    by blast
qed

lemma prob_space_uniform_measure:
  assumes A: "emeasure M A \<noteq> 0" "emeasure M A \<noteq> \<infinity>"
  shows "prob_space (uniform_measure M A)"
proof
  show "emeasure (uniform_measure M A) (space (uniform_measure M A)) = 1"
    using emeasure_uniform_measure[OF emeasure_neq_0_sets[OF A(1)], of "space M"]
    using sets.sets_into_space[OF emeasure_neq_0_sets[OF A(1)]] A
    by (simp add: Int_absorb2 emeasure_nonneg)
qed

lemma prob_space_uniform_count_measure: "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> prob_space (uniform_count_measure A)"
  by default (auto simp: emeasure_uniform_count_measure space_uniform_count_measure one_ereal_def)

lemma (in prob_space) measure_uniform_measure_eq_cond_prob:
  assumes [measurable]: "Measurable.pred M P" "Measurable.pred M Q"
  shows "\<P>(x in uniform_measure M {x\<in>space M. Q x}. P x) = \<P>(x in M. P x \<bar> Q x)"
proof cases
  assume Q: "measure M {x\<in>space M. Q x} = 0"
  then have "AE x in M. \<not> Q x"
    by (simp add: prob_eq_0)
  then have "AE x in M. indicator {x\<in>space M. Q x} x / ereal 0 = 0"
    by (auto split: split_indicator)
  from density_cong[OF _ _ this] show ?thesis
    by (simp add: uniform_measure_def emeasure_eq_measure cond_prob_def Q measure_density_const)
qed (auto simp add: emeasure_eq_measure cond_prob_def intro!: arg_cong[where f=prob])

lemma prob_space_point_measure:
  "finite S \<Longrightarrow> (\<And>s. s \<in> S \<Longrightarrow> 0 \<le> p s) \<Longrightarrow> (\<Sum>s\<in>S. p s) = 1 \<Longrightarrow> prob_space (point_measure S p)"
  by (rule prob_spaceI) (simp add: space_point_measure emeasure_point_measure_finite)

end


section \<open>Order and Equivalence on Lenses\<close>

theory Lens_Order
imports Lens_Algebra
begin

subsection \<open>Sub-lens Relation\<close>

text \<open>A lens $X$ is a sub-lens of $Y$ if there is a well-behaved lens $Z$ such that $X = Z \lcomp Y$,
  or in other words if $X$ can be expressed purely in terms of $Y$.\<close>

definition sublens :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> bool" (infix "\<subseteq>\<^sub>L" 55) where
[lens_defs]: "sublens X Y = (\<exists> Z :: ('a, 'b) lens. vwb_lens Z \<and> X = Z ;\<^sub>L Y)"

text \<open>Various lens classes are downward closed under the sublens relation.\<close>

lemma sublens_pres_mwb:
  "\<lbrakk> mwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> mwb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

lemma sublens_pres_wb:
  "\<lbrakk> wb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> wb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

lemma sublens_pres_vwb:
  "\<lbrakk> vwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> vwb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

text \<open>Sublens is a preorder as the following two theorems show.\<close>

lemma sublens_refl:
  "X \<subseteq>\<^sub>L X"
  using id_vwb_lens sublens_def by fastforce

lemma sublens_trans [trans]:
  "\<lbrakk> X \<subseteq>\<^sub>L Y; Y \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<subseteq>\<^sub>L Z"
  apply (auto simp add: sublens_def lens_comp_assoc)
  apply (rename_tac Z\<^sub>1 Z\<^sub>2)
  apply (rule_tac x="Z\<^sub>1 ;\<^sub>L Z\<^sub>2" in exI)
  apply (simp add: lens_comp_assoc)
  using comp_vwb_lens apply blast
done

text \<open>Sublens has a least element -- @{text "0\<^sub>L"} -- and a greatest element -- @{text "1\<^sub>L"}.
  Intuitively, this shows that sublens orders how large a portion of the source type a particular
  lens views, with @{text "0\<^sub>L"} observing the least, and @{text "1\<^sub>L"} observing the most.\<close>

lemma sublens_least: "wb_lens X \<Longrightarrow> 0\<^sub>L \<subseteq>\<^sub>L X"
  using sublens_def unit_vwb_lens by fastforce

lemma sublens_greatest: "vwb_lens X \<Longrightarrow> X \<subseteq>\<^sub>L 1\<^sub>L"
  by (simp add: sublens_def)

text \<open>If $Y$ is a sublens of $X$ then any put using $X$ will necessarily erase any put using $Y$.
  Similarly, any two source types are observationally equivalent by $Y$ when performed
  following a put using $X$.\<close>

lemma sublens_obs_get:
  "\<lbrakk> mwb_lens X; Y \<subseteq>\<^sub>L X \<rbrakk> \<Longrightarrow>  get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<sigma> v) = get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<rho> v)"
  by (auto simp add: sublens_def lens_comp_def)

text \<open>Sublens preserves independence; in other words if $Y$ is independent of $Z$, then also
  any $X$ smaller than $Y$ is independent of $Z$.\<close>

lemma sublens_pres_indep:
  "\<lbrakk> X \<subseteq>\<^sub>L Y; Y \<bowtie> Z \<rbrakk> \<Longrightarrow> X \<bowtie> Z"
  apply (auto intro!:lens_indepI simp add: sublens_def lens_comp_def lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma sublens_pres_indep':
  "\<lbrakk> X \<subseteq>\<^sub>L Y; Z \<bowtie> Y \<rbrakk> \<Longrightarrow> Z \<bowtie> X"
  by (meson lens_indep_sym sublens_pres_indep)

lemma sublens_compat: "\<lbrakk> vwb_lens X; vwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> X ##\<^sub>L Y"
  unfolding lens_compat_def lens_override_def
  by (metis (no_types, hide_lams) sublens_obs_get sublens_put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put)

text \<open>Well-behavedness of lens quotient has sublens as a proviso. This is because we can only
  remove $X$ from $Y$ if $X$ is smaller than $Y$. \<close>

lemma lens_quotient_mwb:
  "\<lbrakk> mwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> mwb_lens (X /\<^sub>L Y)"
  by (unfold_locales, auto simp add: lens_quotient_def lens_create_def sublens_def lens_comp_def comp_def)

subsection \<open>Lens Equivalence\<close>

text \<open>Using our preorder, we can also derive an equivalence on lenses as follows. It should be
  noted that this equality, like sublens, is heterogeneously typed -- it can compare lenses whose
  view types are different, so long as the source types are the same. We show that it is reflexive,
  symmetric, and transitive. \<close>

definition lens_equiv :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> bool" (infix "\<approx>\<^sub>L" 51) where
[lens_defs]: "lens_equiv X Y = (X \<subseteq>\<^sub>L Y \<and> Y \<subseteq>\<^sub>L X)"

lemma lens_equivI [intro]:
  "\<lbrakk> X \<subseteq>\<^sub>L Y; Y \<subseteq>\<^sub>L X \<rbrakk> \<Longrightarrow> X \<approx>\<^sub>L Y"
  by (simp add: lens_equiv_def)

lemma lens_equiv_refl:
  "X \<approx>\<^sub>L X"
  by (simp add: lens_equiv_def sublens_refl)

lemma lens_equiv_sym:
  "X \<approx>\<^sub>L Y \<Longrightarrow> Y \<approx>\<^sub>L X"
  by (simp add: lens_equiv_def)

lemma lens_equiv_trans [trans]:
  "\<lbrakk> X \<approx>\<^sub>L Y; Y \<approx>\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<approx>\<^sub>L Z"
  by (auto intro: sublens_trans simp add: lens_equiv_def)

lemma lens_equiv_pres_indep:
  "\<lbrakk> X \<approx>\<^sub>L Y; Y \<bowtie> Z \<rbrakk> \<Longrightarrow> X \<bowtie> Z"
  using lens_equiv_def sublens_pres_indep by blast

lemma lens_equiv_pres_indep':
  "\<lbrakk> X \<approx>\<^sub>L Y; Z \<bowtie> Y \<rbrakk> \<Longrightarrow> Z \<bowtie> X"
  using lens_equiv_def sublens_pres_indep' by blast

lemma lens_comp_cong_1: "X \<approx>\<^sub>L Y \<Longrightarrow> X ;\<^sub>L Z \<approx>\<^sub>L Y ;\<^sub>L Z"
  unfolding lens_equiv_def
  by (metis (no_types, lifting) lens_comp_assoc sublens_def)

subsection \<open>Further Algebraic Laws\<close>

text \<open>This law explains the behaviour of lens quotient.\<close>

lemma lens_quotient_comp:
  "\<lbrakk> weak_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> (X /\<^sub>L Y) ;\<^sub>L Y = X"
  by (auto simp add: lens_quotient_def lens_comp_def comp_def sublens_def)

text \<open>Plus distributes through quotient.\<close>

lemma lens_quotient_plus:
  "\<lbrakk> mwb_lens Z; X \<subseteq>\<^sub>L Z; Y \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> (X +\<^sub>L Y) /\<^sub>L Z = (X /\<^sub>L Z) +\<^sub>L (Y /\<^sub>L Z)"
  apply (auto simp add: lens_quotient_def lens_plus_def sublens_def lens_comp_def comp_def)
  apply (rule ext)
  apply (rule ext)
  apply (simp add: prod.case_eq_if)
done

text \<open>There follows a number of laws relating sublens and summation. Firstly, sublens is preserved
  by summation. \<close>

lemma plus_pred_sublens: "\<lbrakk> mwb_lens Z; X \<subseteq>\<^sub>L Z; Y \<subseteq>\<^sub>L Z; X \<bowtie> Y \<rbrakk> \<Longrightarrow> (X +\<^sub>L Y) \<subseteq>\<^sub>L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z\<^sub>1 Z\<^sub>2)
  apply (rule_tac x="Z\<^sub>1 +\<^sub>L Z\<^sub>2" in exI)
  apply (auto intro!: plus_wb_lens)
   apply (simp add: lens_comp_indep_cong_left plus_vwb_lens)
  apply (simp add: plus_lens_distr)
done

text \<open>Intuitively, lens plus is associative. However we cannot prove this using HOL equality due
  to monomorphic typing of this operator. But since sublens and lens equivalence are both heterogeneous
  we can now prove this in the following three lemmas.\<close>

lemma lens_plus_sub_assoc_1:
  "X +\<^sub>L Y +\<^sub>L Z \<subseteq>\<^sub>L (X +\<^sub>L Y) +\<^sub>L Z"
  apply (simp add: sublens_def)
  apply (rule_tac x="(fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L snd\<^sub>L" in exI)
  apply (auto)
   apply (rule plus_vwb_lens)
     apply (simp add: comp_vwb_lens fst_vwb_lens)
    apply (rule plus_vwb_lens)
      apply (simp add: comp_vwb_lens fst_vwb_lens snd_vwb_lens)
     apply (simp add: snd_vwb_lens)
    apply (simp add: lens_indep_left_ext)
   apply (rule lens_indep_sym)
   apply (rule plus_pres_lens_indep)
    using fst_snd_lens_indep fst_vwb_lens lens_indep_left_comp lens_indep_sym vwb_lens_mwb apply blast
   using fst_snd_lens_indep lens_indep_left_ext lens_indep_sym apply blast
  apply (auto simp add: lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if split_beta')[1]
done

lemma lens_plus_sub_assoc_2:
  "(X +\<^sub>L Y) +\<^sub>L Z \<subseteq>\<^sub>L X +\<^sub>L Y +\<^sub>L Z"
  apply (simp add: sublens_def)
  apply (rule_tac x="(fst\<^sub>L +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>L)" in exI)
  apply (auto)
   apply (rule plus_vwb_lens)
     apply (rule plus_vwb_lens)
       apply (simp add: fst_vwb_lens)
      apply (simp add: comp_vwb_lens fst_vwb_lens snd_vwb_lens)
     apply (rule lens_indep_sym)
     apply (rule lens_indep_left_ext)
     using fst_snd_lens_indep lens_indep_sym apply blast
    apply (auto intro: comp_vwb_lens simp add: snd_vwb_lens)
   apply (rule plus_pres_lens_indep)
    apply (simp add: lens_indep_left_ext lens_indep_sym)
   apply (simp add: snd_vwb_lens)
  apply (auto simp add: lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if split_beta')[1]
done

lemma lens_plus_assoc:
  "(X +\<^sub>L Y) +\<^sub>L Z \<approx>\<^sub>L X +\<^sub>L Y +\<^sub>L Z"
  by (simp add: lens_equivI lens_plus_sub_assoc_1 lens_plus_sub_assoc_2)

text \<open>We can similarly show that it is commutative.\<close>

lemma lens_plus_sub_comm: "X \<bowtie> Y \<Longrightarrow> X +\<^sub>L Y \<subseteq>\<^sub>L Y +\<^sub>L X"
  apply (simp add: sublens_def)
  apply (rule_tac x="snd\<^sub>L +\<^sub>L fst\<^sub>L" in exI)
  apply (auto)
   apply (simp add: fst_vwb_lens lens_indep_sym plus_vwb_lens snd_vwb_lens)
  apply (simp add: lens_indep_sym lens_plus_swap)
done

lemma lens_plus_comm: "X \<bowtie> Y \<Longrightarrow> X +\<^sub>L Y \<approx>\<^sub>L Y +\<^sub>L X"
  by (simp add: lens_equivI lens_indep_sym lens_plus_sub_comm)

text \<open>Any composite lens is larger than an element of the lens, as demonstrated by the following
  four laws.\<close>

lemma lens_plus_ub: "wb_lens Y \<Longrightarrow> X \<subseteq>\<^sub>L X +\<^sub>L Y"
  by (metis fst_lens_plus fst_vwb_lens sublens_def)

lemma lens_plus_right_sublens:
  "\<lbrakk> vwb_lens Y; Y \<bowtie> Z; X \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<subseteq>\<^sub>L Y +\<^sub>L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z')
  apply (rule_tac x="Z' ;\<^sub>L snd\<^sub>L" in exI)
  apply (auto)
  using comp_vwb_lens snd_vwb_lens apply blast
  apply (metis lens_comp_assoc snd_lens_plus vwb_lens_def)
  done

lemma lens_plus_mono_left:
  "\<lbrakk> Y \<bowtie> Z; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> X +\<^sub>L Z \<subseteq>\<^sub>L Y +\<^sub>L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z')
  apply (rule_tac x="Z' \<times>\<^sub>L 1\<^sub>L" in exI)
  apply (subst prod_lens_comp_plus)
   apply (simp_all)
  using id_vwb_lens prod_vwb_lens apply blast
  done

lemma lens_plus_mono_right:
  "\<lbrakk> X \<bowtie> Z; Y \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> X +\<^sub>L Y \<subseteq>\<^sub>L X +\<^sub>L Z"
  by (metis prod_lens_comp_plus prod_vwb_lens sublens_def sublens_refl)

text \<open>If we compose a lens $X$ with lens $Y$ then naturally the resulting lens must be smaller
  than $Y$, as $X$ views a part of $Y$. \<close>

lemma lens_comp_lb [simp]: "vwb_lens X \<Longrightarrow> X ;\<^sub>L Y \<subseteq>\<^sub>L Y"
  by (auto simp add: sublens_def)

lemma sublens_comp [simp]:
  assumes "vwb_lens b" "c \<subseteq>\<^sub>L a"
  shows "(b ;\<^sub>L c) \<subseteq>\<^sub>L a"
  by (metis assms sublens_def sublens_trans)

text \<open>We can now also show that @{text "0\<^sub>L"} is the unit of lens plus\<close>

lemma lens_unit_plus_sublens_1: "X \<subseteq>\<^sub>L 0\<^sub>L +\<^sub>L X"
  by (metis lens_comp_lb snd_lens_plus snd_vwb_lens zero_lens_indep unit_wb_lens)

lemma lens_unit_prod_sublens_2: "0\<^sub>L +\<^sub>L X \<subseteq>\<^sub>L X"
  apply (auto simp add: sublens_def)
  apply (rule_tac x="0\<^sub>L +\<^sub>L 1\<^sub>L" in exI)
  apply (auto)
  apply (auto simp add: lens_plus_def zero_lens_def lens_comp_def id_lens_def prod.case_eq_if comp_def)
  apply (rule ext)
  apply (rule ext)
  apply (auto)
done

lemma lens_plus_left_unit: "0\<^sub>L +\<^sub>L X \<approx>\<^sub>L X"
  by (simp add: lens_equivI lens_unit_plus_sublens_1 lens_unit_prod_sublens_2)

lemma lens_plus_right_unit: "X +\<^sub>L 0\<^sub>L \<approx>\<^sub>L X"
  using lens_equiv_trans lens_indep_sym lens_plus_comm lens_plus_left_unit zero_lens_indep by blast

text \<open>We can also show that both sublens and equivalence are congruences with respect to lens plus
  and lens product.\<close>

lemma lens_plus_subcong: "\<lbrakk> Y\<^sub>1 \<bowtie> Y\<^sub>2; X\<^sub>1 \<subseteq>\<^sub>L Y\<^sub>1; X\<^sub>2 \<subseteq>\<^sub>L Y\<^sub>2 \<rbrakk> \<Longrightarrow> X\<^sub>1 +\<^sub>L X\<^sub>2 \<subseteq>\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>2"
  by (metis prod_lens_comp_plus prod_vwb_lens sublens_def)

lemma lens_plus_eq_left: "\<lbrakk> X \<bowtie> Z; X \<approx>\<^sub>L Y \<rbrakk> \<Longrightarrow> X +\<^sub>L Z \<approx>\<^sub>L Y +\<^sub>L Z"
  by (meson lens_equiv_def lens_plus_mono_left sublens_pres_indep)

lemma lens_plus_eq_right: "\<lbrakk> X \<bowtie> Y; Y \<approx>\<^sub>L Z \<rbrakk> \<Longrightarrow> X +\<^sub>L Y \<approx>\<^sub>L X +\<^sub>L Z"
  by (meson lens_equiv_def lens_indep_sym lens_plus_mono_right sublens_pres_indep)

lemma lens_plus_cong:
  assumes "X\<^sub>1 \<bowtie> X\<^sub>2" "X\<^sub>1 \<approx>\<^sub>L Y\<^sub>1" "X\<^sub>2 \<approx>\<^sub>L Y\<^sub>2"
  shows "X\<^sub>1 +\<^sub>L X\<^sub>2 \<approx>\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>2"
proof -
  have "X\<^sub>1 +\<^sub>L X\<^sub>2 \<approx>\<^sub>L Y\<^sub>1 +\<^sub>L X\<^sub>2"
    by (simp add: assms(1) assms(2) lens_plus_eq_left)
  moreover have "... \<approx>\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>2"
    using assms(1) assms(2) assms(3) lens_equiv_def lens_plus_eq_right sublens_pres_indep by blast
  ultimately show ?thesis
    using lens_equiv_trans by blast
qed

lemma prod_lens_sublens_cong:
  "\<lbrakk> X\<^sub>1 \<subseteq>\<^sub>L X\<^sub>2; Y\<^sub>1 \<subseteq>\<^sub>L Y\<^sub>2 \<rbrakk> \<Longrightarrow> (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) \<subseteq>\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z\<^sub>1 Z\<^sub>2)
  apply (rule_tac x="Z\<^sub>1 \<times>\<^sub>L Z\<^sub>2" in exI)
  apply (auto)
   using prod_vwb_lens apply blast
  apply (auto simp add: lens_prod_def lens_comp_def prod.case_eq_if)
  apply (rule ext, rule ext)
  apply (auto simp add: lens_prod_def lens_comp_def prod.case_eq_if)
done

lemma prod_lens_equiv_cong:
  "\<lbrakk> X\<^sub>1 \<approx>\<^sub>L X\<^sub>2; Y\<^sub>1 \<approx>\<^sub>L Y\<^sub>2 \<rbrakk> \<Longrightarrow> (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) \<approx>\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
  by (simp add: lens_equiv_def prod_lens_sublens_cong)

text \<open>We also have the following "exchange" law that allows us to switch over a lens product and plus.\<close>

lemma lens_plus_prod_exchange:
  "(X\<^sub>1 +\<^sub>L X\<^sub>2) \<times>\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2) \<approx>\<^sub>L (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
proof (rule lens_equivI)
  show "(X\<^sub>1 +\<^sub>L X\<^sub>2) \<times>\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2) \<subseteq>\<^sub>L (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
    apply (simp add: sublens_def)
    apply (rule_tac x="((fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L ((snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>L))" in exI)
    apply (auto)
     apply (auto intro!: plus_vwb_lens comp_vwb_lens fst_vwb_lens snd_vwb_lens lens_indep_right_comp)
       apply (auto intro!: lens_indepI simp add: lens_comp_def lens_plus_def fst_lens_def snd_lens_def)
    apply (auto simp add: lens_prod_def lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if comp_def)[1]
    apply (rule ext, rule ext, auto simp add: prod.case_eq_if)
  done
  show "(X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2) \<subseteq>\<^sub>L (X\<^sub>1 +\<^sub>L X\<^sub>2) \<times>\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2)"
    apply (simp add: sublens_def)
    apply (rule_tac x="((fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L ((snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>L))" in exI)
    apply (auto)
     apply (auto intro!: plus_vwb_lens comp_vwb_lens fst_vwb_lens snd_vwb_lens lens_indep_right_comp)
       apply (auto intro!: lens_indepI simp add: lens_comp_def lens_plus_def fst_lens_def snd_lens_def)
     apply (auto simp add: lens_prod_def lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if comp_def)[1]
    apply (rule ext, rule ext, auto simp add: lens_prod_def prod.case_eq_if)
  done
qed

lemma lens_get_put_quasi_commute:
  "\<lbrakk> vwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> s v) = put\<^bsub>X /\<^sub>L Y\<^esub> (get\<^bsub>Y\<^esub> s) v"
proof -
  assume a1: "vwb_lens Y"
  assume a2: "X \<subseteq>\<^sub>L Y"
  have "\<And>l la. put\<^bsub>l ;\<^sub>L la\<^esub> = (\<lambda>b c. put\<^bsub>la\<^esub> (b::'b) (put\<^bsub>l\<^esub> (get\<^bsub>la\<^esub> b::'a) (c::'c)))"
    by (simp add: lens_comp_def)
  then have "\<And>l la b c. get\<^bsub>l\<^esub> (put\<^bsub>la ;\<^sub>L l\<^esub> (b::'b) (c::'c)) = put\<^bsub>la\<^esub> (get\<^bsub>l\<^esub> b::'a) c \<or> \<not> weak_lens l"
    by force
  then show ?thesis
    using a2 a1 by (metis lens_quotient_comp vwb_lens_wb wb_lens_def)
qed

lemma lens_put_of_quotient:
  "\<lbrakk> vwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> put\<^bsub>Y\<^esub> s (put\<^bsub>X /\<^sub>L Y\<^esub> v\<^sub>2 v\<^sub>1) = put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> s v\<^sub>2) v\<^sub>1"
proof -
  assume a1: "vwb_lens Y"
  assume a2: "X \<subseteq>\<^sub>L Y"
  have f3: "\<And>l b. put\<^bsub>l\<^esub> (b::'b) (get\<^bsub>l\<^esub> b::'a) = b \<or> \<not> vwb_lens l"
    by force
  have f4: "\<And>b c. put\<^bsub>X /\<^sub>L Y\<^esub> (get\<^bsub>Y\<^esub> b) c = get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> b c)"
    using a2 a1 by (simp add: lens_get_put_quasi_commute)
  have "\<And>b c a. put\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> b c) a = put\<^bsub>Y\<^esub> b a"
    using a2 a1 by (simp add: sublens_put_put)
  then show ?thesis
    using f4 f3 a1 by (metis mwb_lens.put_put mwb_lens_def vwb_lens_mwb weak_lens.put_get)
qed

subsection \<open>Bijective Lens Equivalences\<close>

text \<open>A bijective lens, like a bijective function, is its own inverse. Thus, if we compose its inverse
  with itself we get @{term "1\<^sub>L"}.\<close>

lemma bij_lens_inv_left:
  "bij_lens X \<Longrightarrow> inv\<^sub>L X ;\<^sub>L X = 1\<^sub>L"
  by (auto simp add: lens_inv_def lens_comp_def lens_create_def comp_def id_lens_def, rule ext, auto)

lemma bij_lens_inv_right:
  "bij_lens X \<Longrightarrow> X ;\<^sub>L inv\<^sub>L X = 1\<^sub>L"
  by (auto simp add: lens_inv_def lens_comp_def comp_def id_lens_def, rule ext, auto)

text \<open>The following important results shows that bijective lenses are precisely those that are
  equivalent to identity. In other words, a bijective lens views all of the source type.\<close>

lemma bij_lens_equiv_id:
  "bij_lens X \<longleftrightarrow> X \<approx>\<^sub>L 1\<^sub>L"
  apply (auto)
   apply (rule lens_equivI)
    apply (simp_all add: sublens_def)
   apply (rule_tac x="lens_inv X" in exI)
   apply (simp add: bij_lens_inv_left lens_inv_bij)
  apply (auto simp add: lens_equiv_def sublens_def id_lens_def lens_comp_def comp_def)
  apply (unfold_locales)
   apply (simp)
  apply (simp)
  apply (metis (no_types, lifting) vwb_lens_wb wb_lens_weak weak_lens.put_get)
done

text \<open>For this reason, by transitivity, any two bijective lenses with the same source type must be equivalent.\<close>

lemma bij_lens_equiv:
  "\<lbrakk> bij_lens X; X \<approx>\<^sub>L Y \<rbrakk> \<Longrightarrow> bij_lens Y"
  by (meson bij_lens_equiv_id lens_equiv_def sublens_trans)

lemma bij_lens_cong:
  "X \<approx>\<^sub>L Y \<Longrightarrow> bij_lens X = bij_lens Y"
  by (meson bij_lens_equiv lens_equiv_sym)

text \<open>We can also show that the identity lens @{term "1\<^sub>L"} is unique. That is to say it is the only
  lens which when compose with $Y$ will yield $Y$.\<close>

lemma lens_id_unique:
  "weak_lens Y \<Longrightarrow> Y = X ;\<^sub>L Y \<Longrightarrow> X = 1\<^sub>L"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
   apply (metis select_convs(1) weak_lens.create_get)
  apply (metis select_convs(1) select_convs(2) weak_lens.put_get)
done

text \<open>Consequently, if composition of two lenses $X$ and $Y$ yields @{text "1\<^sub>L"}, then both
  of the composed lenses must be bijective.\<close>

lemma bij_lens_via_comp_id_left:
  "\<lbrakk> wb_lens X; wb_lens Y; X ;\<^sub>L Y = 1\<^sub>L \<rbrakk> \<Longrightarrow> bij_lens X"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
  apply (unfold_locales)
   apply (simp_all)
   using vwb_lens_wb wb_lens_weak weak_lens.put_get apply fastforce
  apply (metis select_convs(1) select_convs(2) wb_lens_weak weak_lens.put_get)
done

lemma bij_lens_via_comp_id_right:
  "\<lbrakk> wb_lens X; wb_lens Y; X ;\<^sub>L Y = 1\<^sub>L \<rbrakk> \<Longrightarrow> bij_lens Y"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
  apply (unfold_locales)
   apply (simp_all)
   using vwb_lens_wb wb_lens_weak weak_lens.put_get apply fastforce
  apply (metis select_convs(1) select_convs(2) wb_lens_weak weak_lens.put_get)
done

text \<open>Importantly, an equivalence between two lenses can be demonstrated by showing that one lens
  can be converted to the other by application of a suitable bijective lens $Z$. This $Z$ lens
  converts the view type of one to the view type of the other.\<close>

lemma lens_equiv_via_bij:
  assumes "bij_lens Z" "X = Z ;\<^sub>L Y"
  shows "X \<approx>\<^sub>L Y"
  using assms
  apply (auto simp add: lens_equiv_def sublens_def)
   using bij_lens_vwb apply blast
  apply (rule_tac x="lens_inv Z" in exI)
  apply (auto simp add: lens_comp_assoc bij_lens_inv_left)
   using bij_lens_vwb lens_inv_bij apply blast
done

text \<open>Indeed, we actually have a stronger result than this -- the equivalent lenses are precisely
  those than can be converted to one another through a suitable bijective lens. Bijective lenses
  can thus be seen as a special class of "adapter" lens.\<close>

lemma lens_equiv_iff_bij:
  assumes "weak_lens Y"
  shows "X \<approx>\<^sub>L Y \<longleftrightarrow> (\<exists> Z. bij_lens Z \<and> X = Z ;\<^sub>L Y)"
  apply (rule iffI)
   apply (auto simp add: lens_equiv_def sublens_def lens_id_unique)[1]
   apply (rename_tac Z\<^sub>1 Z\<^sub>2)
   apply (rule_tac x="Z\<^sub>1" in exI)
   apply (simp)
   apply (subgoal_tac "Z\<^sub>2 ;\<^sub>L Z\<^sub>1 = 1\<^sub>L")
    apply (meson bij_lens_via_comp_id_right vwb_lens_wb)
   apply (metis assms lens_comp_assoc lens_id_unique)
  using lens_equiv_via_bij apply blast
done

lemma pbij_plus_commute:
  "\<lbrakk> a \<bowtie> b; mwb_lens a; mwb_lens b; pbij_lens (b +\<^sub>L a) \<rbrakk> \<Longrightarrow> pbij_lens (a +\<^sub>L b)"
  apply (unfold_locales, simp_all add:lens_defs lens_indep_sym prod.case_eq_if)
  using lens_indep.lens_put_comm pbij_lens.put_det apply fastforce
  done

subsection \<open>Lens Override Laws\<close>

text \<open>The following laws are analogus to the equivalent laws for functions.\<close>

lemma lens_override_id [simp]:
  "S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on 1\<^sub>L = S\<^sub>2"
  by (simp add: lens_override_def id_lens_def)

lemma lens_override_unit [simp]:
  "S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on 0\<^sub>L = S\<^sub>1"
  by (simp add: lens_override_def zero_lens_def)

lemma lens_override_overshadow:
  assumes "mwb_lens Y"  "X \<subseteq>\<^sub>L Y"
  shows "(S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X) \<oplus>\<^sub>L S\<^sub>3 on Y = S\<^sub>1 \<oplus>\<^sub>L S\<^sub>3 on Y"
  using assms by (simp add: lens_override_def sublens_put_put)

lemma lens_override_irr:
  assumes "X \<bowtie> Y"
  shows "S\<^sub>1 \<oplus>\<^sub>L (S\<^sub>2 \<oplus>\<^sub>L S\<^sub>3 on Y) on X = S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X"
  using assms by (simp add: lens_override_def)

lemma lens_override_overshadow_left:
  assumes "mwb_lens X"
  shows "(S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X) \<oplus>\<^sub>L S\<^sub>3 on X = S\<^sub>1 \<oplus>\<^sub>L S\<^sub>3 on X"
  by (simp add: assms lens_override_def)

lemma lens_override_overshadow_right:
  assumes "mwb_lens X"
  shows "S\<^sub>1 \<oplus>\<^sub>L (S\<^sub>2  \<oplus>\<^sub>L S\<^sub>3 on X) on X = S\<^sub>1 \<oplus>\<^sub>L S\<^sub>3 on X"
  by (simp add: assms lens_override_def)

lemma lens_override_plus:
  "X \<bowtie> Y \<Longrightarrow> S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on (X +\<^sub>L Y) = (S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X) \<oplus>\<^sub>L S\<^sub>2 on Y"
  by (simp add: lens_indep_comm lens_override_def lens_plus_def)

lemma lens_override_idem [simp]:
  "vwb_lens X \<Longrightarrow> S \<oplus>\<^sub>L S on X = S"
  by (simp add: lens_override_def)

lemma lens_override_mwb_idem [simp]:
  "\<lbrakk> mwb_lens X; S \<in> \<S>\<^bsub>X\<^esub> \<rbrakk> \<Longrightarrow> S \<oplus>\<^sub>L S on X = S"
  by (simp add: lens_override_def)

lemma lens_override_put_right_in:
  "\<lbrakk> vwb_lens A; X \<subseteq>\<^sub>L A \<rbrakk> \<Longrightarrow> S\<^sub>1 \<oplus>\<^sub>L (put\<^bsub>X\<^esub> S\<^sub>2 v) on A = put\<^bsub>X\<^esub> (S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on A) v"
  by (simp add: lens_override_def lens_get_put_quasi_commute lens_put_of_quotient)

lemma lens_override_put_right_out:
  "\<lbrakk> vwb_lens A; X \<bowtie> A \<rbrakk> \<Longrightarrow> S\<^sub>1 \<oplus>\<^sub>L (put\<^bsub>X\<^esub> S\<^sub>2 v) on A = (S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on A)"
  by (simp add: lens_override_def  lens_indep.lens_put_irr2)

lemma lens_indep_overrideI:
  assumes "vwb_lens X" "vwb_lens Y" "(\<And> s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X \<oplus>\<^sub>L s\<^sub>3 on Y = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>3 on Y \<oplus>\<^sub>L s\<^sub>2 on X)"
  shows "X \<bowtie> Y"
  using assms
  apply (unfold_locales)
  apply (simp_all add: lens_override_def)
  apply (metis mwb_lens_def vwb_lens_mwb weak_lens.put_get)
  apply (metis lens_override_def lens_override_idem mwb_lens_def vwb_lens_mwb weak_lens.put_get)
  apply (metis mwb_lens_weak vwb_lens_mwb vwb_lens_wb wb_lens.get_put weak_lens.put_get)
  done

lemma lens_indep_override_def:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X \<bowtie> Y \<longleftrightarrow> (\<forall> s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X \<oplus>\<^sub>L s\<^sub>3 on Y = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>3 on Y \<oplus>\<^sub>L s\<^sub>2 on X)"
  by (metis assms(1) assms(2) lens_indep_comm lens_indep_overrideI lens_override_def)

text \<open> Alternative characterisation of very-well behaved lenses: override is idempotent. \<close>

lemma override_idem_implies_vwb:
  "\<lbrakk> mwb_lens X; \<And> s. s \<oplus>\<^sub>L s on X = s \<rbrakk> \<Longrightarrow> vwb_lens X"
  by (unfold_locales, simp_all add: lens_defs)

subsection \<open> Alternative Sublens Characterisation \<close>

text \<open> The following definition is equivalent to the above when the two lenses are very well behaved. \<close>

definition sublens' :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> bool" (infix "\<subseteq>\<^sub>L''" 55) where
[lens_defs]: "sublens' X Y = (\<forall> s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on Y \<oplus>\<^sub>L s\<^sub>3 on X = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 \<oplus>\<^sub>L s\<^sub>3 on X on Y)"

text \<open> We next prove some characteristic properties of our alternative definition of sublens. \<close>

lemma sublens'_prop1:
  assumes "vwb_lens X" "X \<subseteq>\<^sub>L' Y"
  shows "put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> s\<^sub>1 (get\<^bsub>Y\<^esub> s\<^sub>2)) s\<^sub>3 = put\<^bsub>Y\<^esub> s\<^sub>1 (get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> s\<^sub>2 s\<^sub>3))"
  using assms
  by (simp add: sublens'_def, metis lens_override_def mwb_lens_def vwb_lens_mwb weak_lens.put_get)

lemma sublens'_prop2:
  assumes "vwb_lens X" "X \<subseteq>\<^sub>L' Y"
  shows "get\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> s\<^sub>1 (get\<^bsub>Y\<^esub> s\<^sub>2)) = get\<^bsub>X\<^esub> s\<^sub>2"
  using assms unfolding sublens'_def
  by (metis lens_override_def vwb_lens_wb wb_lens_axioms_def wb_lens_def weak_lens.put_get)

lemma sublens'_prop3:
  assumes "vwb_lens X" "vwb_lens Y" "X \<subseteq>\<^sub>L' Y"
  shows "put\<^bsub>Y\<^esub> \<sigma> (get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \<rho> (get\<^bsub>Y\<^esub> \<sigma>)) v)) = put\<^bsub>X\<^esub> \<sigma> v"
  by (metis assms(1) assms(2) assms(3) mwb_lens_def sublens'_prop1 vwb_lens.put_eq vwb_lens_mwb weak_lens.put_get)

text \<open> Finally we show our two definitions of sublens are equivalent, assuming very well behaved lenses. \<close>

lemma sublens'_implies_sublens:
  assumes "vwb_lens X" "vwb_lens Y" "X \<subseteq>\<^sub>L' Y"
  shows "X \<subseteq>\<^sub>L Y"
proof -
  have "vwb_lens (X /\<^sub>L Y)"
    by (unfold_locales
       ,auto simp add: assms lens_quotient_def lens_comp_def lens_create_def sublens'_prop1 sublens'_prop2)
  moreover have "X = X /\<^sub>L Y ;\<^sub>L Y"
  proof -
    have "get\<^bsub>X\<^esub> = (\<lambda>\<sigma>. get\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \<sigma>)) \<circ> get\<^bsub>Y\<^esub>"
      by (rule ext, simp add: assms(1) assms(3) lens_create_def sublens'_prop2)
    moreover have "put\<^bsub>X\<^esub> = (\<lambda>\<sigma> v. put\<^bsub>Y\<^esub> \<sigma> (get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> (get\<^bsub>Y\<^esub> \<sigma>)) v)))"
      by (rule ext, rule ext, simp add: assms(1) assms(2) assms(3) lens_create_def sublens'_prop3)
    ultimately show ?thesis
      by (simp add: lens_quotient_def lens_comp_def)
  qed
  ultimately show ?thesis
    using sublens_def by blast
qed

lemma sublens_implies_sublens':
  assumes "vwb_lens Y" "X \<subseteq>\<^sub>L Y"
  shows "X \<subseteq>\<^sub>L' Y"
  by (metis assms lens_override_def lens_override_put_right_in sublens'_def)

lemma sublens_iff_sublens':
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X \<subseteq>\<^sub>L Y \<longleftrightarrow> X \<subseteq>\<^sub>L' Y"
  using assms sublens'_implies_sublens sublens_implies_sublens' by blast

subsection \<open> Alternative Equivalence Characterisation \<close>

definition lens_equiv' :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> bool" (infix "\<approx>\<^sub>L''" 51) where
[lens_defs]: "lens_equiv' X Y = (\<forall> s\<^sub>1 s\<^sub>2. (s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on Y))"

lemma lens_equiv_iff_lens_equiv':
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X \<approx>\<^sub>L Y \<longleftrightarrow> X \<approx>\<^sub>L' Y"
  apply (simp add: lens_equiv_def sublens_iff_sublens' assms)
  apply (auto simp add: lens_defs assms)
  apply (metis assms(2) mwb_lens.put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put)
  done

end


theory WiseMenPuzzle imports HOMML Relations                 (* By Christoph Benzmüller, 2018 *)
begin
  consts a::"\<alpha>" b::"\<alpha>" c::"\<alpha>"  (*Wise men modeled as accessibility relations.*)
 (*Reflexivity, transitivity and euclideaness is postulated for these relations.*)
  axiomatization where
   knowl_abc: "(x = a \<or> x = b \<or> x = c) \<Longrightarrow> (reflexive x \<and> transitive x \<and> euclidean x)"
 (*Eabc \<phi> stands for "Everyone in group {a,b,c} knows \<phi>".*)
  definition Eabc where "Eabc \<equiv> union_rel (union_rel a b) c"
 (*Cabc \<phi> stands for "The common knowledge of group {a,b,c}".*)
  definition Cabc :: "i\<Rightarrow>i\<Rightarrow>bool" where "Cabc \<equiv> tc Eabc"
 (*Cabc is reflexive, transitive and euclidean; i.e. it is a knowledge operator.*)
  lemma refl_Cabc: "reflexive Cabc" using Cabc_def Eabc_def knowl_abc Defs tc_def by smt
  lemma symm_C_abc: "symmetric Cabc" using Cabc_def Eabc_def knowl_abc symm_tc Defs by smt
  lemma eucl_Cabc: "euclidean Cabc" using Cabc_def Eabc_def knowl_abc symm_C_abc Defs tc_def by smt
 (*We are now ready to model and automate the wise men puzzle.*)
  consts ws :: "\<alpha>\<Rightarrow>\<sigma>" (*ws a: a has a white spot.*) wise :: "\<alpha>\<Rightarrow>bool" (*wise a: a is a wise man.*)
  axiomatization where
   A0: "wise a \<and> wise b \<and> wise c" (*a, b and c are wise men.*) and
   (*Common knowledge: at least one of a, b and c has a white spot *)
   A1: "\<lfloor>\<^bold>\<box>Cabc (ws a \<^bold>\<or> ws b \<^bold>\<or> ws c)\<rfloor>" and
   (*Common knowledge: if x has a white spot then y can see this (and hence know this).*)
   A2: "wise x \<and> wise y \<and> x \<noteq> y \<Longrightarrow> \<lfloor>\<^bold>\<box>Cabc (ws x \<^bold>\<rightarrow> \<^bold>\<box>y (ws x))\<rfloor>" and
   (*Common knowledge: if x not has a white spot then y can see this (hence know this) *)
   A3: "wise x \<and> wise y \<and> x \<noteq> y \<Longrightarrow> \<lfloor>\<^bold>\<box>Cabc (\<^bold>\<not>(ws x) \<^bold>\<rightarrow> \<^bold>\<box>y (\<^bold>\<not>(ws x)))\<rfloor>" and
   (*Common knowledge: a does not know whether he has a white spot.*)
   A4: "\<lfloor>(\<^bold>\<box>Cabc (\<^bold>\<not>(\<^bold>\<box>a (ws a))))\<rfloor>"  and
   (*Common knowledge: b does not know whether he has a white spot.*)
   A5: "\<lfloor>(\<^bold>\<box>Cabc \<^bold>\<not>(\<^bold>\<box>b (ws b)))\<rfloor>"
  theorem  (*c knows he has a white spot.*)
   T1: "\<lfloor>(\<^bold>\<box>c (ws c))\<rfloor>" using A0 A1 A3 A4 A5 refl_Cabc unfolding Defs sledgehammer()
    by metis
lemma True nitpick [satisfy,user_axioms,expect=genuine,show_all] oops (*Consistency confirmed*)
end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Continuity\<close>

theory OrdinalCont
imports OrdinalInduct
begin

subsection \<open>Continuous functions\<close>

locale continuous =
  fixes F :: "ordinal \<Rightarrow> ordinal"
  assumes cont: "F (oLimit f) = oLimit (\<lambda>n. F (f n))"

lemmas continuousD = continuous.cont

lemma (in continuous) mono: "mono F"
 apply (rule monoI)
 apply (cut_tac f="case_nat x (\<lambda>n. y)" in cont)
 apply (subgoal_tac "\<forall>x y. oLimit (case_nat x (\<lambda>n. y)) = max x y")
  apply (subgoal_tac "\<forall>x y n. F (case n of 0 \<Rightarrow> x | Suc n \<Rightarrow> y)
                          = (case n of 0 \<Rightarrow> F x | Suc n \<Rightarrow> F y)")
   apply (simp add: max_def)
   apply (erule ssubst, simp)
  apply (simp split: nat.split)
 apply (clarify, rule order_antisym)
  apply (rule oLimit_leI)
  apply (simp split: nat.split add: max.cobounded1 max.cobounded2)
 apply (simp, safe)
  apply (rule_tac n=0 in le_oLimitI, simp)
 apply (rule_tac n=1 in le_oLimitI, simp)
done

lemma (in continuous) monoD: "x \<le> y \<Longrightarrow> F x \<le> F y"
by (erule monoD[OF mono])

lemma continuousI:
assumes lim: "\<And>f. strict_mono f \<Longrightarrow> F (oLimit f) = oLimit (\<lambda>n. F (f n))"
assumes suc: "\<And>x. F x \<le> F (oSuc x)"
shows "continuous F"
 apply (subgoal_tac "mono F")
  apply (rule continuous.intro)
  apply (case_tac "\<forall>n. f n < oLimit f")
   apply (subgoal_tac "oLimit (\<lambda>n. f (make_mono f n)) = oLimit f")
    apply (erule subst)
    apply (rule trans[OF lim])
     apply (erule strict_mono_f_make_mono)
    apply (rule oLimit_eqI)
     apply (rule exI, rule order_refl)
   apply (rule_tac x=n in exI)
    apply (erule monoD)
    apply (rule le_f_make_mono, assumption)
    apply (induct_tac n, simp)
    apply (simp add: Suc_le_eq)
    apply (erule order_le_less_trans)
    apply (erule make_mono_less)
   apply (erule oLimit_make_mono_eq)
  apply (clarsimp simp add: linorder_not_less)
  apply (drule order_antisym[OF _ le_oLimit], simp)
  apply (rule order_antisym[OF le_oLimit])
  apply (rule oLimit_leI[rule_format])
  apply (erule monoD)
  apply (erule subst)
  apply (rule le_oLimit)
 apply (subgoal_tac "\<forall>y x. x \<le> y \<longrightarrow> F x \<le> F y")
  apply (rule monoI, simp)
 apply (rule allI, rule_tac a=y in oLimit_induct)
   apply simp
  apply (clarsimp, erule le_oSucE)
   apply (drule spec, drule mp, assumption)
   apply (erule order_trans, rule suc)
  apply simp
 apply (clarsimp simp add: lim, erule le_oLimitE)
  apply (drule_tac x=n in spec)
  apply (drule_tac x=x in  spec, drule mp, assumption)
  apply (erule order_trans)
  apply (rule le_oLimit)
 apply (simp add: lim)
done

subsection \<open>Normal functions\<close>

locale normal = continuous +
  assumes strict: "strict_mono F"

lemma (in normal) mono: "mono F"
by (rule mono)

lemma (in normal) continuous: "continuous F"
by (rule continuous.intro, rule cont)

lemma (in normal) monoD: "x \<le> y \<Longrightarrow> F x \<le> F y"
by (rule monoD)

lemma (in normal) strict_monoD: "x < y \<Longrightarrow> F x < F y"
by (erule strict_monoD[OF strict])

lemma (in normal) cancel_eq: "(F x = F y) = (x = y)"
by (rule strict_mono_cancel_eq[OF strict])

lemma (in normal) cancel_less: "(F x < F y) = (x < y)"
by (rule strict_mono_cancel_less[OF strict])

lemma (in normal) cancel_le: "(F x \<le> F y) = (x \<le> y)"
by (rule strict_mono_cancel_le[OF strict])

lemma (in normal) oLimit: "F (oLimit f) = oLimit (\<lambda>n. F (f n))"
by (rule cont)

lemma (in normal) increasing: "x \<le> F x"
 apply (rule_tac a=x in oLimit_induct)
   apply simp
  apply (rule oSuc_leI)
  apply (erule order_le_less_trans)
  apply (rule strict_monoD[OF less_oSuc])
 apply (simp add: oLimit)
 apply (rule oLimit_leI, clarify)
 apply (rule order_trans, erule spec)
 apply (rule le_oLimit)
done

lemma normalI:
assumes lim: "\<And>f. strict_mono f \<Longrightarrow> F (oLimit f) = oLimit (\<lambda>n. F (f n))"
assumes suc: "\<And>x. F x < F (oSuc x)"
shows "normal F"
 apply (rule normal.intro[OF _ normal_axioms.intro])
  apply (simp add: continuousI order_less_imp_le suc lim)
 apply (subgoal_tac "\<forall>y x. x < y \<longrightarrow> F x < F y")
  apply (rule strict_monoI, simp)
 apply (rule allI, rule_tac a=y in oLimit_induct)
   apply simp
  apply (clarsimp, erule less_oSucE)
   apply (drule spec, drule mp, assumption)
   apply (erule order_less_trans, rule suc)
  apply (simp add: suc)
 apply (clarsimp simp add: lim, erule less_oLimitE)
 apply (drule spec, drule spec, drule mp, assumption)
 apply (erule order_less_le_trans)
 apply (rule le_oLimit)
done

lemma normal_range_le:
"\<lbrakk>normal F; normal G; range G \<subseteq> range F\<rbrakk> \<Longrightarrow> F x \<le> G x"
 apply (rule_tac a=x in oLimit_induct)
   apply (subgoal_tac "G 0 \<in> range F")
    apply (clarsimp simp add: normal.cancel_le)
   apply (erule subsetD, rule rangeI)
  apply (subgoal_tac "G (oSuc x) \<in> range F")
   apply (clarsimp simp add: normal.cancel_le)
   apply (rename_tac y)
   apply (rule oSuc_leI)
   apply (subgoal_tac "F x < F y", simp add: normal.cancel_less)
   apply (erule order_le_less_trans)
   apply (erule subst)
   apply (simp add: normal.cancel_less)
  apply (erule subsetD, rule rangeI)
 apply (simp only: normal.oLimit)
 apply (rule oLimit_leI[rule_format])
 apply (rule_tac n=n in le_oLimitI)
 apply (erule spec)
done

lemma normal_range_eq:
"\<lbrakk>normal F; normal G; range F = range G\<rbrakk> \<Longrightarrow> F = G"
 apply (rule ext, rule order_antisym)
  apply (simp add: normal_range_le)
 apply (simp add: normal_range_le)
done

end