(*
  Theory: Density_Predicates.thy
  Authors: Manuel Eberl
*)

header {* Density Predicates *}

theory Density_Predicates
imports Probability PDF_Misc
begin

subsection {* Probability Densities *}

definition is_subprob_density :: "'a measure \<Rightarrow> ('a \<Rightarrow> ereal) \<Rightarrow> bool" where
  "is_subprob_density M f \<equiv> (f \<in> borel_measurable M) \<and> space M \<noteq> {} \<and>
                           (\<forall>x\<in>space M. f x \<ge> 0) \<and> (\<integral>\<^sup>+x. f x \<partial>M) \<le> 1"

lemma is_subprob_densityI[intro]:
    "\<lbrakk>f \<in> borel_measurable M; \<And>x. x \<in> space M \<Longrightarrow> f x \<ge> 0; space M \<noteq> {}; (\<integral>\<^sup>+x. f x \<partial>M) \<le> 1\<rbrakk>
        \<Longrightarrow> is_subprob_density M f"
  unfolding is_subprob_density_def by simp

subsection {* Measure spaces with densities *}

definition has_density :: "'a measure \<Rightarrow> 'a measure \<Rightarrow> ('a \<Rightarrow> ereal) \<Rightarrow> bool" where
  "has_density M N f \<longleftrightarrow> (f \<in> borel_measurable N) \<and> (\<forall>x\<in>space N. f x \<ge> 0) \<and>
                         space N \<noteq> {} \<and> M = density N f"

lemma has_densityI[intro]:
  "\<lbrakk>f \<in> borel_measurable N; \<And>x. x \<in> space N \<Longrightarrow> f x \<ge> 0; M = density N f; space N \<noteq> {}\<rbrakk>
      \<Longrightarrow> has_density M N f"
  unfolding has_density_def by blast

lemma has_densityD:
  assumes "has_density M N f"
  shows "f \<in> borel_measurable N" "\<And>x. x \<in> space N \<Longrightarrow> f x \<ge> 0" "M = density N f" "space N \<noteq> {}"
using assms unfolding has_density_def by simp_all

lemma has_density_sets: "has_density M N f \<Longrightarrow> sets M = sets N"
  unfolding has_density_def by simp

lemma has_density_space: "has_density M N f \<Longrightarrow> space M = space N"
  unfolding has_density_def by simp

lemma has_density_emeasure:
    "has_density M N f \<Longrightarrow> X \<in> sets M \<Longrightarrow> emeasure M X = \<integral>\<^sup>+x. f x * indicator X x \<partial>N"
  unfolding has_density_def by (simp_all add: emeasure_density)

lemma has_density_emeasure_space:
    "has_density M N f \<Longrightarrow> emeasure M (space M) = \<integral>\<^sup>+x. f x \<partial>N"
  by (simp add: has_density_emeasure) (simp add: has_density_space nn_integral_over_space)

lemma has_density_emeasure_space':
    "has_density M N f \<Longrightarrow> emeasure (density N f) (space (density N f)) = \<integral>\<^sup>+x. f x \<partial>N"
  by (frule has_densityD(3)[symmetric]) (simp add: has_density_emeasure_space)

lemma has_density_imp_is_subprob_density:
    "\<lbrakk>has_density M N f; (\<integral>\<^sup>+x. f x \<partial>N) = 1\<rbrakk> \<Longrightarrow> is_subprob_density N f"
  by (auto dest: has_densityD)

lemma has_density_imp_is_subprob_density':
    "\<lbrakk>has_density M N f; prob_space M\<rbrakk> \<Longrightarrow> is_subprob_density N f"
  by (auto intro!: has_density_imp_is_subprob_density dest: prob_space.emeasure_space_1
           simp: has_density_emeasure_space)

lemma has_density_equal_on_space:
  assumes "has_density M N f" "\<And>x. x \<in> space N \<Longrightarrow> f x = g x"
  shows "has_density M N g"
proof
  from assms(1) and assms(2)[symmetric] show "\<And>x. x \<in> space N \<Longrightarrow> g x \<ge> 0"
    by (auto dest: has_densityD)
  from assms show "g \<in> borel_measurable N"
    by (subst measurable_cong[of _ _ f]) (auto dest: has_densityD)
  with assms show "M = density N g"
    by (subst density_cong[of _ _ f]) (auto dest: has_densityD)
  from assms(1) show "space N \<noteq> {}" by (rule has_densityD)
qed

lemma has_density_cong:
  assumes "\<And>x. x \<in> space N \<Longrightarrow> f x = g x"
  shows "has_density M N f = has_density M N g"
using assms by (intro iffI) (erule has_density_equal_on_space, simp)+

lemma has_density_dens_AE:
    "\<lbrakk>AE y in N. f y = f' y; f' \<in> borel_measurable N;
      \<And>x. x \<in> space M \<Longrightarrow> f' x \<ge> 0; has_density M N f\<rbrakk>
        \<Longrightarrow> has_density M N f'"
  unfolding has_density_def by (simp cong: density_cong)

subsection {* Probability spaces with densities *}

lemma is_subprob_density_imp_has_density:
    "\<lbrakk>is_subprob_density N f; M = density N f\<rbrakk> \<Longrightarrow> has_density M N f"
  by (rule has_densityI) auto

lemma has_subprob_density_imp_subprob_space':
    "\<lbrakk>has_density M N f; is_subprob_density N f\<rbrakk> \<Longrightarrow> subprob_space M"
proof (rule subprob_spaceI)
  assume "has_density M N f"
  hence "M = density N f" by (simp add: has_density_def)
  also from `has_density M N f` have "space ... \<noteq> {}" by (simp add: has_density_def)
  finally show "space M \<noteq> {}" .
qed (auto simp add: has_density_emeasure_space dest: has_densityD)

lemma has_subprob_density_imp_subprob_space[dest]:
    "is_subprob_density M f \<Longrightarrow> subprob_space (density M f)"
  by (rule has_subprob_density_imp_subprob_space') auto

definition "has_subprob_density M N f \<equiv> has_density M N f \<and> subprob_space M"

(* TODO: Move *)
lemma subprob_space_density_not_empty: "subprob_space (density M f) \<Longrightarrow> space M \<noteq> {}"
  by (subst space_density[symmetric], subst subprob_space.subprob_not_empty, assumption) simp

lemma has_subprob_densityI':
  assumes "f \<in> borel_measurable N" "\<And>x. x \<in> space N \<Longrightarrow> f x \<ge> 0" "space N \<noteq> {}"
          "M = density N f" "(\<integral>\<^sup>+x. f x \<partial>N) \<le> 1"
  shows "has_subprob_density M N f"
proof-
  from assms have D: "has_density M N f" by blast
  moreover from D and assms have "subprob_space M"
    by (auto intro!: subprob_spaceI simp: has_density_emeasure_space emeasure_density_space)
  ultimately show ?thesis unfolding has_subprob_density_def by simp
qed

lemma has_subprob_densityD:
  assumes "has_subprob_density M N f"
  shows "f \<in> borel_measurable N" "\<And>x. x \<in> space N \<Longrightarrow> f x \<ge> 0" "M = density N f" "subprob_space M"
using assms unfolding has_subprob_density_def by (auto dest: has_densityD)

lemma has_subprob_density_imp_has_density:
  "has_subprob_density M N f \<Longrightarrow> has_density M N f" by (simp add: has_subprob_density_def)

lemma has_subprob_density_equal_on_space:
  assumes "has_subprob_density M N f" "\<And>x. x \<in> space N \<Longrightarrow> f x = g x"
  shows "has_subprob_density M N g"
using assms unfolding has_subprob_density_def by (auto dest: has_density_equal_on_space)

lemma has_subprob_density_cong:
  assumes "\<And>x. x \<in> space N \<Longrightarrow> f x = g x"
  shows "has_subprob_density M N f = has_subprob_density M N g"
using assms by (intro iffI) (erule has_subprob_density_equal_on_space, simp)+

lemma has_subprob_density_dens_AE:
    "\<lbrakk>AE y in N. f y = f' y; f' \<in> borel_measurable N;
      \<And>x. x \<in> space M \<Longrightarrow> f' x \<ge> 0; has_subprob_density M N f\<rbrakk>
      \<Longrightarrow> has_subprob_density M N f'"
  unfolding has_subprob_density_def by (simp add: has_density_dens_AE)

subsection {* Parametrized probability densities *}

definition
  "has_parametrized_subprob_density M N R f \<equiv>
       (\<forall>x \<in> space M. has_subprob_density (N x) R (f x)) \<and> split f \<in> borel_measurable (M \<Otimes>\<^sub>M R)"

lemma has_parametrized_subprob_densityI:
  assumes "\<And>x. x \<in> space M \<Longrightarrow> N x = density R (f x)"
  assumes "\<And>x y. x \<in> space M \<Longrightarrow> y \<in> space R \<Longrightarrow> f x y \<ge> 0"
  assumes "\<And>x. x \<in> space M \<Longrightarrow> subprob_space (N x)"
  assumes "split f \<in> borel_measurable (M \<Otimes>\<^sub>M R)"
  shows "has_parametrized_subprob_density M N R f"
  unfolding has_parametrized_subprob_density_def using assms
  by (intro ballI conjI has_subprob_densityI) simp_all

lemma has_parametrized_subprob_densityD:
  assumes "has_parametrized_subprob_density M N R f"
  shows "\<And>x. x \<in> space M \<Longrightarrow> N x = density R (f x)"
    and "\<And>x y. x \<in> space M \<Longrightarrow> y \<in> space R \<Longrightarrow> f x y \<ge> 0"
    and "\<And>x. x \<in> space M \<Longrightarrow> subprob_space (N x)"
    and "split f \<in> borel_measurable (M \<Otimes>\<^sub>M R)"
  using assms unfolding has_parametrized_subprob_density_def
  by (auto dest: has_subprob_densityD)

lemma has_parametrized_subprob_density_integral:
  assumes "has_parametrized_subprob_density M N R f" "x \<in> space M"
  shows "(\<integral>\<^sup>+y. f x y \<partial>R) \<le> 1"
proof-
  have "(\<integral>\<^sup>+y. f x y \<partial>R) = emeasure (density R (f x)) (space (density R (f x)))" using assms
    by (auto simp: emeasure_density_space dest: has_parametrized_subprob_densityD)
  also have "density R (f x) = (N x)" using assms by (auto dest: has_parametrized_subprob_densityD)
  also have "emeasure ... (space ...) \<le> 1" using assms
    by (subst subprob_space.emeasure_space_le_1) (auto dest: has_parametrized_subprob_densityD)
  finally show ?thesis .
qed

lemma has_parametrized_subprob_density_cong:
  assumes "\<And>x. x \<in> space M \<Longrightarrow> N x = N' x"
  shows "has_parametrized_subprob_density M N R f = has_parametrized_subprob_density M N' R f"
using assms unfolding has_parametrized_subprob_density_def by auto

lemma has_parametrized_subprob_density_dens_AE:
  assumes "\<And>x. x \<in> space M \<Longrightarrow> AE y in R. f x y = f' x y"
          "split f' \<in> borel_measurable (M \<Otimes>\<^sub>M R)"
          "\<And>x y. x \<in> space M \<Longrightarrow> y \<in> space R \<Longrightarrow> f' x y \<ge> 0"
          "has_parametrized_subprob_density M N R f"
  shows   "has_parametrized_subprob_density M N R f'"
unfolding has_parametrized_subprob_density_def
proof (intro conjI ballI)
  fix x assume x: "x \<in> space M"
  with assms(4) have "space (N x) = space R"
    by (auto dest!: has_parametrized_subprob_densityD(1))
  with assms and x show "has_subprob_density (N x) R (f' x)"
    by (rule_tac has_subprob_density_dens_AE[of "f x"])
       (auto simp: has_parametrized_subprob_density_def)
qed fact

subsection {* Density in the Giry monad *}

lemma emeasure_bind_density:
  assumes "space M \<noteq> {}" "\<And>x. x \<in> space M \<Longrightarrow> has_density (f x) N (g x)"
          "f \<in> measurable M (subprob_algebra N)" "X \<in> sets N"
  shows "emeasure (M \<guillemotright>= f) X = \<integral>\<^sup>+x. \<integral>\<^sup>+y. g x y * indicator X y \<partial>N \<partial>M"
proof-
  from assms have "emeasure (M \<guillemotright>= f) X = \<integral>\<^sup>+x. emeasure (f x) X \<partial>M"
    by (intro emeasure_bind)
  also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. g x y * indicator X y \<partial>N \<partial>M" using assms
    by (intro nn_integral_cong) (simp add: has_density_emeasure sets_kernel)
  finally show ?thesis .
qed

lemma bind_density:
  assumes "sigma_finite_measure M" "sigma_finite_measure N"
          "space M \<noteq> {}" "\<And>x. x \<in> space M \<Longrightarrow> has_density (f x) N (g x)"
          "split g \<in> borel_measurable (M \<Otimes>\<^sub>M N)"
          "f \<in> measurable M (subprob_algebra N)"
  shows "(M \<guillemotright>= f) = density N (\<lambda>y. \<integral>\<^sup>+x. g x y \<partial>M)"
proof (rule measure_eqI)
  interpret sfN: sigma_finite_measure N by fact
  interpret sfNM: pair_sigma_finite N M unfolding pair_sigma_finite_def using assms by simp
  fix X assume "X \<in> sets (M \<guillemotright>= f)"
  with assms have "X \<in> sets N" by auto
  with assms have "emeasure (M \<guillemotright>= f) X = \<integral>\<^sup>+x. \<integral>\<^sup>+y. g x y * indicator X y \<partial>N \<partial>M"
    by (intro emeasure_bind_density) simp_all
  also from `X \<in> sets N` have "... = \<integral>\<^sup>+y. \<integral>\<^sup>+x. g x y * indicator X y \<partial>M \<partial>N"
    by (intro sfNM.Fubini', subst measurable_split_conv, intro borel_measurable_ereal_times,
        subst measurable_split_conv[symmetric], subst measurable_pair_swap_iff, simp add: assms,
        intro measurable_compose[OF measurable_fst borel_measurable_indicator])
  also {
    fix y assume "y \<in> space N"
    have "(\<lambda>x. g x y) = split g \<circ> (\<lambda>x. (x, y))" by (rule ext) simp
    also from `y \<in> space N` have "... \<in> borel_measurable M"
      by (intro measurable_comp[OF _ assms(5)] measurable_Pair2')
    finally have "(\<lambda>x. g x y) \<in> borel_measurable M" .
  }
  hence "... = \<integral>\<^sup>+y. (\<integral>\<^sup>+x. g x y \<partial>M) * indicator X y \<partial>N"
    by (intro nn_integral_cong nn_integral_multc)  simp_all
  also from `X \<in> sets N` and assms have "... = emeasure (density N (\<lambda>y. \<integral>\<^sup>+x. g x y \<partial>M)) X"
    by (subst emeasure_density) (simp_all add: sfN.borel_measurable_nn_integral)
  finally show "emeasure (M \<guillemotright>= f) X = emeasure (density N (\<lambda>y. \<integral>\<^sup>+x. g x y \<partial>M)) X" .
qed (simp add: assms)

lemma bind_has_density:
  assumes "sigma_finite_measure M" "sigma_finite_measure N"
          "space M \<noteq> {}" "\<And>x. x \<in> space M \<Longrightarrow> has_density (f x) N (g x)"
          "split g \<in> borel_measurable (M \<Otimes>\<^sub>M N)"
          "f \<in> measurable M (subprob_algebra N)"
  shows "has_density (M \<guillemotright>= f) N (\<lambda>y. \<integral>\<^sup>+x. g x y \<partial>M)"
proof
  interpret sigma_finite_measure M by fact
  show "(\<lambda>y. \<integral>\<^sup>+ x. g x y \<partial>M) \<in> borel_measurable N" using assms
    by (intro borel_measurable_nn_integral, subst measurable_pair_swap_iff) simp
  show "M \<guillemotright>= f = density N (\<lambda>y. \<integral>\<^sup>+ x. g x y \<partial>M)"
    by (intro bind_density) (simp_all add: assms)
  from `space M \<noteq> {}` obtain x where "x \<in> space M" by blast
  with assms have "has_density (f x) N (g x)" by simp
  thus "space N \<noteq> {}" by (rule has_densityD)
qed (simp add: nn_integral_nonneg)

lemma bind_has_density':
  assumes sfM: "sigma_finite_measure M"
      and sfR: "sigma_finite_measure R"
      and not_empty: "space M \<noteq> {}" and dens_M: "has_density M N \<delta>M"
      and dens_f: "\<And>x. x \<in> space M \<Longrightarrow> has_density (f x) R (\<delta>f x)"
      and M\<delta>f: "split \<delta>f \<in> borel_measurable (N \<Otimes>\<^sub>M R)"
      and Mf: "f \<in> measurable N (subprob_algebra R)"
  shows "has_density (M \<guillemotright>= f) R (\<lambda>y. \<integral>\<^sup>+x. \<delta>M x * \<delta>f x y \<partial>N)"
proof-
  from dens_M have M_M: "measurable M = measurable N"
    by (intro ext measurable_cong_sets) (auto dest: has_densityD)
  from dens_M have M_MR: "measurable (M \<Otimes>\<^sub>M R) = measurable (N \<Otimes>\<^sub>M R)"
    by (intro ext measurable_cong_sets sets_pair_measure_cong) (auto dest: has_densityD)
  have "has_density (M \<guillemotright>= f) R (\<lambda>y. \<integral>\<^sup>+x. \<delta>f x y \<partial>M)"
    by (rule bind_has_density) (auto simp: assms M_MR M_M)
  moreover {
    fix y assume A: "y \<in> space R"
    have "(\<lambda>x. \<delta>f x y) = split \<delta>f \<circ> (\<lambda>x. (x,y))" by (rule ext) (simp add: o_def)
    also have "... \<in> borel_measurable N" by (intro measurable_comp[OF _ M\<delta>f] measurable_Pair2' A)
    finally have M_\<delta>f': "(\<lambda>x. \<delta>f x y) \<in> borel_measurable N" .

    from dens_M have "M = density N \<delta>M" by (auto dest: has_densityD)
    also from dens_M have "(\<integral>\<^sup>+x. \<delta>f x y \<partial>...) = \<integral>\<^sup>+x. \<delta>M x * \<delta>f x y \<partial>N"
      by (subst nn_integral_density) (auto dest: has_densityD simp: M_\<delta>f')
    finally have "(\<integral>\<^sup>+x. \<delta>f x y \<partial>M) = \<integral>\<^sup>+x. \<delta>M x * \<delta>f x y \<partial>N" .
  }
  ultimately show "has_density (M \<guillemotright>= f) R (\<lambda>y. \<integral>\<^sup>+x. \<delta>M x * \<delta>f x y \<partial>N)"
    by (rule has_density_equal_on_space) (simp_all add: nn_integral_nonneg)
qed

lemma bind_has_subprob_density:
  assumes "subprob_space M" "sigma_finite_measure N"
          "space M \<noteq> {}" "\<And>x. x \<in> space M \<Longrightarrow> has_density (f x) N (g x)"
          "split g \<in> borel_measurable (M \<Otimes>\<^sub>M N)"
          "f \<in> measurable M (subprob_algebra N)"
  shows "has_subprob_density (M \<guillemotright>= f) N (\<lambda>y. \<integral>\<^sup>+x. g x y \<partial>M)"
proof (unfold has_subprob_density_def, intro conjI)
  from assms show "has_density (M \<guillemotright>= f) N (\<lambda>y. \<integral>\<^sup>+x. g x y \<partial>M)"
    by (intro bind_has_density) (auto simp: subprob_space_imp_sigma_finite)
  from assms show "subprob_space (M \<guillemotright>= f)" by (intro subprob_space_bind)
qed

lemma bind_has_subprob_density':
  assumes "has_subprob_density M N \<delta>M" "space R \<noteq> {}" "sigma_finite_measure R"
          "\<And>x. x \<in> space M \<Longrightarrow> has_subprob_density (f x) R (\<delta>f x)"
          "split \<delta>f \<in> borel_measurable (N \<Otimes>\<^sub>M R)" "f \<in> measurable N (subprob_algebra R)"
  shows "has_subprob_density (M \<guillemotright>= f) R (\<lambda>y. \<integral>\<^sup>+x. \<delta>M x * \<delta>f x y \<partial>N)"
proof (unfold has_subprob_density_def, intro conjI)
  from assms(1) have "space M \<noteq> {}" by (intro subprob_space.subprob_not_empty has_subprob_densityD)
  with assms show "has_density (M \<guillemotright>= f) R (\<lambda>y. \<integral>\<^sup>+x. \<delta>M x * \<delta>f x y \<partial>N)"
    by (intro bind_has_density' has_densityI)
       (auto simp: subprob_space_imp_sigma_finite dest: has_subprob_densityD)
  from assms show "subprob_space (M \<guillemotright>= f)"
    by (intro subprob_space_bind) (auto dest: has_subprob_densityD)
qed

lemma null_measure_has_subprob_density:
  "space M \<noteq> {} \<Longrightarrow> has_subprob_density (null_measure M) M (\<lambda>_. 0)"
  by (intro has_subprob_densityI)
     (auto intro: null_measure_eq_density simp: subprob_space_null_measure_iff)

lemma emeasure_has_parametrized_subprob_density:
  assumes "has_parametrized_subprob_density M N R f"
  assumes "x \<in> space M" "X \<in> sets R"
  shows "emeasure (N x) X = \<integral>\<^sup>+y. f x y * indicator X y \<partial>R"
proof-
  from has_parametrized_subprob_densityD(4)[OF assms(1)] and assms(2)
    have Mf: "f x \<in> borel_measurable R" by simp
  have "N x = density R (f x)"
    by (rule has_parametrized_subprob_densityD(1)[OF assms(1,2)])
  also from Mf and assms(3) have "emeasure ... X = \<integral>\<^sup>+y. f x y * indicator X y \<partial>R"
    by (rule emeasure_density)
  finally show ?thesis .
qed

lemma emeasure_count_space_density_singleton:
  assumes "x \<in> A" "has_density M (count_space A) f"
  shows "emeasure M {x} = f x"
proof-
  from has_densityD[OF assms(2)] have nonneg: "\<And>x. x \<in> A \<Longrightarrow> f x \<ge> 0" by simp
  from assms have M: "M = density (count_space A) f" by (intro has_densityD)
  from assms have "emeasure M {x} = \<integral>\<^sup>+y. f y * indicator {x} y \<partial>count_space A"
    by (simp add: M emeasure_density)
  also from assms and nonneg have "... = f x"
    apply (subst nn_integral_count_space)
    apply (auto simp: indicator_def) []
    apply (cases "f x > 0")
    apply (auto simp: indicator_def eq_iff)
    done
  finally show ?thesis .
qed

lemma subprob_count_space_density_le_1:
  assumes "has_subprob_density M (count_space A) f" "x \<in> A"
  shows "f x \<le> 1"
proof (cases "f x > 0")
  assume "f x > 0"
  from assms interpret subprob_space M by (intro has_subprob_densityD)
  from assms have M: "M = density (count_space A) f" by (intro has_subprob_densityD)
  from assms have "f x = emeasure M {x}"
    by (intro emeasure_count_space_density_singleton[symmetric])
       (auto simp: has_subprob_density_def)
  also have "... \<le> 1" by (rule subprob_measure_le_1)
  finally show ?thesis .
qed (auto simp: not_less intro: order.trans[of _ 0 1])

end


section \<open> Expectations \<close>

theory utp_expectation
  imports "UTP.utp"
begin

subsection \<open> Probabilities \<close>

typedef prob = "{0..1} :: real set"
  by auto

setup_lifting type_definition_prob

instantiation prob :: "{ord,zero,one,times,uminus}"
begin
  lift_definition less_eq_prob :: "prob \<Rightarrow> prob \<Rightarrow> bool" is "op \<le>" .
  lift_definition less_prob :: "prob \<Rightarrow> prob \<Rightarrow> bool" is "op <" .
  lift_definition zero_prob :: prob is 0 by auto
  lift_definition one_prob :: prob is 1 by auto
  lift_definition times_prob :: "prob \<Rightarrow> prob \<Rightarrow> prob" is "op *"
    by (auto, simp add: mult_le_one)
  lift_definition uminus_prob :: "prob \<Rightarrow> prob" is "\<lambda> p. 1 - p"
    by (auto)
instance ..
end

instance prob :: order
  by (intro_classes, (transfer, auto)+)

instance prob :: comm_monoid_mult
  by (intro_classes, (transfer, auto)+)

lemma "- (- (p :: prob)) = p"
  by (transfer, simp)

subsection \<open> Expectation Type \<close>

type_synonym '\<alpha> uexpt = "(prob, '\<alpha>) uexpr"

definition upred_expt :: "'\<alpha> upred \<Rightarrow> '\<alpha> uexpt" ("[_]\<^sub>P") where
[upred_defs]: "[P]\<^sub>P = 1 \<triangleleft> P \<triangleright> 0"

lemma upred_expt_false: "[false]\<^sub>P = 0"
  by pred_auto

lemma upred_expt_true: "[true]\<^sub>P = 1"
  by pred_auto

end


(*  Title:      HOL/Library/Char_ord.thy
    Author:     Norbert Voelker, Florian Haftmann
*)

section \<open>Order on characters\<close>

theory Char_ord
  imports Main
begin

instantiation char :: linorder
begin

definition less_eq_char :: "char \<Rightarrow> char \<Rightarrow> bool"
  where "c1 \<le> c2 \<longleftrightarrow> of_char c1 \<le> (of_char c2 :: nat)"

definition less_char :: "char \<Rightarrow> char \<Rightarrow> bool"
  where "c1 < c2 \<longleftrightarrow> of_char c1 < (of_char c2 :: nat)"

instance
  by standard (auto simp add: less_eq_char_def less_char_def)

end

lemma less_eq_char_simp [simp]:
  "Char b0 b1 b2 b3 b4 b5 b6 b7 \<le> Char c0 c1 c2 c3 c4 c5 c6 c7
    \<longleftrightarrow> foldr (\<lambda>b k. of_bool b + k * 2) [b0, b1, b2, b3, b4, b5, b6, b7] 0
      \<le> foldr (\<lambda>b k. of_bool b + k * 2) [c0, c1, c2, c3, c4, c5, c6, c7] (0::nat)"
  by (simp add: less_eq_char_def)

lemma less_char_simp [simp]:
  "Char b0 b1 b2 b3 b4 b5 b6 b7 < Char c0 c1 c2 c3 c4 c5 c6 c7
    \<longleftrightarrow> foldr (\<lambda>b k. of_bool b + k * 2) [b0, b1, b2, b3, b4, b5, b6, b7] 0
      < foldr (\<lambda>b k. of_bool b + k * 2) [c0, c1, c2, c3, c4, c5, c6, c7] (0::nat)"
  by (simp add: less_char_def)

instantiation char :: distrib_lattice
begin

definition "(inf :: char \<Rightarrow> _) = min"
definition "(sup :: char \<Rightarrow> _) = max"

instance
  by standard (auto simp add: inf_char_def sup_char_def max_min_distrib2)

end

end


(*  Author:  Gertrud Bauer, Tobias Nipkow  *)

header {* Transitive Closure of Successor List Function *}

theory RTranCl
imports Main
begin

text{* The reflexive transitive closure of a relation induced by a
function of type @{typ"'a \<Rightarrow> 'a list"}. Instead of defining the closure
again it would have been simpler to take @{term"{(x,y) . y \<in> set(f x)}\<^sup>*"}. *}

abbreviation (input)
  in_set :: "'a => ('a => 'b list) => 'b => bool" ("_ [_]\<rightarrow> _" [55,0,55] 50) where
  "g [succs]\<rightarrow> g' == g' \<in> set (succs g)"

inductive_set
  RTranCl :: "('a \<Rightarrow> 'a list) \<Rightarrow> ('a * 'a) set"
  and in_RTranCl :: "'a \<Rightarrow> ('a \<Rightarrow> 'a list) \<Rightarrow> 'a \<Rightarrow> bool"
    ("_ [_]\<rightarrow>* _" [55,0,55] 50)
  for succs :: "'a \<Rightarrow> 'a list"
where
  "g [succs]\<rightarrow>* g' \<equiv> (g,g') \<in> RTranCl succs"
| refl: "g [succs]\<rightarrow>* g"
| succs: "g [succs]\<rightarrow> g' \<Longrightarrow> g' [succs]\<rightarrow>* g'' \<Longrightarrow> g [succs]\<rightarrow>* g''"

inductive_cases RTranCl_elim: "(h,h') : RTranCl succs"

lemma RTranCl_induct(*<*) [induct set: RTranCl, consumes 1, case_names refl succs] (*>*):
 "(h, h') \<in> RTranCl succs \<Longrightarrow>
  P h \<Longrightarrow>
  (\<And>g g'. g' \<in> set (succs g) \<Longrightarrow> P g \<Longrightarrow> P g') \<Longrightarrow>
  P h'"
proof -
  assume s: "\<And>g g'. g' \<in> set (succs g) \<Longrightarrow> P g \<Longrightarrow> P g'"
  assume "(h, h') \<in> RTranCl succs" "P h"
  then show "P h'"
  proof (induct rule: RTranCl.induct)
    fix g assume "P g" then show "P g" .
  next
    fix g g' g''
    assume IH: "P g' \<Longrightarrow> P g''"
    assume "g' \<in> set(succs g)" "P g"
    then have "P g'" by (rule s)
    then show "P g''" by (rule IH)
  qed
qed

definition invariant :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a list) \<Rightarrow> bool" where
"invariant P succs \<equiv> \<forall>g g'. g' \<in> set(succs g) \<longrightarrow> P g \<longrightarrow> P g'"

lemma invariantE:
  "invariant P succs  \<Longrightarrow> g [succs]\<rightarrow> g' \<Longrightarrow> P g \<Longrightarrow> P g'"
by(simp add:invariant_def)

lemma inv_subset:
 "invariant P f \<Longrightarrow> (!!g. P g \<Longrightarrow> set(f' g) \<subseteq> set(f g)) \<Longrightarrow> invariant P f'"
by(auto simp:invariant_def)

lemma RTranCl_inv:
  "invariant P succs \<Longrightarrow> (g,g') \<in> RTranCl succs \<Longrightarrow> P g \<Longrightarrow> P g'"
by (erule RTranCl_induct)(auto simp:invariant_def)

lemma RTranCl_subset2:
assumes a: "(s,g) : RTranCl f"
shows "(!!g. (s,g) \<in> RTranCl f \<Longrightarrow> set(f g) \<subseteq> set(h g)) \<Longrightarrow> (s,g) : RTranCl h"
using a
proof (induct rule: RTranCl.induct)
  case refl show ?case by(rule RTranCl.intros)
next
  case succs thus ?case by(blast intro: RTranCl.intros)
qed

end


(*  Title:      HOL/Lattices.thy
    Author:     Tobias Nipkow
*)

section \<open>Abstract lattices\<close>

theory Lattices
imports Groups
begin

subsection \<open>Abstract semilattice\<close>

text \<open>
  These locales provide a basic structure for interpretation into
  bigger structures;  extensions require careful thinking, otherwise
  undesired effects may occur due to interpretation.
\<close>

locale semilattice = abel_semigroup +
  assumes idem [simp]: "a \<^bold>* a = a"
begin

lemma left_idem [simp]: "a \<^bold>* (a \<^bold>* b) = a \<^bold>* b"
  by (simp add: assoc [symmetric])

lemma right_idem [simp]: "(a \<^bold>* b) \<^bold>* b = a \<^bold>* b"
  by (simp add: assoc)

end

locale semilattice_neutr = semilattice + comm_monoid

locale semilattice_order = semilattice +
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<^bold>\<le>" 50)
    and less :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<^bold><" 50)
  assumes order_iff: "a \<^bold>\<le> b \<longleftrightarrow> a = a \<^bold>* b"
    and strict_order_iff: "a \<^bold>< b \<longleftrightarrow> a = a \<^bold>* b \<and> a \<noteq> b"
begin

lemma orderI: "a = a \<^bold>* b \<Longrightarrow> a \<^bold>\<le> b"
  by (simp add: order_iff)

lemma orderE:
  assumes "a \<^bold>\<le> b"
  obtains "a = a \<^bold>* b"
  using assms by (unfold order_iff)

sublocale ordering less_eq less
proof
  show "a \<^bold>< b \<longleftrightarrow> a \<^bold>\<le> b \<and> a \<noteq> b" for a b
    by (simp add: order_iff strict_order_iff)
next
  show "a \<^bold>\<le> a" for a
    by (simp add: order_iff)
next
  fix a b
  assume "a \<^bold>\<le> b" "b \<^bold>\<le> a"
  then have "a = a \<^bold>* b" "a \<^bold>* b = b"
    by (simp_all add: order_iff commute)
  then show "a = b" by simp
next
  fix a b c
  assume "a \<^bold>\<le> b" "b \<^bold>\<le> c"
  then have "a = a \<^bold>* b" "b = b \<^bold>* c"
    by (simp_all add: order_iff commute)
  then have "a = a \<^bold>* (b \<^bold>* c)"
    by simp
  then have "a = (a \<^bold>* b) \<^bold>* c"
    by (simp add: assoc)
  with \<open>a = a \<^bold>* b\<close> [symmetric] have "a = a \<^bold>* c" by simp
  then show "a \<^bold>\<le> c" by (rule orderI)
qed

lemma cobounded1 [simp]: "a \<^bold>* b \<^bold>\<le> a"
  by (simp add: order_iff commute)

lemma cobounded2 [simp]: "a \<^bold>* b \<^bold>\<le> b"
  by (simp add: order_iff)

lemma boundedI:
  assumes "a \<^bold>\<le> b" and "a \<^bold>\<le> c"
  shows "a \<^bold>\<le> b \<^bold>* c"
proof (rule orderI)
  from assms obtain "a \<^bold>* b = a" and "a \<^bold>* c = a"
    by (auto elim!: orderE)
  then show "a = a \<^bold>* (b \<^bold>* c)"
    by (simp add: assoc [symmetric])
qed

lemma boundedE:
  assumes "a \<^bold>\<le> b \<^bold>* c"
  obtains "a \<^bold>\<le> b" and "a \<^bold>\<le> c"
  using assms by (blast intro: trans cobounded1 cobounded2)

lemma bounded_iff [simp]: "a \<^bold>\<le> b \<^bold>* c \<longleftrightarrow> a \<^bold>\<le> b \<and> a \<^bold>\<le> c"
  by (blast intro: boundedI elim: boundedE)

lemma strict_boundedE:
  assumes "a \<^bold>< b \<^bold>* c"
  obtains "a \<^bold>< b" and "a \<^bold>< c"
  using assms by (auto simp add: commute strict_iff_order elim: orderE intro!: that)+

lemma coboundedI1: "a \<^bold>\<le> c \<Longrightarrow> a \<^bold>* b \<^bold>\<le> c"
  by (rule trans) auto

lemma coboundedI2: "b \<^bold>\<le> c \<Longrightarrow> a \<^bold>* b \<^bold>\<le> c"
  by (rule trans) auto

lemma strict_coboundedI1: "a \<^bold>< c \<Longrightarrow> a \<^bold>* b \<^bold>< c"
  using irrefl
  by (auto intro: not_eq_order_implies_strict coboundedI1 strict_implies_order
      elim: strict_boundedE)

lemma strict_coboundedI2: "b \<^bold>< c \<Longrightarrow> a \<^bold>* b \<^bold>< c"
  using strict_coboundedI1 [of b c a] by (simp add: commute)

lemma mono: "a \<^bold>\<le> c \<Longrightarrow> b \<^bold>\<le> d \<Longrightarrow> a \<^bold>* b \<^bold>\<le> c \<^bold>* d"
  by (blast intro: boundedI coboundedI1 coboundedI2)

lemma absorb1: "a \<^bold>\<le> b \<Longrightarrow> a \<^bold>* b = a"
  by (rule antisym) (auto simp: refl)

lemma absorb2: "b \<^bold>\<le> a \<Longrightarrow> a \<^bold>* b = b"
  by (rule antisym) (auto simp: refl)

lemma absorb3: "a \<^bold>< b \<Longrightarrow> a \<^bold>* b = a"
  by (rule absorb1) (rule strict_implies_order)

lemma absorb4: "b \<^bold>< a \<Longrightarrow> a \<^bold>* b = b"
  by (rule absorb2) (rule strict_implies_order)

lemma absorb_iff1: "a \<^bold>\<le> b \<longleftrightarrow> a \<^bold>* b = a"
  using order_iff by auto

lemma absorb_iff2: "b \<^bold>\<le> a \<longleftrightarrow> a \<^bold>* b = b"
  using order_iff by (auto simp add: commute)

end

locale semilattice_neutr_order = semilattice_neutr + semilattice_order
begin

sublocale ordering_top less_eq less "\<^bold>1"
  by standard (simp add: order_iff)

lemma eq_neutr_iff [simp]: \<open>a \<^bold>* b = \<^bold>1 \<longleftrightarrow> a = \<^bold>1 \<and> b = \<^bold>1\<close>
  by (simp add: eq_iff)

lemma neutr_eq_iff [simp]: \<open>\<^bold>1 = a \<^bold>* b \<longleftrightarrow> a = \<^bold>1 \<and> b = \<^bold>1\<close>
  by (simp add: eq_iff)

end

text \<open>Interpretations for boolean operators\<close>

interpretation conj: semilattice_neutr \<open>(\<and>)\<close> True
  by standard auto

interpretation disj: semilattice_neutr \<open>(\<or>)\<close> False
  by standard auto

declare conj_assoc [ac_simps del] disj_assoc [ac_simps del] \<comment> \<open>already simp by default\<close>

subsection \<open>Syntactic infimum and supremum operations\<close>

class inf =
  fixes inf :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<sqinter>" 70)

class sup =
  fixes sup :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<squnion>" 65)

subsection \<open>Concrete lattices\<close>

class semilattice_inf = order + inf +
  assumes inf_le1 [simp]: "x \<sqinter> y \<le> x"
  and inf_le2 [simp]: "x \<sqinter> y \<le> y"
  and inf_greatest: "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"

class semilattice_sup = order + sup +
  assumes sup_ge1 [simp]: "x \<le> x \<squnion> y"
  and sup_ge2 [simp]: "y \<le> x \<squnion> y"
  and sup_least: "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
begin

text \<open>Dual lattice.\<close>
lemma dual_semilattice: "class.semilattice_inf sup greater_eq greater"
  by (rule class.semilattice_inf.intro, rule dual_order)
    (unfold_locales, simp_all add: sup_least)

end

class lattice = semilattice_inf + semilattice_sup

subsubsection \<open>Intro and elim rules\<close>

context semilattice_inf
begin

lemma le_infI1: "a \<le> x \<Longrightarrow> a \<sqinter> b \<le> x"
  by (rule order_trans) auto

lemma le_infI2: "b \<le> x \<Longrightarrow> a \<sqinter> b \<le> x"
  by (rule order_trans) auto

lemma le_infI: "x \<le> a \<Longrightarrow> x \<le> b \<Longrightarrow> x \<le> a \<sqinter> b"
  by (fact inf_greatest) (* FIXME: duplicate lemma *)

lemma le_infE: "x \<le> a \<sqinter> b \<Longrightarrow> (x \<le> a \<Longrightarrow> x \<le> b \<Longrightarrow> P) \<Longrightarrow> P"
  by (blast intro: order_trans inf_le1 inf_le2)

lemma le_inf_iff: "x \<le> y \<sqinter> z \<longleftrightarrow> x \<le> y \<and> x \<le> z"
  by (blast intro: le_infI elim: le_infE)

lemma le_iff_inf: "x \<le> y \<longleftrightarrow> x \<sqinter> y = x"
  by (auto intro: le_infI1 order.antisym dest: order.eq_iff [THEN iffD1] simp add: le_inf_iff)

lemma inf_mono: "a \<le> c \<Longrightarrow> b \<le> d \<Longrightarrow> a \<sqinter> b \<le> c \<sqinter> d"
  by (fast intro: inf_greatest le_infI1 le_infI2)

end

context semilattice_sup
begin

lemma le_supI1: "x \<le> a \<Longrightarrow> x \<le> a \<squnion> b"
  by (rule order_trans) auto

lemma le_supI2: "x \<le> b \<Longrightarrow> x \<le> a \<squnion> b"
  by (rule order_trans) auto

lemma le_supI: "a \<le> x \<Longrightarrow> b \<le> x \<Longrightarrow> a \<squnion> b \<le> x"
  by (fact sup_least) (* FIXME: duplicate lemma *)

lemma le_supE: "a \<squnion> b \<le> x \<Longrightarrow> (a \<le> x \<Longrightarrow> b \<le> x \<Longrightarrow> P) \<Longrightarrow> P"
  by (blast intro: order_trans sup_ge1 sup_ge2)

lemma le_sup_iff: "x \<squnion> y \<le> z \<longleftrightarrow> x \<le> z \<and> y \<le> z"
  by (blast intro: le_supI elim: le_supE)

lemma le_iff_sup: "x \<le> y \<longleftrightarrow> x \<squnion> y = y"
  by (auto intro: le_supI2 order.antisym dest: order.eq_iff [THEN iffD1] simp add: le_sup_iff)

lemma sup_mono: "a \<le> c \<Longrightarrow> b \<le> d \<Longrightarrow> a \<squnion> b \<le> c \<squnion> d"
  by (fast intro: sup_least le_supI1 le_supI2)

end

subsubsection \<open>Equational laws\<close>

context semilattice_inf
begin

sublocale inf: semilattice inf
proof
  fix a b c
  show "(a \<sqinter> b) \<sqinter> c = a \<sqinter> (b \<sqinter> c)"
    by (rule order.antisym) (auto intro: le_infI1 le_infI2 simp add: le_inf_iff)
  show "a \<sqinter> b = b \<sqinter> a"
    by (rule order.antisym) (auto simp add: le_inf_iff)
  show "a \<sqinter> a = a"
    by (rule order.antisym) (auto simp add: le_inf_iff)
qed

sublocale inf: semilattice_order inf less_eq less
  by standard (auto simp add: le_iff_inf less_le)

lemma inf_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
  by (fact inf.assoc)

lemma inf_commute: "(x \<sqinter> y) = (y \<sqinter> x)"
  by (fact inf.commute)

lemma inf_left_commute: "x \<sqinter> (y \<sqinter> z) = y \<sqinter> (x \<sqinter> z)"
  by (fact inf.left_commute)

lemma inf_idem: "x \<sqinter> x = x"
  by (fact inf.idem) (* already simp *)

lemma inf_left_idem: "x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
  by (fact inf.left_idem) (* already simp *)

lemma inf_right_idem: "(x \<sqinter> y) \<sqinter> y = x \<sqinter> y"
  by (fact inf.right_idem) (* already simp *)

lemma inf_absorb1: "x \<le> y \<Longrightarrow> x \<sqinter> y = x"
  by (rule order.antisym) auto

lemma inf_absorb2: "y \<le> x \<Longrightarrow> x \<sqinter> y = y"
  by (rule order.antisym) auto

lemmas inf_aci = inf_commute inf_assoc inf_left_commute inf_left_idem

end

context semilattice_sup
begin

sublocale sup: semilattice sup
proof
  fix a b c
  show "(a \<squnion> b) \<squnion> c = a \<squnion> (b \<squnion> c)"
    by (rule order.antisym) (auto intro: le_supI1 le_supI2 simp add: le_sup_iff)
  show "a \<squnion> b = b \<squnion> a"
    by (rule order.antisym) (auto simp add: le_sup_iff)
  show "a \<squnion> a = a"
    by (rule order.antisym) (auto simp add: le_sup_iff)
qed

sublocale sup: semilattice_order sup greater_eq greater
  by standard (auto simp add: le_iff_sup sup.commute less_le)

lemma sup_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
  by (fact sup.assoc)

lemma sup_commute: "(x \<squnion> y) = (y \<squnion> x)"
  by (fact sup.commute)

lemma sup_left_commute: "x \<squnion> (y \<squnion> z) = y \<squnion> (x \<squnion> z)"
  by (fact sup.left_commute)

lemma sup_idem: "x \<squnion> x = x"
  by (fact sup.idem) (* already simp *)

lemma sup_left_idem [simp]: "x \<squnion> (x \<squnion> y) = x \<squnion> y"
  by (fact sup.left_idem)

lemma sup_absorb1: "y \<le> x \<Longrightarrow> x \<squnion> y = x"
  by (rule order.antisym) auto

lemma sup_absorb2: "x \<le> y \<Longrightarrow> x \<squnion> y = y"
  by (rule order.antisym) auto

lemmas sup_aci = sup_commute sup_assoc sup_left_commute sup_left_idem

end

context lattice
begin

lemma dual_lattice: "class.lattice sup (\<ge>) (>) inf"
  by (rule class.lattice.intro,
      rule dual_semilattice,
      rule class.semilattice_sup.intro,
      rule dual_order)
    (unfold_locales, auto)

lemma inf_sup_absorb [simp]: "x \<sqinter> (x \<squnion> y) = x"
  by (blast intro: order.antisym inf_le1 inf_greatest sup_ge1)

lemma sup_inf_absorb [simp]: "x \<squnion> (x \<sqinter> y) = x"
  by (blast intro: order.antisym sup_ge1 sup_least inf_le1)

lemmas inf_sup_aci = inf_aci sup_aci

lemmas inf_sup_ord = inf_le1 inf_le2 sup_ge1 sup_ge2

text \<open>Towards distributivity.\<close>

lemma distrib_sup_le: "x \<squnion> (y \<sqinter> z) \<le> (x \<squnion> y) \<sqinter> (x \<squnion> z)"
  by (auto intro: le_infI1 le_infI2 le_supI1 le_supI2)

lemma distrib_inf_le: "(x \<sqinter> y) \<squnion> (x \<sqinter> z) \<le> x \<sqinter> (y \<squnion> z)"
  by (auto intro: le_infI1 le_infI2 le_supI1 le_supI2)

text \<open>If you have one of them, you have them all.\<close>

lemma distrib_imp1:
  assumes distrib: "\<And>x y z. x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
  shows "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
proof-
  have "x \<squnion> (y \<sqinter> z) = (x \<squnion> (x \<sqinter> z)) \<squnion> (y \<sqinter> z)"
    by simp
  also have "\<dots> = x \<squnion> (z \<sqinter> (x \<squnion> y))"
    by (simp add: distrib inf_commute sup_assoc del: sup_inf_absorb)
  also have "\<dots> = ((x \<squnion> y) \<sqinter> x) \<squnion> ((x \<squnion> y) \<sqinter> z)"
    by (simp add: inf_commute)
  also have "\<dots> = (x \<squnion> y) \<sqinter> (x \<squnion> z)" by(simp add:distrib)
  finally show ?thesis .
qed

lemma distrib_imp2:
  assumes distrib: "\<And>x y z. x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
  shows "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
proof-
  have "x \<sqinter> (y \<squnion> z) = (x \<sqinter> (x \<squnion> z)) \<sqinter> (y \<squnion> z)"
    by simp
  also have "\<dots> = x \<sqinter> (z \<squnion> (x \<sqinter> y))"
    by (simp add: distrib sup_commute inf_assoc del: inf_sup_absorb)
  also have "\<dots> = ((x \<sqinter> y) \<squnion> x) \<sqinter> ((x \<sqinter> y) \<squnion> z)"
    by (simp add: sup_commute)
  also have "\<dots> = (x \<sqinter> y) \<squnion> (x \<sqinter> z)" by (simp add:distrib)
  finally show ?thesis .
qed

end

subsubsection \<open>Strict order\<close>

context semilattice_inf
begin

lemma less_infI1: "a < x \<Longrightarrow> a \<sqinter> b < x"
  by (auto simp add: less_le inf_absorb1 intro: le_infI1)

lemma less_infI2: "b < x \<Longrightarrow> a \<sqinter> b < x"
  by (auto simp add: less_le inf_absorb2 intro: le_infI2)

end

context semilattice_sup
begin

lemma less_supI1: "x < a \<Longrightarrow> x < a \<squnion> b"
  using dual_semilattice
  by (rule semilattice_inf.less_infI1)

lemma less_supI2: "x < b \<Longrightarrow> x < a \<squnion> b"
  using dual_semilattice
  by (rule semilattice_inf.less_infI2)

end

subsection \<open>Distributive lattices\<close>

class distrib_lattice = lattice +
  assumes sup_inf_distrib1: "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"

context distrib_lattice
begin

lemma sup_inf_distrib2: "(y \<sqinter> z) \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  by (simp add: sup_commute sup_inf_distrib1)

lemma inf_sup_distrib1: "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
  by (rule distrib_imp2 [OF sup_inf_distrib1])

lemma inf_sup_distrib2: "(y \<squnion> z) \<sqinter> x = (y \<sqinter> x) \<squnion> (z \<sqinter> x)"
  by (simp add: inf_commute inf_sup_distrib1)

lemma dual_distrib_lattice: "class.distrib_lattice sup (\<ge>) (>) inf"
  by (rule class.distrib_lattice.intro, rule dual_lattice)
    (unfold_locales, fact inf_sup_distrib1)

lemmas sup_inf_distrib = sup_inf_distrib1 sup_inf_distrib2

lemmas inf_sup_distrib = inf_sup_distrib1 inf_sup_distrib2

lemmas distrib = sup_inf_distrib1 sup_inf_distrib2 inf_sup_distrib1 inf_sup_distrib2

end

subsection \<open>Bounded lattices\<close>

class bounded_semilattice_inf_top = semilattice_inf + order_top
begin

sublocale inf_top: semilattice_neutr inf top
  + inf_top: semilattice_neutr_order inf top less_eq less
proof
  show "x \<sqinter> \<top> = x" for x
    by (rule inf_absorb1) simp
qed

lemma inf_top_left: "\<top> \<sqinter> x = x"
  by (fact inf_top.left_neutral)

lemma inf_top_right: "x \<sqinter> \<top> = x"
  by (fact inf_top.right_neutral)

lemma inf_eq_top_iff: "x \<sqinter> y = \<top> \<longleftrightarrow> x = \<top> \<and> y = \<top>"
  by (fact inf_top.eq_neutr_iff)

lemma top_eq_inf_iff: "\<top> = x \<sqinter> y \<longleftrightarrow> x = \<top> \<and> y = \<top>"
  by (fact inf_top.neutr_eq_iff)

end

class bounded_semilattice_sup_bot = semilattice_sup + order_bot
begin

sublocale sup_bot: semilattice_neutr sup bot
  + sup_bot: semilattice_neutr_order sup bot greater_eq greater
proof
  show "x \<squnion> \<bottom> = x" for x
    by (rule sup_absorb1) simp
qed

lemma sup_bot_left: "\<bottom> \<squnion> x = x"
  by (fact sup_bot.left_neutral)

lemma sup_bot_right: "x \<squnion> \<bottom> = x"
  by (fact sup_bot.right_neutral)

lemma sup_eq_bot_iff: "x \<squnion> y = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
  by (fact sup_bot.eq_neutr_iff)

lemma bot_eq_sup_iff: "\<bottom> = x \<squnion> y \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
  by (fact sup_bot.neutr_eq_iff)

end

class bounded_lattice_bot = lattice + order_bot
begin

subclass bounded_semilattice_sup_bot ..

lemma inf_bot_left [simp]: "\<bottom> \<sqinter> x = \<bottom>"
  by (rule inf_absorb1) simp

lemma inf_bot_right [simp]: "x \<sqinter> \<bottom> = \<bottom>"
  by (rule inf_absorb2) simp

end

class bounded_lattice_top = lattice + order_top
begin

subclass bounded_semilattice_inf_top ..

lemma sup_top_left [simp]: "\<top> \<squnion> x = \<top>"
  by (rule sup_absorb1) simp

lemma sup_top_right [simp]: "x \<squnion> \<top> = \<top>"
  by (rule sup_absorb2) simp

end

class bounded_lattice = lattice + order_bot + order_top
begin

subclass bounded_lattice_bot ..
subclass bounded_lattice_top ..

lemma dual_bounded_lattice: "class.bounded_lattice sup greater_eq greater inf \<top> \<bottom>"
  by unfold_locales (auto simp add: less_le_not_le)

end

subsection \<open>\<open>min/max\<close> as special case of lattice\<close>

context linorder
begin

sublocale min: semilattice_order min less_eq less
  + max: semilattice_order max greater_eq greater
  by standard (auto simp add: min_def max_def)

declare min.absorb1 [simp] min.absorb2 [simp]
  min.absorb3 [simp] min.absorb4 [simp]
  max.absorb1 [simp] max.absorb2 [simp]
  max.absorb3 [simp] max.absorb4 [simp]

lemma min_le_iff_disj: "min x y \<le> z \<longleftrightarrow> x \<le> z \<or> y \<le> z"
  unfolding min_def using linear by (auto intro: order_trans)

lemma le_max_iff_disj: "z \<le> max x y \<longleftrightarrow> z \<le> x \<or> z \<le> y"
  unfolding max_def using linear by (auto intro: order_trans)

lemma min_less_iff_disj: "min x y < z \<longleftrightarrow> x < z \<or> y < z"
  unfolding min_def le_less using less_linear by (auto intro: less_trans)

lemma less_max_iff_disj: "z < max x y \<longleftrightarrow> z < x \<or> z < y"
  unfolding max_def le_less using less_linear by (auto intro: less_trans)

lemma min_less_iff_conj [simp]: "z < min x y \<longleftrightarrow> z < x \<and> z < y"
  unfolding min_def le_less using less_linear by (auto intro: less_trans)

lemma max_less_iff_conj [simp]: "max x y < z \<longleftrightarrow> x < z \<and> y < z"
  unfolding max_def le_less using less_linear by (auto intro: less_trans)

lemma min_max_distrib1: "min (max b c) a = max (min b a) (min c a)"
  by (auto simp add: min_def max_def not_le dest: le_less_trans less_trans intro: antisym)

lemma min_max_distrib2: "min a (max b c) = max (min a b) (min a c)"
  by (auto simp add: min_def max_def not_le dest: le_less_trans less_trans intro: antisym)

lemma max_min_distrib1: "max (min b c) a = min (max b a) (max c a)"
  by (auto simp add: min_def max_def not_le dest: le_less_trans less_trans intro: antisym)

lemma max_min_distrib2: "max a (min b c) = min (max a b) (max a c)"
  by (auto simp add: min_def max_def not_le dest: le_less_trans less_trans intro: antisym)

lemmas min_max_distribs = min_max_distrib1 min_max_distrib2 max_min_distrib1 max_min_distrib2

lemma split_min [no_atp]: "P (min i j) \<longleftrightarrow> (i \<le> j \<longrightarrow> P i) \<and> (\<not> i \<le> j \<longrightarrow> P j)"
  by (simp add: min_def)

lemma split_max [no_atp]: "P (max i j) \<longleftrightarrow> (i \<le> j \<longrightarrow> P j) \<and> (\<not> i \<le> j \<longrightarrow> P i)"
  by (simp add: max_def)

lemma split_min_lin [no_atp]:
  \<open>P (min a b) \<longleftrightarrow> (b = a \<longrightarrow> P a) \<and> (a < b \<longrightarrow> P a) \<and> (b < a \<longrightarrow> P b)\<close>
  by (cases a b rule: linorder_cases) auto

lemma split_max_lin [no_atp]:
  \<open>P (max a b) \<longleftrightarrow> (b = a \<longrightarrow> P a) \<and> (a < b \<longrightarrow> P b) \<and> (b < a \<longrightarrow> P a)\<close>
  by (cases a b rule: linorder_cases) auto

end

lemma inf_min: "inf = (min :: 'a::{semilattice_inf,linorder} \<Rightarrow> 'a \<Rightarrow> 'a)"
  by (auto intro: antisym simp add: min_def fun_eq_iff)

lemma sup_max: "sup = (max :: 'a::{semilattice_sup,linorder} \<Rightarrow> 'a \<Rightarrow> 'a)"
  by (auto intro: antisym simp add: max_def fun_eq_iff)

subsection \<open>Uniqueness of inf and sup\<close>

lemma (in semilattice_inf) inf_unique:
  fixes f  (infixl "\<triangle>" 70)
  assumes le1: "\<And>x y. x \<triangle> y \<le> x"
    and le2: "\<And>x y. x \<triangle> y \<le> y"
    and greatest: "\<And>x y z. x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<triangle> z"
  shows "x \<sqinter> y = x \<triangle> y"
proof (rule order.antisym)
  show "x \<triangle> y \<le> x \<sqinter> y"
    by (rule le_infI) (rule le1, rule le2)
  have leI: "\<And>x y z. x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<triangle> z"
    by (blast intro: greatest)
  show "x \<sqinter> y \<le> x \<triangle> y"
    by (rule leI) simp_all
qed

lemma (in semilattice_sup) sup_unique:
  fixes f  (infixl "\<nabla>" 70)
  assumes ge1 [simp]: "\<And>x y. x \<le> x \<nabla> y"
    and ge2: "\<And>x y. y \<le> x \<nabla> y"
    and least: "\<And>x y z. y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<nabla> z \<le> x"
  shows "x \<squnion> y = x \<nabla> y"
proof (rule order.antisym)
  show "x \<squnion> y \<le> x \<nabla> y"
    by (rule le_supI) (rule ge1, rule ge2)
  have leI: "\<And>x y z. x \<le> z \<Longrightarrow> y \<le> z \<Longrightarrow> x \<nabla> y \<le> z"
    by (blast intro: least)
  show "x \<nabla> y \<le> x \<squnion> y"
    by (rule leI) simp_all
qed

subsection \<open>Lattice on \<^typ>\<open>_ \<Rightarrow> _\<close>\<close>

instantiation "fun" :: (type, semilattice_sup) semilattice_sup
begin

definition "f \<squnion> g = (\<lambda>x. f x \<squnion> g x)"

lemma sup_apply [simp, code]: "(f \<squnion> g) x = f x \<squnion> g x"
  by (simp add: sup_fun_def)

instance
  by standard (simp_all add: le_fun_def)

end

instantiation "fun" :: (type, semilattice_inf) semilattice_inf
begin

definition "f \<sqinter> g = (\<lambda>x. f x \<sqinter> g x)"

lemma inf_apply [simp, code]: "(f \<sqinter> g) x = f x \<sqinter> g x"
  by (simp add: inf_fun_def)

instance by standard (simp_all add: le_fun_def)

end

instance "fun" :: (type, lattice) lattice ..

instance "fun" :: (type, distrib_lattice) distrib_lattice
  by standard (rule ext, simp add: sup_inf_distrib1)

instance "fun" :: (type, bounded_lattice) bounded_lattice ..

instantiation "fun" :: (type, uminus) uminus
begin

definition fun_Compl_def: "- A = (\<lambda>x. - A x)"

lemma uminus_apply [simp, code]: "(- A) x = - (A x)"
  by (simp add: fun_Compl_def)

instance ..

end

instantiation "fun" :: (type, minus) minus
begin

definition fun_diff_def: "A - B = (\<lambda>x. A x - B x)"

lemma minus_apply [simp, code]: "(A - B) x = A x - B x"
  by (simp add: fun_diff_def)

instance ..

end

end


theory dropTake
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S Nat

fun eqN :: "Nat \<Rightarrow> Nat \<Rightarrow> bool" where
  "eqN Z Z = True"
| "eqN (S n) (S m) = eqN n m"
| "eqN _     _     = False"

datatype 'a List = Nil | Cons 'a "'a List"

fun len :: "'a List \<Rightarrow> Nat" where
  "len Nil = Z"
| "len (Cons _ as) = S (len as)"

fun app :: "'a List \<Rightarrow> 'a List \<Rightarrow> 'a List" where
  "app Nil         ts = ts"
| "app (Cons r rs) ts = Cons r (app rs ts)"

fun init :: "'a List \<Rightarrow> 'a List" where
  "init Nil          = Nil"
| "init (Cons _ Nil) = Nil"
| "init (Cons t ts)  = Cons t (init ts)"

fun tail :: "'a List \<Rightarrow> 'a List" where
  "tail Nil         = Nil"
| "tail (Cons _ ts) = ts"

fun zip :: "'a List \<Rightarrow> 'b List \<Rightarrow> ('a * 'b) List" where
  "zip Nil _   = Nil"
| "zip _   Nil = Nil"
| "zip (Cons t ts) (Cons r rs) = Cons (t,r) (zip ts rs)"

(* An example for conditionals and simultaneous induction derived from _zip_'s definition:
    immediately provable by our tactic without a need for exploration *)
lemma appZips : "len a = len b \<Longrightarrow> app (zip a b) (zip c d) = zip (app a c) (app b d)"
  (* apply hipster_induct *)
  apply (induct a b arbitrary: c d rule: dropTake.zip.induct)
  apply simp
  apply (metis Nat.distinct(1) app.simps(1) len.elims)
  apply simp
  apply simp
  done
(*by (hipster_induct_schemes app.simps zip.simps len.simps List.exhaust Nat.distinct)*)

fun take :: "Nat \<Rightarrow> 'a List \<Rightarrow> 'a List" where
  "take Z     _           = Nil"
| "take _     Nil         = Nil"
| "take (S n) (Cons t ts) = Cons t (take n ts)"

fun drop :: "Nat \<Rightarrow> 'a List \<Rightarrow> 'a List" where
  "drop Z     ts          = ts"
| "drop _     Nil         = Nil"
| "drop (S n) (Cons t ts) = drop n ts"
lemma dropTake : "ts = app (take n ts) (drop n ts)"
  (* apply hipster_induct *)
  apply (induct n ts rule: dropTake.take.induct)
  apply simp
  apply simp
  apply simp
  done
  (* by hipster_induct_schemes *)
ML\<open>
fun SOLVE_OR_FAIL tac st =
  let fun solved st = has_fewer_prems 1 st;
  in Seq.filter solved (tac st) end;

fun mytac ctxt = (SOLVE_OR_FAIL (Rec_Ind_Tacs.recinduct_simp ctxt)) ORELSE (Rec_Ind_Lemma_Spec_Tacs.koen_induct ctxt)
\<close>
method_setup recind_lemma = \<open>
  Scan.lift (Scan.succeed
    (fn ctxt => SIMPLE_METHOD
      (mytac ctxt)))
\<close>

(* Similarly for the more complex in expression yet not conditional similar proposition to the above *)
lemma zipApp : "zip (app xs ys) zs = app (zip xs (take (len xs) zs)) (zip ys (drop (len xs) zs))"
  apply recind_lemma
  (* apply hipster_induct *) (* fails*)
(* by (hipster_induct_schemes app.simps zip.simps drop.simps take.simps len.simps Nat.exhaust List.exhaust) *)
  oops

fun sub :: "Nat \<Rightarrow> Nat \<Rightarrow> Nat" where
  "sub Z _     = Z"
| "sub (S n) Z = S n"
| "sub (S n) (S m) = sub n m"

lemma initAsTake: "init ts = take (sub (len ts) (S Z)) ts"
(*  apply hipster_induct *)
  apply (induct ts rule: dropTake.init.induct)
  apply simp
  apply simp
  apply simp
  apply (metis Nat.distinct(1) sub.elims)
  done
(* by (hipster_induct_schemes sub.simps Nat.exhaust) *)

fun count :: "Nat \<Rightarrow> Nat List \<Rightarrow> Nat" where
  "count _ Nil = Z"
| "count n (Cons t ts) = (if eqN n t then S (count n ts) else count n ts)"

lemma count01: "\<not> (eqN r t) \<Longrightarrow> count r (app ts (Cons t Nil)) = count r ts"
 (*  apply hipster_induct *)
  apply (induct ts arbitrary: r t)
  apply simp
  apply simp
  done
(* by (hipster_induct_simp_metis) *)

lemma initTail : "init (tail x) = tail (init x)"
 (* apply hipster_induct *)
  apply (induct x)
  apply simp
  apply simp
  apply (smt List.distinct(1) init.elims tail.simps(1) tail.simps(2))
  done
(* by (hipster_induct_schemes) *)

lemma lenInitTail: "len (init x) = len (tail x)"
(*   apply hipster_induct *)
  apply (induct x)
apply simp
apply simp
  apply (metis init.simps(2) init.simps(3) len.elims len.simps(2) tail.simps(2))
  done
(* by (hipster_induct_schemes) *)

fun notNil :: "'a List \<Rightarrow> bool" where
  "notNil Nil = False"
| "notNil _   = True"

lemma initApp: "notNil ts \<Longrightarrow> init (app rs ts) = app rs (init ts)"
 (*  apply hipster_induct *)
  apply (induct rs arbitrary: ts)
  apply simp
  apply simp
  apply (metis app.elims init.simps(3) notNil.elims(2))
  done
(* by (hipster_induct_schemes notNil.elims init.simps app.simps) *)

end


(*<*)
theory Trie imports Main begin
(*>*)
text{*
To minimize running time, each node of a trie should contain an array that maps
letters to subtries. We have chosen a
representation where the subtries are held in an association list, i.e.\ a
list of (letter,trie) pairs.  Abstracting over the alphabet @{typ"'a"} and the
values @{typ"'v"} we define a trie as follows:
*}

datatype ('a,'v)trie = Trie  "'v option"  "('a * ('a,'v)trie)list"

text{*\noindent
\index{datatypes!and nested recursion}%
The first component is the optional value, the second component the
association list of subtries.  This is an example of nested recursion involving products,
which is fine because products are datatypes as well.
We define two selector functions:
*}

primrec "value" :: "('a,'v)trie \<Rightarrow> 'v option" where
"value(Trie ov al) = ov"
primrec alist :: "('a,'v)trie \<Rightarrow> ('a * ('a,'v)trie)list" where
"alist(Trie ov al) = al"

text{*\noindent
Association lists come with a generic lookup function.  Its result
involves type @{text option} because a lookup can fail:
*}

primrec assoc :: "('key * 'val)list \<Rightarrow> 'key \<Rightarrow> 'val option" where
"assoc [] x = None" |
"assoc (p#ps) x =
   (let (a,b) = p in if a=x then Some b else assoc ps x)"

text{*
Now we can define the lookup function for tries. It descends into the trie
examining the letters of the search string one by one. As
recursion on lists is simpler than on tries, let us express this as primitive
recursion on the search string argument:
*}

primrec lookup :: "('a,'v)trie \<Rightarrow> 'a list \<Rightarrow> 'v option" where
"lookup t [] = value t" |
"lookup t (a#as) = (case assoc (alist t) a of
                      None \<Rightarrow> None
                    | Some at \<Rightarrow> lookup at as)"

text{*
As a first simple property we prove that looking up a string in the empty
trie @{term"Trie None []"} always returns @{const None}. The proof merely
distinguishes the two cases whether the search string is empty or not:
*}

text{*
Things begin to get interesting with the definition of an update function
that adds a new (string, value) pair to a trie, overwriting the old value
associated with that string:
*}

primrec update:: "('a,'v)trie \<Rightarrow> 'a list \<Rightarrow> 'v \<Rightarrow> ('a,'v)trie" where
"update t []     v = Trie (Some v) (alist t)" |
"update t (a#as) v =
   (let tt = (case assoc (alist t) a of
                None \<Rightarrow> Trie None [] | Some at \<Rightarrow> at)
    in Trie (value t) ((a,update tt as v) # alist t))"

text{*\noindent
The base case is obvious. In the recursive case the subtrie
@{term tt} associated with the first letter @{term a} is extracted,
recursively updated, and then placed in front of the association list.
The old subtrie associated with @{term a} is still in the association list
but no longer accessible via @{const assoc}. Clearly, there is room here for
optimizations!

Before we start on any proofs about @{const update} we tell the simplifier to
expand all @{text let}s and to split all @{text case}-constructs over
options:
*}

declare Let_def[simp] option.split[split]

text{*\noindent
The reason becomes clear when looking (probably after a failed proof
attempt) at the body of @{const update}: it contains both
@{text let} and a case distinction over type @{text option}.

Our main goal is to prove the correct interaction of @{const update} and
@{const lookup}:
*}

theorem "\<forall>t v bs. lookup (update t as v) bs =
                    (if as=bs then Some v else lookup t bs)"

txt{*\noindent
Our plan is to induct on @{term as}; hence the remaining variables are
quantified. From the definitions it is clear that induction on either
@{term as} or @{term bs} is required. The choice of @{term as} is
guided by the intuition that simplification of @{const lookup} might be easier
if @{const update} has already been simplified, which can only happen if
@{term as} is instantiated.
The start of the proof is conventional:
*}
apply(induct_tac as, auto)

txt{*\noindent
Unfortunately, this time we are left with three intimidating looking subgoals:
\begin{isabelle}
~1.~\dots~{\isasymLongrightarrow}~lookup~\dots~bs~=~lookup~t~bs\isanewline
~2.~\dots~{\isasymLongrightarrow}~lookup~\dots~bs~=~lookup~t~bs\isanewline
~3.~\dots~{\isasymLongrightarrow}~lookup~\dots~bs~=~lookup~t~bs
\end{isabelle}
Clearly, if we want to make headway we have to instantiate @{term bs} as
well now. It turns out that instead of induction, case distinction
suffices:
*}
apply(case_tac[!] bs, auto)
done

text{*\noindent
\index{subgoal numbering}%
All methods ending in @{text tac} take an optional first argument that
specifies the range of subgoals they are applied to, where @{text"[!]"} means
all subgoals, i.e.\ @{text"[1-3]"} in our case. Individual subgoal numbers,
e.g. @{text"[2]"} are also allowed.

This proof may look surprisingly straightforward. However, note that this
comes at a cost: the proof script is unreadable because the intermediate
proof states are invisible, and we rely on the (possibly brittle) magic of
@{text auto} (@{text simp_all} will not do --- try it) to split the subgoals
of the induction up in such a way that case distinction on @{term bs} makes
sense and solves the proof.

\begin{exercise}
  Modify @{const update} (and its type) such that it allows both insertion and
  deletion of entries with a single function.  Prove the corresponding version
  of the main theorem above.
  Optimize your function such that it shrinks tries after
  deletion if possible.
\end{exercise}

\begin{exercise}
  Write an improved version of @{const update} that does not suffer from the
  space leak (pointed out above) caused by not deleting overwritten entries
  from the association list. Prove the main theorem for your improved
  @{const update}.
\end{exercise}

\begin{exercise}
  Conceptually, each node contains a mapping from letters to optional
  subtries. Above we have implemented this by means of an association
  list. Replay the development replacing @{typ "('a * ('a,'v)trie)list"}
  with @{typ"'a \<Rightarrow> ('a,'v)trie option"}.
\end{exercise}

*}

(*<*)

(* Exercise 1. Solution by Getrud Bauer *)

primrec update1 :: "('a, 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v option \<Rightarrow> ('a, 'v) trie"
where
  "update1 t []     vo = Trie vo (alist t)" |
  "update1 t (a#as) vo =
     (let tt = (case assoc (alist t) a of
                  None \<Rightarrow> Trie None []
                | Some at \<Rightarrow> at)
      in Trie (value t) ((a, update1 tt as vo) # alist t))"

theorem [simp]: "\<forall>t v bs. lookup (update1 t as v) bs =
                    (if as = bs then v else lookup t bs)"
apply (induct_tac as, auto)
apply (case_tac[!] bs, auto)
done

(* Exercise 2. Solution by Getrud Bauer *)

primrec overwrite :: "'a \<Rightarrow> 'b \<Rightarrow> ('a * 'b) list \<Rightarrow> ('a * 'b) list" where
"overwrite a v [] = [(a,v)]" |
"overwrite a v (p#ps) = (if a = fst p then (a,v)#ps else p # overwrite a v ps)"

lemma [simp]: "\<forall> a v b. assoc (overwrite a v ps) b = assoc ((a,v)#ps) b"
apply (induct_tac ps, auto)
apply (case_tac[!] a)
done

primrec update2 :: "('a, 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v option \<Rightarrow> ('a, 'v) trie"
where
  "update2 t []     vo = Trie vo (alist t)" |
  "update2 t (a#as) vo =
     (let tt = (case assoc (alist t) a of
                  None \<Rightarrow> Trie None []
                | Some at \<Rightarrow> at)
      in Trie (value t) (overwrite a (update2 tt as vo) (alist t)))"

theorem "\<forall>t v bs. lookup (update2 t as vo) bs =
                    (if as = bs then vo else lookup t bs)"
apply (induct_tac as, auto)
apply (case_tac[!] bs, auto)
done

(* Exercise 3. Solution by Getrud Bauer *)
datatype ('a,dead 'v) triem = Triem  "'v option" "'a \<Rightarrow> ('a,'v) triem option"

primrec valuem :: "('a, 'v) triem \<Rightarrow> 'v option" where
"valuem (Triem ov m) = ov"

primrec mapping :: "('a,'v) triem \<Rightarrow> 'a \<Rightarrow> ('a, 'v) triem option" where
"mapping (Triem ov m) = m"

primrec lookupm :: "('a,'v) triem \<Rightarrow> 'a list \<Rightarrow> 'v option" where
  "lookupm t [] = valuem t" |
  "lookupm t (a#as) = (case mapping t a of
                        None \<Rightarrow> None
                      | Some at \<Rightarrow> lookupm at as)"

lemma [simp]: "lookupm (Triem None  (\<lambda>c. None)) as = None"
apply (case_tac as, simp_all)
done

primrec updatem :: "('a,'v)triem \<Rightarrow> 'a list \<Rightarrow> 'v \<Rightarrow> ('a,'v)triem" where
  "updatem t []     v = Triem (Some v) (mapping t)" |
  "updatem t (a#as) v =
     (let tt = (case mapping t a of
                  None \<Rightarrow> Triem None (\<lambda>c. None)
                | Some at \<Rightarrow> at)
      in Triem (valuem t)
              (\<lambda>c. if c = a then Some (updatem tt as v) else mapping t c))"

theorem "\<forall>t v bs. lookupm (updatem t as v) bs =
                    (if as = bs then Some v else lookupm t bs)"
apply (induct_tac as, auto)
apply (case_tac[!] bs, auto)
done

end
(*>*)


subsection \<open>Measure spaces \label{sec:measure-spaces}\<close>

theory Measure
imports Sigma_Algebra MonConv
begin

(*We use a modified version of the simple Sigma_Algebra Theory by
Markus Wenzel here,
  which does not need an explicit definition of countable,
  changing the names according to Joe Hurd*)
text \<open>Now we are already set for the central concept of
  measure. The following definitions are translated as faithfully as possible
  from those in Joe Hurd's thesis \cite{hurd2002}.\<close>

definition
  measurable:: "'a set set \<Rightarrow> 'b set set \<Rightarrow> ('a \<Rightarrow> 'b) set" where
  "measurable F G = {f. \<forall>g\<in>G. f -` g \<in> F}"

text \<open>So a function is called $F$-$G$-measurable if and only if the inverse
  image of any set in $G$ is in $F$. $F$ and $G$ are usually the sets of
  measurable sets, the first component of a measure space\footnote{In
  standard mathematical notation, the universe is first in a
  measure space triple, but in our definitions, following Joe Hurd, it is always the
  whole type universe and therefore omitted.}.\<close>

definition
  measurable_sets:: "('a set set * ('a set \<Rightarrow> real)) \<Rightarrow> 'a set set" where
  "measurable_sets = fst"

definition
  measure:: "('a set set * ('a set \<Rightarrow> real)) \<Rightarrow> ('a set \<Rightarrow> real)" where
  "measure = snd"

text \<open>The other component is the measure itself. It is a function that
  assigns a nonnegative real number to every measurable set and has
  the property of being
  countably additive for disjoint sets.\<close>

definition
  positive:: "('a set set * ('a set \<Rightarrow> real)) \<Rightarrow> bool" where
  "positive M \<longleftrightarrow> measure M {} = 0 \<and>
  (\<forall>A. A\<in> measurable_sets M \<longrightarrow> 0 \<le> measure M A)"
  (*Remark: This definition of measure space is not minimal,
  in the sense that the containment of the \<Union>(the ` in) measurable sets
  is implied by the measurable sets being a sigma algebra*)

definition
  countably_additive:: "('a set set * ('a set => real)) => bool" where
  "countably_additive M \<longleftrightarrow> (\<forall>f::(nat => 'a set). range f \<subseteq> measurable_sets M
  \<and> (\<forall>m n. m \<noteq> n \<longrightarrow> f m \<inter> f n = {}) \<and>  (\<Union>i. f i) \<in> measurable_sets M
  \<longrightarrow> (\<lambda>n. measure M (f n)) sums  measure M (\<Union>i. f i))"

text \<open>This last property deserves some comments. The conclusion is
  usually --- also in the aforementioned source --- phrased as

  \<open>measure M (\<Union>i. f i) = (\<Sum>n. measure M (f n))\<close>.

  In our formal setting this is unsatisfactory, because the
  sum operator\footnote{Which is merely syntactic sugar for the
  \isa{suminf} functional from the \isa{Series} theory
  \cite{Fleuriot:2000:MNR}.}, like any HOL function, is total, although
  a series obviously need not converge. It is defined using the \<open>\<epsilon>\<close> operator, and its
  behavior is unspecified in the diverging case. Hence, the above assertion
  would give no information about the convergence of the series.

  Furthermore, the definition contains redundancy. Assuming that the
  countable union of sets is measurable is unnecessary when the
  measurable sets form a sigma algebra, which is postulated in the
  final definition\footnote{Joe Hurd inherited this practice from a very
  influential probability textbook \cite{Williams.mart}}.
\<close>

definition
  measure_space:: "('a set set * ('a set \<Rightarrow> real)) \<Rightarrow> bool" where
  "measure_space M \<longleftrightarrow> sigma_algebra (measurable_sets M) \<and>
  positive M \<and> countably_additive M"

text \<open>Note that our definition is restricted to finite measure
  spaces --- that is, \<open>measure M UNIV < \<infinity>\<close> --- since the measure
  must be a real number for any measurable set. In probability, this
  is naturally the case.

  Two important theorems close this section. Both appear in
  Hurd's work as well, but are shown anyway, owing to their central
  role in measure theory. The first one is a mighty tool for proving measurability. It states
  that for a function mapping one sigma algebra into another, it is
  sufficient to be measurable regarding only a generator of the target
  sigma algebra. Formalizing the interesting proof out of Bauer's
  textbook \cite{Bauer} is relatively straightforward using rule
  induction.\<close>

theorem assumes sig: "sigma_algebra a" and meas: "f \<in> measurable a b" shows
  measurable_lift: "f \<in> measurable a (sigma b)"
proof -
  define Q where "Q = {q. f -` q \<in> a}"
  with meas have 1: "b \<subseteq> Q" by (auto simp add: measurable_def)

  { fix x assume "x\<in>sigma b"
    hence "x\<in>Q"
    proof (induct rule: sigma.induct)
      case basic
      from 1 show " \<And>a. a \<in> b \<Longrightarrow> a \<in> Q" ..
    next
      case empty
      from sig have "{}\<in>a"
        by (simp only: sigma_algebra_def)
      thus "{} \<in> Q"
        by (simp add: Q_def)
    next
      case complement
      fix r assume "r \<in> Q"
      then obtain r1 where im: "r1 = f -` r" and a: "r1 \<in> a"
        by (simp add: Q_def)
      with sig have "-r1 \<in> a"
        by (simp only: sigma_algebra_def)
      with im Q_def show "-r \<in> Q"
        by (simp add: vimage_Compl)
    next
      case Union
      fix r assume "\<And>i::nat. r i \<in> Q"
      then obtain r1 where im: "\<And>i. r1 i =  f -` r i" and a: "\<And>i. r1 i \<in>        a"
        by (simp add: Q_def)
      from a sig have "\<Union>(r1 ` UNIV) \<in> a"
        by (auto simp only: sigma_algebra_def)
      with im Q_def show "\<Union>(r ` UNIV) \<in> Q"
        by (auto simp add: vimage_UN)
    qed }

  hence "(sigma b) \<subseteq> Q" ..
  thus "f \<in> measurable a (sigma b)"
    by (auto simp add: measurable_def Q_def)
qed

text \<open>The case is different for the second theorem. It is only five
  lines in the book (ibid.), but almost 200 in formal text. Precision
  still pays here, gaining a detailed view of a technique that
  is often employed in measure theory --- making a sequence of sets
  disjoint. Moreover, the necessity for the above-mentioned change in the
  definition of countably additive was detected only in the
  formalization of this proof.

  To enable application of the additivity of measures, the following construction
  yields disjoint sets. We skip the justification of the lemmata for
  brevity.\<close>

primrec mkdisjoint:: "(nat \<Rightarrow> 'a set) \<Rightarrow> (nat \<Rightarrow> 'a set)"
where
  "mkdisjoint A 0 = A 0"
| "mkdisjoint A (Suc n) = A (Suc n) - A n"

lemma mkdisjoint_un:
  assumes up: "\<And>n. A n \<subseteq> A (Suc n)"
  shows "A n = (\<Union>i\<in>{..n}. mkdisjoint A i)"
(*<*)proof (induct n)
  case 0 show ?case by simp
next
  case (Suc n)
  hence "A n = (\<Union>i\<in>{..n}. mkdisjoint A i)" .
  moreover
  have "(\<Union>i\<in>{..(Suc n)}. mkdisjoint A i) = mkdisjoint A (Suc n) \<union>
    (\<Union>i\<in>{..n}. mkdisjoint A i)" by (simp add: atMost_Suc)
  moreover
  have "mkdisjoint A (Suc n) \<union> A n = A (Suc n) \<union> A n" by simp
  moreover
  from up have "\<dots> = A (Suc n)" by auto
  ultimately
  show ?case by simp
qed(*>*)

lemma mkdisjoint_disj:
  assumes up: "\<And>n. A n \<subseteq> A (Suc n)" and ne: "m \<noteq> n"
  shows "mkdisjoint A m \<inter> mkdisjoint A n = {}"
(*<*)proof -
  { fix m1 m2::nat assume less: "m1 < m2"
    hence "0 < m2" by simp
    then obtain n where eq: "m2 = Suc n" by (auto simp add: gr0_conv_Suc)
    with less have less2: "m1 < Suc n" by simp

    {
      fix y assume y: "y \<in> mkdisjoint A m1"
      fix x assume x: "x \<in> mkdisjoint A m2"
      with eq have"x \<notin> A n" by simp
      also from up have "A n = (\<Union>i\<in>{..n}. mkdisjoint A i)"
        by (rule mkdisjoint_un)
      also
      from less2 have "m1 \<in> {..n}" by simp
      hence "mkdisjoint A m1 \<subseteq> (\<Union>i\<in>{..n}. mkdisjoint A i)" by auto
      ultimately
      have "x \<notin> mkdisjoint A m1" by auto
      with y have "y \<noteq> x" by fast
    }
    hence "mkdisjoint A m1 \<inter> mkdisjoint A m2 = {}"
      by (simp add: disjoint_iff_not_equal)
  } hence 1: "\<And>m1 m2. m1 < m2 \<Longrightarrow>  mkdisjoint A m1 \<inter> mkdisjoint A m2 = {}" .

  show ?thesis
  proof (cases "m < n")
    case True
    thus ?thesis by (rule 1)
  next
    case False
    with ne have "n < m" by arith
    hence "mkdisjoint A n \<inter> mkdisjoint A m = {}" by (rule 1)
    thus ?thesis by fast
  qed
qed(*>*)

lemma mkdisjoint_mon_conv:
  assumes mc: "A\<up>B"
  shows "(\<Union>i. mkdisjoint A i) = B"
(*<*)proof
  { fix x assume "x \<in> (\<Union>i. mkdisjoint A i)"
    then obtain i where "x \<in> mkdisjoint A i" by auto
    hence "x \<in> A i" by (cases i) simp_all
    with mc have "x \<in> B" by (auto simp add: mon_conv_set_def)
  }
  thus "(\<Union>i. mkdisjoint A i) \<subseteq> B" by fast

  { fix x assume "x \<in> B"
    with mc obtain i where "x \<in> A i" by (auto simp add: mon_conv_set_def)
    also from mc have "\<And>n. A n \<subseteq> A (Suc n)" by (simp only: mon_conv_set_def)
    hence "A i = (\<Union>r\<in>{..i}. mkdisjoint A r)" by (rule mkdisjoint_un)
    also have "\<dots> \<subseteq> (\<Union>r. mkdisjoint A r)" by auto
    finally have "x \<in> (\<Union>i. mkdisjoint A i)".
  }
  thus "B \<subseteq> (\<Union>i. mkdisjoint A i)" by fast
qed(*>*)

(*This is in Joe Hurd's Thesis (p. 35) as Monotone Convergence theorem. Check the real name \<dots> .
    Also, it's not as strong as it could be,
    but we need no more.*)

text \<open>Joe Hurd calls the following the Monotone Convergence Theorem,
  though in mathematical literature this name is often reserved for a
  similar fact
  about integrals that we will prove in \ref{nnfis}, which depends on this
  one. The claim made here is that the measures of monotonically convergent sets
  approach the measure of their limit. A strengthened version would
  imply monotone convergence of the measures, but is not needed in the
  development.
\<close>

theorem measure_mon_conv:
  assumes ms: "measure_space M" and
  Ams: "\<And>n. A n \<in> measurable_sets M" and AB: "A\<up>B"
  shows "(\<lambda>n. measure M (A n)) \<longlonglongrightarrow> measure M B"
proof -

  from AB have up: "\<And>n. A n \<subseteq> A (Suc n)"
    by (simp only: mon_conv_set_def)

  { fix i
    have "mkdisjoint A i \<in> measurable_sets M"
    proof (cases i)
      case 0 with Ams show ?thesis by simp
    next
      case (Suc i)
      have "A (Suc i) - A i = A (Suc i) \<inter> - A i" by blast
      with Suc ms Ams show ?thesis
        by (auto simp add: measure_space_def sigma_algebra_def sigma_algebra_inter)
    qed
  }
  hence i: "\<And>i. mkdisjoint A i \<in> measurable_sets M" .

  with ms have un: "(\<Union>i. mkdisjoint A i) \<in> measurable_sets M"
    by (simp add: measure_space_def sigma_algebra_def)
  moreover
  from i have range: "range (mkdisjoint A) \<subseteq> measurable_sets M"
    by fast
  moreover
  from up have "\<forall>i j. i \<noteq> j \<longrightarrow>  mkdisjoint A i \<inter> mkdisjoint A j = {}"
    by (simp add: mkdisjoint_disj)
  moreover note ms
  ultimately
  have sums:
    "(\<lambda>i. measure M (mkdisjoint A i)) sums (measure M (\<Union>i. mkdisjoint A i))"
    by (simp add: measure_space_def countably_additive_def)
  hence "(\<Sum>i. measure M (mkdisjoint A i)) = (measure M (\<Union>i. mkdisjoint A i))"
    by (rule sums_unique[THEN sym])

  also
  from sums have "summable (\<lambda>i. measure M (mkdisjoint A i))"
    by (rule sums_summable)

  hence "(\<lambda>n. \<Sum>i<n. measure M (mkdisjoint A i))
    \<longlonglongrightarrow> (\<Sum>i. measure M (mkdisjoint A i))"
    by (rule summable_LIMSEQ)

  hence "(\<lambda>n. \<Sum>i<Suc n. measure M (mkdisjoint A i)) \<longlonglongrightarrow> (\<Sum>i. measure M (mkdisjoint A i))"
    by (rule LIMSEQ_Suc)

  ultimately have "(\<lambda>n. \<Sum>i<Suc n. measure M (mkdisjoint A i))
    \<longlonglongrightarrow> (measure M (\<Union>i. mkdisjoint A i))" by simp

  also
  { fix n
    from up have "A n = (\<Union>i\<in>{..n}. mkdisjoint A i)"
      by (rule mkdisjoint_un)
    hence "measure M (A n) = measure M (\<Union>i\<in>{..n}. mkdisjoint A i)"
      by simp

    also have
      "(\<Union>i\<in>{..n}. mkdisjoint A i) = (\<Union>i. if i\<le>n then mkdisjoint A i else {})"
    proof -
      have "UNIV = {..n} \<union> {n<..}" by auto
      hence "(\<Union>i. if i\<le>n then mkdisjoint A i else {}) =
        (\<Union>i\<in>{..n}. if i\<le>n then mkdisjoint A i else {})
        \<union>  (\<Union>i\<in>{n<..}. if i\<le>n then mkdisjoint A i else {})"
        by (auto split: if_splits)
      moreover
      { have "(\<Union>i\<in>{n<..}. if i\<le>n then mkdisjoint A i else {}) = {}"
          by force }
      hence "\<dots> = (\<Union>i\<in>{..n}. mkdisjoint A i)"
        by auto
      ultimately show
        "(\<Union>i\<in>{..n}. mkdisjoint A i) = (\<Union>i. if i\<le>n then mkdisjoint A i else {})" by simp
    qed

    ultimately have
      "measure M (A n) = measure M (\<Union>i. if i\<le>n then mkdisjoint A i else {})"
      by simp

    also
    from i ms have
      un: "(\<Union>i. if i\<le>n then mkdisjoint A i else {}) \<in> measurable_sets M"
      by (simp add: measure_space_def sigma_algebra_def cong add: SUP_cong_simp)
    moreover
    from i ms have
      "range (\<lambda>i. if i\<le>n then mkdisjoint A i else {}) \<subseteq> measurable_sets M"
      by (auto simp add: measure_space_def sigma_algebra_def)
    moreover
    from up have "\<forall>i j. i \<noteq> j \<longrightarrow>
      (if i\<le>n then mkdisjoint A i else {}) \<inter>
      (if j\<le>n then mkdisjoint A j else {}) = {}"
      by (simp add: mkdisjoint_disj)
    moreover note ms
    ultimately have
      "measure M (A n) = (\<Sum>i. measure M (if i \<le> n then mkdisjoint A i else {}))"
      by (simp add: measure_space_def countably_additive_def sums_unique cong add: SUP_cong_simp)

    also
    from ms have
      "\<forall>i. (Suc n)\<le>i \<longrightarrow> measure M (if i \<le> n then mkdisjoint A i else {}) = 0"
      by (simp add: measure_space_def positive_def)
    hence "(\<lambda>i. measure M (if i \<le> n then mkdisjoint A i else {})) sums
      (\<Sum>i<Suc n. measure M (if i \<le> n then mkdisjoint A i else {}))"
      by (intro sums_finite) auto
    hence "(\<Sum>i. measure M (if i \<le> n then mkdisjoint A i else {})) =
      (\<Sum>i<Suc n. measure M (if i \<le> n then mkdisjoint A i else {}))"
      by (rule sums_unique[THEN sym])
    also
    have "\<dots> = (\<Sum>i<Suc n. measure M (mkdisjoint A i))"
      by simp
    finally have
      "measure M (A n) = (\<Sum>i<Suc n. measure M (mkdisjoint A i))" .
  }

  ultimately have
    "(\<lambda>n. measure M (A n)) \<longlonglongrightarrow> (measure M (\<Union>i. mkdisjoint A i))"
    by simp

  with AB show ?thesis
    by (simp add: mkdisjoint_mon_conv)
qed(*>*)

(*<*)
primrec trivial_series2:: "'a set \<Rightarrow> 'a set \<Rightarrow> (nat \<Rightarrow> 'a set)"
where
  "trivial_series2 a b 0 = a"
| "trivial_series2 a b (Suc n) = (if (n=0) then b else {})"

lemma measure_additive: assumes ms: "measure_space M"
  and disj: "a \<inter> b = {}" and a: "a \<in> measurable_sets M"
  and b:"b \<in> measurable_sets M"
  shows "measure M (a \<union> b) = measure M a + measure M b"
(*<*)proof -
  have "(a \<union> b) = (\<Union>i. trivial_series2 a b i)"
  proof (rule set_eqI)
    fix x
    {
      assume "x \<in> a \<union> b"
      hence "\<exists>i. x \<in> trivial_series2 a b i"
      proof
        assume "x \<in> a"
        hence "x \<in> trivial_series2 a b 0"
          by simp
        thus "\<exists>i. x \<in> trivial_series2 a b i"
          by fast
      next
        assume "x \<in> b"
        hence "x \<in> trivial_series2 a b 1"
          by simp
        thus "\<exists>i. x \<in> trivial_series2 a b i"
          by fast
      qed
    }
    hence "(x \<in> a \<union> b) \<Longrightarrow> (x \<in> (\<Union>i. trivial_series2 a b i))"
      by simp
    also
    {
      assume "x \<in> (\<Union>i. trivial_series2 a b i)"
      then obtain i where x: "x \<in> trivial_series2 a b i"
        by auto
      hence "x \<in> a \<union> b"
      proof (cases i)
        case 0
        with x show ?thesis by simp
      next
        case (Suc n)
        with x show ?thesis
          by (cases n) auto
      qed
    }
    ultimately show "(x \<in> a \<union> b) = (x \<in> (\<Union>i. trivial_series2 a b i))"
      by fast
  qed
  also
  { fix i
    from a b ms have "trivial_series2 a b i \<in> measurable_sets M"
      by (cases i) (auto simp add: measure_space_def sigma_algebra_def)
  }
  hence m1: "range (trivial_series2 a b) \<subseteq> measurable_sets M"
    and m2: "(\<Union>i. trivial_series2 a b i) \<in> measurable_sets M"
    using ms
    by (auto simp add: measure_space_def sigma_algebra_def)

  { fix i j::nat
    assume "i \<noteq> j"
    hence "trivial_series2 a b i \<inter> trivial_series2 a b j = {}"
      using disj
      by (cases i, cases j, auto)(cases j, auto)
  }
  with m1 m2 have "(\<lambda>n. measure M (trivial_series2 a b n)) sums  measure M (\<Union>i. trivial_series2 a b i)"
    using ms
    by (simp add: measure_space_def countably_additive_def)
  moreover
  from ms have "\<forall>m. Suc(Suc 0) \<le> m \<longrightarrow> measure M (trivial_series2 a b m) = 0"
  proof (clarify)
    fix m
    assume "Suc (Suc 0) \<le> m"
    thus "measure M (trivial_series2 a b m) = 0"
      using ms
      by (cases m) (auto simp add: measure_space_def positive_def)
  qed
  hence "(\<lambda>n. measure M (trivial_series2 a b n)) sums (\<Sum>n<Suc(Suc 0). measure M (trivial_series2 a b n))"
    by (intro sums_finite) auto
  moreover
  have "(\<Sum>n=0..<Suc(Suc 0). measure M (trivial_series2 a b n)) =
    measure M a + measure M b"
    by simp
  ultimately
  have "measure M (a \<union> b) = (\<Sum>n. measure M (trivial_series2 a b n))"
    and "Measure.measure M a + Measure.measure M b = (\<Sum>n. measure M (trivial_series2 a b n))"
    by (simp_all add: sums_unique)
  thus ?thesis by simp
qed
(*>*)
end