(*  Title:      HOL/Analysis/Complete_Measure.thy
    Author:     Robert Himmelmann, Johannes Hoelzl, TU Muenchen
*)
section \<open>Complete Measures\<close>
theory Complete_Measure
  imports Bochner_Integration
begin

locale\<^marker>\<open>tag important\<close> complete_measure =
  fixes M :: "'a measure"
  assumes complete: "\<And>A B. B \<subseteq> A \<Longrightarrow> A \<in> null_sets M \<Longrightarrow> B \<in> sets M"

definition\<^marker>\<open>tag important\<close>
  "split_completion M A p = (if A \<in> sets M then p = (A, {}) else
   \<exists>N'. A = fst p \<union> snd p \<and> fst p \<inter> snd p = {} \<and> fst p \<in> sets M \<and> snd p \<subseteq> N' \<and> N' \<in> null_sets M)"

definition\<^marker>\<open>tag important\<close>
  "main_part M A = fst (Eps (split_completion M A))"

definition\<^marker>\<open>tag important\<close>
  "null_part M A = snd (Eps (split_completion M A))"

definition\<^marker>\<open>tag important\<close> completion :: "'a measure \<Rightarrow> 'a measure" where
  "completion M = measure_of (space M) { S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' }
    (emeasure M \<circ> main_part M)"

lemma completion_into_space:
  "{ S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' } \<subseteq> Pow (space M)"
  using sets.sets_into_space by auto

lemma space_completion[simp]: "space (completion M) = space M"
  unfolding completion_def using space_measure_of[OF completion_into_space] by simp

lemma completionI:
  assumes "A = S \<union> N" "N \<subseteq> N'" "N' \<in> null_sets M" "S \<in> sets M"
  shows "A \<in> { S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' }"
  using assms by auto

lemma completionE:
  assumes "A \<in> { S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' }"
  obtains S N N' where "A = S \<union> N" "N \<subseteq> N'" "N' \<in> null_sets M" "S \<in> sets M"
  using assms by auto

lemma sigma_algebra_completion:
  "sigma_algebra (space M) { S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' }"
    (is "sigma_algebra _ ?A")
  unfolding sigma_algebra_iff2
proof (intro conjI ballI allI impI)
  show "?A \<subseteq> Pow (space M)"
    using sets.sets_into_space by auto
next
  show "{} \<in> ?A" by auto
next
  let ?C = "space M"
  fix A assume "A \<in> ?A"
  then obtain S N N'
    where "A = S \<union> N" "N \<subseteq> N'" "N' \<in> null_sets M" "S \<in> sets M"
    by (rule completionE)
  then show "space M - A \<in> ?A"
    by (intro completionI[of _ "(?C - S) \<inter> (?C - N')" "(?C - S) \<inter> N' \<inter> (?C - N)"]) auto
next
  fix A :: "nat \<Rightarrow> 'a set" assume A: "range A \<subseteq> ?A"
  then have "\<forall>n. \<exists>S N N'. A n = S \<union> N \<and> S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N'"
    by (auto simp: image_subset_iff)
  then obtain S N N' where "\<forall>x. A x = S x \<union> N x \<and> S x \<in> sets M \<and> N' x \<in> null_sets M \<and> N x \<subseteq> N' x"
    by metis
  then show "\<Union>(A ` UNIV) \<in> ?A"
    using null_sets_UN[of N']
    by (intro completionI[of _ "\<Union>(S ` UNIV)" "\<Union>(N ` UNIV)" "\<Union>(N' ` UNIV)"]) auto
qed

lemma\<^marker>\<open>tag important\<close> sets_completion:
  "sets (completion M) = { S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' }"
  using sigma_algebra.sets_measure_of_eq[OF sigma_algebra_completion]
  by (simp add: completion_def)

lemma sets_completionE:
  assumes "A \<in> sets (completion M)"
  obtains S N N' where "A = S \<union> N" "N \<subseteq> N'" "N' \<in> null_sets M" "S \<in> sets M"
  using assms unfolding sets_completion by auto

lemma sets_completionI:
  assumes "A = S \<union> N" "N \<subseteq> N'" "N' \<in> null_sets M" "S \<in> sets M"
  shows "A \<in> sets (completion M)"
  using assms unfolding sets_completion by auto

lemma sets_completionI_sets[intro, simp]:
  "A \<in> sets M \<Longrightarrow> A \<in> sets (completion M)"
  unfolding sets_completion by force

lemma\<^marker>\<open>tag important\<close> measurable_completion: "f \<in> M \<rightarrow>\<^sub>M N \<Longrightarrow> f \<in> completion M \<rightarrow>\<^sub>M N"
  by (auto simp: measurable_def)

lemma null_sets_completion:
  assumes "N' \<in> null_sets M" "N \<subseteq> N'" shows "N \<in> sets (completion M)"
  using assms by (intro sets_completionI[of N "{}" N N']) auto

lemma\<^marker>\<open>tag important\<close> split_completion:
  assumes "A \<in> sets (completion M)"
  shows "split_completion M A (main_part M A, null_part M A)"
proof cases
  assume "A \<in> sets M" then show ?thesis
    by (simp add: split_completion_def[abs_def] main_part_def null_part_def)
next
  assume nA: "A \<notin> sets M"
  show ?thesis
    unfolding main_part_def null_part_def if_not_P[OF nA]
  proof (rule someI2_ex)
    from assms obtain S N N' where A: "A = S \<union> N" "N \<subseteq> N'" "N' \<in> null_sets M" "S \<in> sets M"
      by (blast intro: sets_completionE)
    let ?P = "(S, N - S)"
    show "\<exists>p. split_completion M A p"
      unfolding split_completion_def if_not_P[OF nA] using A
    proof (intro exI conjI)
      show "A = fst ?P \<union> snd ?P" using A by auto
      show "snd ?P \<subseteq> N'" using A by auto
   qed auto
  qed auto
qed

lemma sets_restrict_space_subset:
  assumes S: "S \<in> sets (completion M)"
  shows "sets (restrict_space (completion M) S) \<subseteq> sets (completion M)"
  by (metis assms sets.Int_space_eq2 sets_restrict_space_iff subsetI)

lemma
  assumes "S \<in> sets (completion M)"
  shows main_part_sets[intro, simp]: "main_part M S \<in> sets M"
    and main_part_null_part_Un[simp]: "main_part M S \<union> null_part M S = S"
    and main_part_null_part_Int[simp]: "main_part M S \<inter> null_part M S = {}"
  using split_completion[OF assms]
  by (auto simp: split_completion_def split: if_split_asm)

lemma main_part[simp]: "S \<in> sets M \<Longrightarrow> main_part M S = S"
  using split_completion[of S M]
  by (auto simp: split_completion_def split: if_split_asm)

lemma null_part:
  assumes "S \<in> sets (completion M)" shows "\<exists>N. N\<in>null_sets M \<and> null_part M S \<subseteq> N"
  using split_completion[OF assms] by (auto simp: split_completion_def split: if_split_asm)

lemma null_part_sets[intro, simp]:
  assumes "S \<in> sets M" shows "null_part M S \<in> sets M" "emeasure M (null_part M S) = 0"
proof -
  have S: "S \<in> sets (completion M)" using assms by auto
  have *: "S - main_part M S \<in> sets M" using assms by auto
  from main_part_null_part_Un[OF S] main_part_null_part_Int[OF S]
  have "S - main_part M S = null_part M S" by auto
  with * show sets: "null_part M S \<in> sets M" by auto
  from null_part[OF S] obtain N where "N \<in> null_sets M \<and> null_part M S \<subseteq> N" ..
  with emeasure_eq_0[of N _ "null_part M S"] sets
  show "emeasure M (null_part M S) = 0" by auto
qed

lemma emeasure_main_part_UN:
  fixes S :: "nat \<Rightarrow> 'a set"
  assumes "range S \<subseteq> sets (completion M)"
  shows "emeasure M (main_part M (\<Union>i. (S i))) = emeasure M (\<Union>i. main_part M (S i))"
proof -
  have S: "\<And>i. S i \<in> sets (completion M)" using assms by auto
  then have UN: "(\<Union>i. S i) \<in> sets (completion M)" by auto
  have "\<forall>i. \<exists>N. N \<in> null_sets M \<and> null_part M (S i) \<subseteq> N"
    using null_part[OF S] by auto
  then obtain N where N: "\<forall>x. N x \<in> null_sets M \<and> null_part M (S x) \<subseteq> N x" by metis
  then have UN_N: "(\<Union>i. N i) \<in> null_sets M" by (intro null_sets_UN) auto
  from S have "(\<Union>i. S i) \<in> sets (completion M)" by auto
  from null_part[OF this] obtain N' where N': "N' \<in> null_sets M \<and> null_part M (\<Union> (range S)) \<subseteq> N'" ..
  let ?N = "(\<Union>i. N i) \<union> N'"
  have null_set: "?N \<in> null_sets M" using N' UN_N by (intro null_sets.Un) auto
  have "main_part M (\<Union>i. S i) \<union> ?N = (main_part M (\<Union>i. S i) \<union> null_part M (\<Union>i. S i)) \<union> ?N"
    using N' by auto
  also have "\<dots> = (\<Union>i. main_part M (S i) \<union> null_part M (S i)) \<union> ?N"
    unfolding main_part_null_part_Un[OF S] main_part_null_part_Un[OF UN] by auto
  also have "\<dots> = (\<Union>i. main_part M (S i)) \<union> ?N"
    using N by auto
  finally have *: "main_part M (\<Union>i. S i) \<union> ?N = (\<Union>i. main_part M (S i)) \<union> ?N" .
  have "emeasure M (main_part M (\<Union>i. S i)) = emeasure M (main_part M (\<Union>i. S i) \<union> ?N)"
    using null_set UN by (intro emeasure_Un_null_set[symmetric]) auto
  also have "\<dots> = emeasure M ((\<Union>i. main_part M (S i)) \<union> ?N)"
    unfolding * ..
  also have "\<dots> = emeasure M (\<Union>i. main_part M (S i))"
    using null_set S by (intro emeasure_Un_null_set) auto
  finally show ?thesis .
qed

lemma\<^marker>\<open>tag important\<close> emeasure_completion[simp]:
  assumes S: "S \<in> sets (completion M)"
  shows "emeasure (completion M) S = emeasure M (main_part M S)"
proof (subst emeasure_measure_of[OF completion_def completion_into_space])
  let ?\<mu> = "emeasure M \<circ> main_part M"
  show "S \<in> sets (completion M)" "?\<mu> S = emeasure M (main_part M S) " using S by simp_all
  show "positive (sets (completion M)) ?\<mu>"
    by (simp add: positive_def)
  show "countably_additive (sets (completion M)) ?\<mu>"
  proof (intro countably_additiveI)
    fix A :: "nat \<Rightarrow> 'a set" assume A: "range A \<subseteq> sets (completion M)" "disjoint_family A"
    have "disjoint_family (\<lambda>i. main_part M (A i))"
    proof (intro disjoint_family_on_bisimulation[OF A(2)])
      fix n m assume "A n \<inter> A m = {}"
      then have "(main_part M (A n) \<union> null_part M (A n)) \<inter> (main_part M (A m) \<union> null_part M (A m)) = {}"
        using A by (subst (1 2) main_part_null_part_Un) auto
      then show "main_part M (A n) \<inter> main_part M (A m) = {}" by auto
    qed
    then have "(\<Sum>n. emeasure M (main_part M (A n))) = emeasure M (\<Union>i. main_part M (A i))"
      using A by (auto intro!: suminf_emeasure)
    then show "(\<Sum>n. ?\<mu> (A n)) = ?\<mu> (\<Union>(A ` UNIV))"
      by (simp add: completion_def emeasure_main_part_UN[OF A(1)])
  qed
qed

lemma measure_completion[simp]: "S \<in> sets M \<Longrightarrow> measure (completion M) S = measure M S"
  unfolding measure_def by auto

lemma emeasure_completion_UN:
  "range S \<subseteq> sets (completion M) \<Longrightarrow>
    emeasure (completion M) (\<Union>i::nat. (S i)) = emeasure M (\<Union>i. main_part M (S i))"
  by (subst emeasure_completion) (auto simp add: emeasure_main_part_UN)

lemma emeasure_completion_Un:
  assumes S: "S \<in> sets (completion M)" and T: "T \<in> sets (completion M)"
  shows "emeasure (completion M) (S \<union> T) = emeasure M (main_part M S \<union> main_part M T)"
proof (subst emeasure_completion)
  have UN: "(\<Union>i. binary (main_part M S) (main_part M T) i) = (\<Union>i. main_part M (binary S T i))"
    unfolding binary_def by (auto split: if_split_asm)
  show "emeasure M (main_part M (S \<union> T)) = emeasure M (main_part M S \<union> main_part M T)"
    using emeasure_main_part_UN[of "binary S T" M] assms
    by (simp add: range_binary_eq, simp add: Un_range_binary UN)
qed (auto intro: S T)

lemma sets_completionI_sub:
  assumes N: "N' \<in> null_sets M" "N \<subseteq> N'"
  shows "N \<in> sets (completion M)"
  using assms by (intro sets_completionI[of _ "{}" N N']) auto

lemma completion_ex_simple_function:
  assumes f: "simple_function (completion M) f"
  shows "\<exists>f'. simple_function M f' \<and> (AE x in M. f x = f' x)"
proof -
  let ?F = "\<lambda>x. f -` {x} \<inter> space M"
  have F: "\<And>x. ?F x \<in> sets (completion M)" and fin: "finite (f`space M)"
    using simple_functionD[OF f] simple_functionD[OF f] by simp_all
  have "\<forall>x. \<exists>N. N \<in> null_sets M \<and> null_part M (?F x) \<subseteq> N"
    using F null_part by auto
  from choice[OF this] obtain N where
    N: "\<And>x. null_part M (?F x) \<subseteq> N x" "\<And>x. N x \<in> null_sets M" by auto
  let ?N = "\<Union>x\<in>f`space M. N x"
  let ?f' = "\<lambda>x. if x \<in> ?N then undefined else f x"
  have sets: "?N \<in> null_sets M" using N fin by (intro null_sets.finite_UN) auto
  show ?thesis unfolding simple_function_def
  proof (safe intro!: exI[of _ ?f'])
    have "?f' ` space M \<subseteq> f`space M \<union> {undefined}" by auto
    from finite_subset[OF this] simple_functionD(1)[OF f]
    show "finite (?f' ` space M)" by auto
  next
    fix x assume "x \<in> space M"
    have "?f' -` {?f' x} \<inter> space M =
      (if x \<in> ?N then ?F undefined \<union> ?N
       else if f x = undefined then ?F (f x) \<union> ?N
       else ?F (f x) - ?N)"
      using N(2) sets.sets_into_space by (auto split: if_split_asm simp: null_sets_def)
    moreover { fix y have "?F y \<union> ?N \<in> sets M"
      proof cases
        assume y: "y \<in> f`space M"
        have "?F y \<union> ?N = (main_part M (?F y) \<union> null_part M (?F y)) \<union> ?N"
          using main_part_null_part_Un[OF F] by auto
        also have "\<dots> = main_part M (?F y) \<union> ?N"
          using y N by auto
        finally show ?thesis
          using F sets by auto
      next
        assume "y \<notin> f`space M" then have "?F y = {}" by auto
        then show ?thesis using sets by auto
      qed }
    moreover {
      have "?F (f x) - ?N = main_part M (?F (f x)) \<union> null_part M (?F (f x)) - ?N"
        using main_part_null_part_Un[OF F] by auto
      also have "\<dots> = main_part M (?F (f x)) - ?N"
        using N \<open>x \<in> space M\<close> by auto
      finally have "?F (f x) - ?N \<in> sets M"
        using F sets by auto }
    ultimately show "?f' -` {?f' x} \<inter> space M \<in> sets M" by auto
  next
    show "AE x in M. f x = ?f' x"
      by (rule AE_I', rule sets) auto
  qed
qed

lemma\<^marker>\<open>tag important\<close> completion_ex_borel_measurable:
  fixes g :: "'a \<Rightarrow> ennreal"
  assumes g: "g \<in> borel_measurable (completion M)"
  shows "\<exists>g'\<in>borel_measurable M. (AE x in M. g x = g' x)"
proof -
  obtain f :: "nat \<Rightarrow> 'a \<Rightarrow> ennreal"
    where *: "\<And>i. simple_function (completion M) (f i)"
      and **: "\<And>x. (SUP i. f i x) = g x"
    using g[THEN borel_measurable_implies_simple_function_sequence'] by metis
  from *[THEN completion_ex_simple_function]
  have "\<forall>i. \<exists>f'. simple_function M f' \<and> (AE x in M. f i x = f' x)" ..
  then obtain f'
    where sf: "\<And>i. simple_function M (f' i)"
      and AE: "\<forall>i. AE x in M. f i x = f' i x"
    by metis
  show ?thesis
  proof (intro bexI)
    from AE[unfolded AE_all_countable[symmetric]]
    show "AE x in M. g x = (SUP i. f' i x)" (is "AE x in M. g x = ?f x")
    proof (elim AE_mp, safe intro!: AE_I2)
      fix x assume eq: "\<forall>i. f i x = f' i x"
      have "g x = (SUP i. f i x)" by (auto simp: ** split: split_max)
      with eq show "g x = ?f x" by auto
    qed
    show "?f \<in> borel_measurable M"
      using sf[THEN borel_measurable_simple_function] by auto
  qed
qed

lemma null_sets_completionI: "N \<in> null_sets M \<Longrightarrow> N \<in> null_sets (completion M)"
  by (auto simp: null_sets_def)

lemma AE_completion: "(AE x in M. P x) \<Longrightarrow> (AE x in completion M. P x)"
  unfolding eventually_ae_filter by (auto intro: null_sets_completionI)

lemma null_sets_completion_iff: "N \<in> sets M \<Longrightarrow> N \<in> null_sets (completion M) \<longleftrightarrow> N \<in> null_sets M"
  by (auto simp: null_sets_def)

lemma sets_completion_AE: "(AE x in M. \<not> P x) \<Longrightarrow> Measurable.pred (completion M) P"
  unfolding pred_def sets_completion eventually_ae_filter
  by auto

lemma null_sets_completion_iff2:
  "A \<in> null_sets (completion M) \<longleftrightarrow> (\<exists>N'\<in>null_sets M. A \<subseteq> N')"
proof safe
  assume "A \<in> null_sets (completion M)"
  then have A: "A \<in> sets (completion M)" and "main_part M A \<in> null_sets M"
    by (auto simp: null_sets_def)
  moreover obtain N where "N \<in> null_sets M" "null_part M A \<subseteq> N"
    using null_part[OF A] by auto
  ultimately show "\<exists>N'\<in>null_sets M. A \<subseteq> N'"
  proof (intro bexI)
    show "A \<subseteq> N \<union> main_part M A"
      using \<open>null_part M A \<subseteq> N\<close> by (subst main_part_null_part_Un[OF A, symmetric]) auto
  qed auto
next
  fix N assume "N \<in> null_sets M" "A \<subseteq> N"
  then have "A \<in> sets (completion M)" and N: "N \<in> sets M" "A \<subseteq> N" "emeasure M N = 0"
    by (auto intro: null_sets_completion)
  moreover have "emeasure (completion M) A = 0"
    using N by (intro emeasure_eq_0[of N _ A]) auto
  ultimately show "A \<in> null_sets (completion M)"
    by auto
qed

lemma null_sets_completion_subset:
  "B \<subseteq> A \<Longrightarrow> A \<in> null_sets (completion M) \<Longrightarrow> B \<in> null_sets (completion M)"
  unfolding null_sets_completion_iff2 by auto

interpretation completion: complete_measure "completion M" for M
proof
  show "B \<subseteq> A \<Longrightarrow> A \<in> null_sets (completion M) \<Longrightarrow> B \<in> sets (completion M)" for B A
    using null_sets_completion_subset[of B A M] by (simp add: null_sets_def)
qed

lemma null_sets_restrict_space:
  "\<Omega> \<in> sets M \<Longrightarrow> A \<in> null_sets (restrict_space M \<Omega>) \<longleftrightarrow> A \<subseteq> \<Omega> \<and> A \<in> null_sets M"
  by (auto simp: null_sets_def emeasure_restrict_space sets_restrict_space)

lemma completion_ex_borel_measurable_real:
  fixes g :: "'a \<Rightarrow> real"
  assumes g: "g \<in> borel_measurable (completion M)"
  shows "\<exists>g'\<in>borel_measurable M. (AE x in M. g x = g' x)"
proof -
  have "(\<lambda>x. ennreal (g x)) \<in> completion M \<rightarrow>\<^sub>M borel" "(\<lambda>x. ennreal (- g x)) \<in> completion M \<rightarrow>\<^sub>M borel"
    using g by auto
  from this[THEN completion_ex_borel_measurable]
  obtain pf nf :: "'a \<Rightarrow> ennreal"
    where [measurable]: "nf \<in> M \<rightarrow>\<^sub>M borel" "pf \<in> M \<rightarrow>\<^sub>M borel"
      and ae: "AE x in M. pf x = ennreal (g x)" "AE x in M. nf x = ennreal (- g x)"
    by (auto simp: eq_commute)
  then have "AE x in M. pf x = ennreal (g x) \<and> nf x = ennreal (- g x)"
    by auto
  then obtain N where "N \<in> null_sets M" "{x\<in>space M. pf x \<noteq> ennreal (g x) \<and> nf x \<noteq> ennreal (- g x)} \<subseteq> N"
    by (auto elim!: AE_E)
  show ?thesis
  proof
    let ?F = "\<lambda>x. indicator (space M - N) x * (enn2real (pf x) - enn2real (nf x))"
    show "?F \<in> M \<rightarrow>\<^sub>M borel"
      using \<open>N \<in> null_sets M\<close> by auto
    show "AE x in M. g x = ?F x"
      using \<open>N \<in> null_sets M\<close>[THEN AE_not_in] ae AE_space
      apply eventually_elim
      subgoal for x
        by (cases "0::real" "g x" rule: linorder_le_cases) (auto simp: ennreal_neg)
      done
  qed
qed

lemma simple_function_completion: "simple_function M f \<Longrightarrow> simple_function (completion M) f"
  by (simp add: simple_function_def)

lemma simple_integral_completion:
  "simple_function M f \<Longrightarrow> simple_integral (completion M) f = simple_integral M f"
  unfolding simple_integral_def by simp

lemma nn_integral_completion: "nn_integral (completion M) f = nn_integral M f"
  unfolding nn_integral_def
proof (safe intro!: SUP_eq)
  fix s assume s: "simple_function (completion M) s" and "s \<le> f"
  then obtain s' where s': "simple_function M s'" "AE x in M. s x = s' x"
    by (auto dest: completion_ex_simple_function)
  then obtain N where N: "N \<in> null_sets M" "{x\<in>space M. s x \<noteq> s' x} \<subseteq> N"
    by (auto elim!: AE_E)
  then have ae_N: "AE x in M. (s x \<noteq> s' x \<longrightarrow> x \<in> N) \<and> x \<notin> N"
    by (auto dest: AE_not_in)
  define s'' where "s'' x = (if x \<in> N then 0 else s x)" for x
  then have ae_s_eq_s'': "AE x in completion M. s x = s'' x"
    using s' ae_N by (intro AE_completion) auto
  have s'': "simple_function M s''"
  proof (subst simple_function_cong)
    show "t \<in> space M \<Longrightarrow> s'' t = (if t \<in> N then 0 else s' t)" for t
      using N by (auto simp: s''_def dest: sets.sets_into_space)
    show "simple_function M (\<lambda>t. if t \<in> N then 0 else s' t)"
      unfolding s''_def[abs_def] using N by (auto intro!: simple_function_If s')
  qed

  show "\<exists>j\<in>{g. simple_function M g \<and> g \<le> f}. integral\<^sup>S (completion M) s \<le> integral\<^sup>S M j"
  proof (safe intro!: bexI[of _ s''])
    have "integral\<^sup>S (completion M) s = integral\<^sup>S (completion M) s''"
      by (intro simple_integral_cong_AE s simple_function_completion s'' ae_s_eq_s'')
    then show "integral\<^sup>S (completion M) s \<le> integral\<^sup>S M s''"
      using s'' by (simp add: simple_integral_completion)
    from \<open>s \<le> f\<close> show "s'' \<le> f"
      unfolding s''_def le_fun_def by auto
  qed fact
next
  fix s assume "simple_function M s" "s \<le> f"
  then show "\<exists>j\<in>{g. simple_function (completion M) g \<and> g \<le> f}. integral\<^sup>S M s \<le> integral\<^sup>S (completion M) j"
    by (intro bexI[of _ s]) (auto simp: simple_integral_completion simple_function_completion)
qed

lemma integrable_completion:
  fixes f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
  shows "f \<in> M \<rightarrow>\<^sub>M borel \<Longrightarrow> integrable (completion M) f \<longleftrightarrow> integrable M f"
  by (rule integrable_subalgebra[symmetric]) auto

lemma integral_completion:
  fixes f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
  assumes f: "f \<in> M \<rightarrow>\<^sub>M borel" shows "integral\<^sup>L (completion M) f = integral\<^sup>L M f"
  by (rule integral_subalgebra[symmetric]) (auto intro: f)

locale\<^marker>\<open>tag important\<close> semifinite_measure =
  fixes M :: "'a measure"
  assumes semifinite:
    "\<And>A. A \<in> sets M \<Longrightarrow> emeasure M A = \<infinity> \<Longrightarrow> \<exists>B\<in>sets M. B \<subseteq> A \<and> emeasure M B < \<infinity>"

locale\<^marker>\<open>tag important\<close> locally_determined_measure = semifinite_measure +
  assumes locally_determined:
    "\<And>A. A \<subseteq> space M \<Longrightarrow> (\<And>B. B \<in> sets M \<Longrightarrow> emeasure M B < \<infinity> \<Longrightarrow> A \<inter> B \<in> sets M) \<Longrightarrow> A \<in> sets M"

locale\<^marker>\<open>tag important\<close> cld_measure =
  complete_measure M + locally_determined_measure M for M :: "'a measure"

definition\<^marker>\<open>tag important\<close> outer_measure_of :: "'a measure \<Rightarrow> 'a set \<Rightarrow> ennreal"
  where "outer_measure_of M A = (INF B \<in> {B\<in>sets M. A \<subseteq> B}. emeasure M B)"

lemma outer_measure_of_eq[simp]: "A \<in> sets M \<Longrightarrow> outer_measure_of M A = emeasure M A"
  by (auto simp: outer_measure_of_def intro!: INF_eqI emeasure_mono)

lemma outer_measure_of_mono: "A \<subseteq> B \<Longrightarrow> outer_measure_of M A \<le> outer_measure_of M B"
  unfolding outer_measure_of_def by (intro INF_superset_mono) auto

lemma outer_measure_of_attain:
  assumes "A \<subseteq> space M"
  shows "\<exists>E\<in>sets M. A \<subseteq> E \<and> outer_measure_of M A = emeasure M E"
proof -
  have "emeasure M ` {B \<in> sets M. A \<subseteq> B} \<noteq> {}"
    using \<open>A \<subseteq> space M\<close> by auto
  from ennreal_Inf_countable_INF[OF this]
  obtain f
    where f: "range f \<subseteq> emeasure M ` {B \<in> sets M. A \<subseteq> B}" "decseq f"
      and "outer_measure_of M A = (INF i. f i)"
    unfolding outer_measure_of_def by auto
  have "\<exists>E. \<forall>n. (E n \<in> sets M \<and> A \<subseteq> E n \<and> emeasure M (E n) \<le> f n) \<and> E (Suc n) \<subseteq> E n"
  proof (rule dependent_nat_choice)
    show "\<exists>x. x \<in> sets M \<and> A \<subseteq> x \<and> emeasure M x \<le> f 0"
      using f(1) by (fastforce simp: image_subset_iff image_iff intro: eq_refl[OF sym])
  next
    fix E n assume "E \<in> sets M \<and> A \<subseteq> E \<and> emeasure M E \<le> f n"
    moreover obtain F where "F \<in> sets M" "A \<subseteq> F" "f (Suc n) = emeasure M F"
      using f(1) by (auto simp: image_subset_iff image_iff)
    ultimately show "\<exists>y. (y \<in> sets M \<and> A \<subseteq> y \<and> emeasure M y \<le> f (Suc n)) \<and> y \<subseteq> E"
      by (auto intro!: exI[of _ "F \<inter> E"] emeasure_mono)
  qed
  then obtain E
    where [simp]: "\<And>n. E n \<in> sets M"
      and "\<And>n. A \<subseteq> E n"
      and le_f: "\<And>n. emeasure M (E n) \<le> f n"
      and "decseq E"
    by (auto simp: decseq_Suc_iff)
  show ?thesis
  proof cases
    assume fin: "\<exists>i. emeasure M (E i) < \<infinity>"
    show ?thesis
    proof (intro bexI[of _ "\<Inter>i. E i"] conjI)
      show "A \<subseteq> (\<Inter>i. E i)" "(\<Inter>i. E i) \<in> sets M"
        using \<open>\<And>n. A \<subseteq> E n\<close> by auto

      have " (INF i. emeasure M (E i)) \<le> outer_measure_of M A"
        unfolding \<open>outer_measure_of M A = (INF n. f n)\<close>
        by (intro INF_superset_mono le_f) auto
      moreover have "outer_measure_of M A \<le> (INF i. outer_measure_of M (E i))"
        by (intro INF_greatest outer_measure_of_mono \<open>\<And>n. A \<subseteq> E n\<close>)
      ultimately have "outer_measure_of M A = (INF i. emeasure M (E i))"
        by auto
      also have "\<dots> = emeasure M (\<Inter>i. E i)"
        using fin by (intro INF_emeasure_decseq' \<open>decseq E\<close>) (auto simp: less_top)
      finally show "outer_measure_of M A = emeasure M (\<Inter>i. E i)" .
    qed
  next
    assume "\<nexists>i. emeasure M (E i) < \<infinity>"
    then have "f n = \<infinity>" for n
      using le_f by (auto simp: not_less top_unique)
    moreover have "\<exists>E\<in>sets M. A \<subseteq> E \<and> f 0 = emeasure M E"
      using f by auto
    ultimately show ?thesis
      unfolding \<open>outer_measure_of M A = (INF n. f n)\<close> by simp
  qed
qed

lemma SUP_outer_measure_of_incseq:
  assumes A: "\<And>n. A n \<subseteq> space M" and "incseq A"
  shows "(SUP n. outer_measure_of M (A n)) = outer_measure_of M (\<Union>i. A i)"
proof (rule antisym)
  obtain E
    where E: "\<And>n. E n \<in> sets M" "\<And>n. A n \<subseteq> E n" "\<And>n. outer_measure_of M (A n) = emeasure M (E n)"
    using outer_measure_of_attain[OF A] by metis

  define F where "F n = (\<Inter>i\<in>{n ..}. E i)" for n
  with E have F: "incseq F" "\<And>n. F n \<in> sets M"
    by (auto simp: incseq_def)
  have "A n \<subseteq> F n" for n
    using incseqD[OF \<open>incseq A\<close>, of n] \<open>\<And>n. A n \<subseteq> E n\<close> by (auto simp: F_def)

  have eq: "outer_measure_of M (A n) = outer_measure_of M (F n)" for n
  proof (intro antisym)
    have "outer_measure_of M (F n) \<le> outer_measure_of M (E n)"
      by (intro outer_measure_of_mono) (auto simp add: F_def)
    with E show "outer_measure_of M (F n) \<le> outer_measure_of M (A n)"
      by auto
    show "outer_measure_of M (A n) \<le> outer_measure_of M (F n)"
      by (intro outer_measure_of_mono \<open>A n \<subseteq> F n\<close>)
  qed

  have "outer_measure_of M (\<Union>n. A n) \<le> outer_measure_of M (\<Union>n. F n)"
    using \<open>\<And>n. A n \<subseteq> F n\<close> by (intro outer_measure_of_mono) auto
  also have "\<dots> = (SUP n. emeasure M (F n))"
    using F by (simp add: SUP_emeasure_incseq subset_eq)
  finally show "outer_measure_of M (\<Union>n. A n) \<le> (SUP n. outer_measure_of M (A n))"
    by (simp add: eq F)
qed (auto intro: SUP_least outer_measure_of_mono)

definition\<^marker>\<open>tag important\<close> measurable_envelope :: "'a measure \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool"
  where "measurable_envelope M A E \<longleftrightarrow>
    (A \<subseteq> E \<and> E \<in> sets M \<and> (\<forall>F\<in>sets M. emeasure M (F \<inter> E) = outer_measure_of M (F \<inter> A)))"

lemma measurable_envelopeD:
  assumes "measurable_envelope M A E"
  shows "A \<subseteq> E"
    and "E \<in> sets M"
    and "\<And>F. F \<in> sets M \<Longrightarrow> emeasure M (F \<inter> E) = outer_measure_of M (F \<inter> A)"
    and "A \<subseteq> space M"
  using assms sets.sets_into_space[of E] by (auto simp: measurable_envelope_def)

lemma measurable_envelopeD1:
  assumes E: "measurable_envelope M A E" and F: "F \<in> sets M" "F \<subseteq> E - A"
  shows "emeasure M F = 0"
proof -
  have "emeasure M F = emeasure M (F \<inter> E)"
    using F by (intro arg_cong2[where f=emeasure]) auto
  also have "\<dots> = outer_measure_of M (F \<inter> A)"
    using measurable_envelopeD[OF E] \<open>F \<in> sets M\<close> by (auto simp: measurable_envelope_def)
  also have "\<dots> = outer_measure_of M {}"
    using \<open>F \<subseteq> E - A\<close> by (intro arg_cong2[where f=outer_measure_of]) auto
  finally show "emeasure M F = 0"
    by simp
qed

lemma measurable_envelope_eq1:
  assumes "A \<subseteq> E" "E \<in> sets M"
  shows "measurable_envelope M A E \<longleftrightarrow> (\<forall>F\<in>sets M. F \<subseteq> E - A \<longrightarrow> emeasure M F = 0)"
proof safe
  assume *: "\<forall>F\<in>sets M. F \<subseteq> E - A \<longrightarrow> emeasure M F = 0"
  show "measurable_envelope M A E"
    unfolding measurable_envelope_def
  proof (rule ccontr, auto simp add: \<open>E \<in> sets M\<close> \<open>A \<subseteq> E\<close>)
    fix F assume "F \<in> sets M" "emeasure M (F \<inter> E) \<noteq> outer_measure_of M (F \<inter> A)"
    then have "outer_measure_of M (F \<inter> A) < emeasure M (F \<inter> E)"
      using outer_measure_of_mono[of "F \<inter> A" "F \<inter> E" M] \<open>A \<subseteq> E\<close> \<open>E \<in> sets M\<close> by (auto simp: less_le)
    then obtain G where G: "G \<in> sets M" "F \<inter> A \<subseteq> G" and less: "emeasure M G < emeasure M (E \<inter> F)"
      unfolding outer_measure_of_def INF_less_iff by (auto simp: ac_simps)
    have le: "emeasure M (G \<inter> E \<inter> F) \<le> emeasure M G"
      using \<open>E \<in> sets M\<close> \<open>G \<in> sets M\<close> \<open>F \<in> sets M\<close> by (auto intro!: emeasure_mono)

    from G have "E \<inter> F - G \<in> sets M" "E \<inter> F - G \<subseteq> E - A"
      using \<open>F \<in> sets M\<close> \<open>E \<in> sets M\<close> by auto
    with * have "0 = emeasure M (E \<inter> F - G)"
      by auto
    also have "E \<inter> F - G = E \<inter> F - (G \<inter> E \<inter> F)"
      by auto
    also have "emeasure M (E \<inter> F - (G \<inter> E \<inter> F)) = emeasure M (E \<inter> F) - emeasure M (G \<inter> E \<inter> F)"
      using \<open>E \<in> sets M\<close> \<open>F \<in> sets M\<close> le less G by (intro emeasure_Diff) (auto simp: top_unique)
    also have "\<dots> > 0"
      using le less by (intro diff_gr0_ennreal) auto
    finally show False by auto
  qed
qed (rule measurable_envelopeD1)

lemma measurable_envelopeD2:
  assumes E: "measurable_envelope M A E" shows "emeasure M E = outer_measure_of M A"
proof -
  from \<open>measurable_envelope M A E\<close> have "emeasure M (E \<inter> E) = outer_measure_of M (E \<inter> A)"
    by (auto simp: measurable_envelope_def)
  with measurable_envelopeD[OF E] show "emeasure M E = outer_measure_of M A"
    by (auto simp: Int_absorb1)
qed

lemma\<^marker>\<open>tag important\<close> measurable_envelope_eq2:
  assumes "A \<subseteq> E" "E \<in> sets M" "emeasure M E < \<infinity>"
  shows "measurable_envelope M A E \<longleftrightarrow> (emeasure M E = outer_measure_of M A)"
proof safe
  assume *: "emeasure M E = outer_measure_of M A"
  show "measurable_envelope M A E"
    unfolding measurable_envelope_eq1[OF \<open>A \<subseteq> E\<close> \<open>E \<in> sets M\<close>]
  proof (intro conjI ballI impI assms)
    fix F assume F: "F \<in> sets M" "F \<subseteq> E - A"
    with \<open>E \<in> sets M\<close> have le: "emeasure M F \<le> emeasure M  E"
      by (intro emeasure_mono) auto
    from F \<open>A \<subseteq> E\<close> have "outer_measure_of M A \<le> outer_measure_of M (E - F)"
      by (intro outer_measure_of_mono) auto
    then have "emeasure M E - 0 \<le> emeasure M (E - F)"
      using * \<open>E \<in> sets M\<close> \<open>F \<in> sets M\<close> by simp
    also have "\<dots> = emeasure M E - emeasure M F"
      using \<open>E \<in> sets M\<close> \<open>emeasure M E < \<infinity>\<close> F le by (intro emeasure_Diff) (auto simp: top_unique)
    finally show "emeasure M F = 0"
      using ennreal_mono_minus_cancel[of "emeasure M E" 0 "emeasure M F"] le assms by auto
  qed
qed (auto intro: measurable_envelopeD2)

lemma measurable_envelopeI_countable:
  fixes A :: "nat \<Rightarrow> 'a set"
  assumes E: "\<And>n. measurable_envelope M (A n) (E n)"
  shows "measurable_envelope M (\<Union>n. A n) (\<Union>n. E n)"
proof (subst measurable_envelope_eq1)
  show "(\<Union>n. A n) \<subseteq> (\<Union>n. E n)" "(\<Union>n. E n) \<in> sets M"
    using measurable_envelopeD(1,2)[OF E] by auto
  show "\<forall>F\<in>sets M. F \<subseteq> (\<Union>n. E n) - (\<Union>n. A n) \<longrightarrow> emeasure M F = 0"
  proof safe
    fix F assume F: "F \<in> sets M" "F \<subseteq> (\<Union>n. E n) - (\<Union>n. A n)"
    then have "F \<inter> E n \<in> sets M" "F \<inter> E n \<subseteq> E n - A n" "F \<subseteq> (\<Union>n. E n)" for n
      using measurable_envelopeD(1,2)[OF E] by auto
    then have "emeasure M (\<Union>n. F \<inter> E n) = 0"
      by (intro emeasure_UN_eq_0 measurable_envelopeD1[OF E]) auto
    then show "emeasure M F = 0"
      using \<open>F \<subseteq> (\<Union>n. E n)\<close> by (auto simp: Int_absorb2)
  qed
qed

lemma measurable_envelopeI_countable_cover:
  fixes A and C :: "nat \<Rightarrow> 'a set"
  assumes C: "A \<subseteq> (\<Union>n. C n)" "\<And>n. C n \<in> sets M" "\<And>n. emeasure M (C n) < \<infinity>"
  shows "\<exists>E\<subseteq>(\<Union>n. C n). measurable_envelope M A E"
proof -
  have "A \<inter> C n \<subseteq> space M" for n
    using \<open>C n \<in> sets M\<close> by (auto dest: sets.sets_into_space)
  then have "\<forall>n. \<exists>E\<in>sets M. A \<inter> C n \<subseteq> E \<and> outer_measure_of M (A \<inter> C n) = emeasure M E"
    using outer_measure_of_attain[of "A \<inter> C n" M for n] by auto
  then obtain E
    where E: "\<And>n. E n \<in> sets M" "\<And>n. A \<inter> C n \<subseteq> E n"
      and eq: "\<And>n. outer_measure_of M (A \<inter> C n) = emeasure M (E n)"
    by metis

  have "outer_measure_of M (A \<inter> C n) \<le> outer_measure_of M (E n \<inter> C n)" for n
    using E by (intro outer_measure_of_mono) auto
  moreover have "outer_measure_of M (E n \<inter> C n) \<le> outer_measure_of M (E n)" for n
    by (intro outer_measure_of_mono) auto
  ultimately have eq: "outer_measure_of M (A \<inter> C n) = emeasure M (E n \<inter> C n)" for n
    using E C by (intro antisym) (auto simp: eq)

  { fix n
    have "outer_measure_of M (A \<inter> C n) \<le> outer_measure_of M (C n)"
      by (intro outer_measure_of_mono) simp
    also have "\<dots> < \<infinity>"
      using assms by auto
    finally have "emeasure M (E n \<inter> C n) < \<infinity>"
      using eq by simp }
  then have "measurable_envelope M (\<Union>n. A \<inter> C n) (\<Union>n. E n \<inter> C n)"
    using E C by (intro measurable_envelopeI_countable measurable_envelope_eq2[THEN iffD2]) (auto simp: eq)
  with \<open>A \<subseteq> (\<Union>n. C n)\<close> show ?thesis
    by (intro exI[of _ "(\<Union>n. E n \<inter> C n)"]) (auto simp add: Int_absorb2)
qed

lemma (in complete_measure) complete_sets_sandwich:
  assumes [measurable]: "A \<in> sets M" "C \<in> sets M" and subset: "A \<subseteq> B" "B \<subseteq> C"
    and measure: "emeasure M A = emeasure M C" "emeasure M A < \<infinity>"
  shows "B \<in> sets M"
proof -
  have "B - A \<in> sets M"
  proof (rule complete)
    show "B - A \<subseteq> C - A"
      using subset by auto
    show "C - A \<in> null_sets M"
      using measure subset by(simp add: emeasure_Diff null_setsI)
  qed
  then have "A \<union> (B - A) \<in> sets M"
    by measurable
  also have "A \<union> (B - A) = B"
    using \<open>A \<subseteq> B\<close> by auto
  finally show ?thesis .
qed

lemma (in complete_measure) complete_sets_sandwich_fmeasurable:
  assumes [measurable]: "A \<in> fmeasurable M" "C \<in> fmeasurable M" and subset: "A \<subseteq> B" "B \<subseteq> C"
    and measure: "measure M A = measure M C"
  shows "B \<in> fmeasurable M"
proof (rule fmeasurableI2)
  show "B \<subseteq> C" "C \<in> fmeasurable M" by fact+
  show "B \<in> sets M"
  proof (rule complete_sets_sandwich)
    show "A \<in> sets M" "C \<in> sets M" "A \<subseteq> B" "B \<subseteq> C"
      using assms by auto
    show "emeasure M A < \<infinity>"
      using \<open>A \<in> fmeasurable M\<close> by (auto simp: fmeasurable_def)
    show "emeasure M A = emeasure M C"
      using assms by (simp add: emeasure_eq_measure2)
  qed
qed

lemma AE_completion_iff: "(AE x in completion M. P x) \<longleftrightarrow> (AE x in M. P x)"
proof
  assume "AE x in completion M. P x"
  then obtain N where "N \<in> null_sets (completion M)" and P: "{x\<in>space M. \<not> P x} \<subseteq> N"
    unfolding eventually_ae_filter by auto
  then obtain N' where N': "N' \<in> null_sets M" and "N \<subseteq> N'"
    unfolding null_sets_completion_iff2 by auto
  from P \<open>N \<subseteq> N'\<close> have "{x\<in>space M. \<not> P x} \<subseteq> N'"
    by auto
  with N' show "AE x in M. P x"
    unfolding eventually_ae_filter by auto
qed (rule AE_completion)

lemma null_part_null_sets: "S \<in> completion M \<Longrightarrow> null_part M S \<in> null_sets (completion M)"
  by (auto dest!: null_part intro: null_sets_completionI null_sets_completion_subset)

lemma AE_notin_null_part: "S \<in> completion M \<Longrightarrow> (AE x in M. x \<notin> null_part M S)"
  by (auto dest!: null_part_null_sets AE_not_in simp: AE_completion_iff)

lemma completion_upper:
  assumes A: "A \<in> sets (completion M)"
  shows "\<exists>A'\<in>sets M. A \<subseteq> A' \<and> emeasure (completion M) A = emeasure M A'"
proof -
  from AE_notin_null_part[OF A] obtain N where N: "N \<in> null_sets M" "null_part M A \<subseteq> N"
    unfolding eventually_ae_filter using null_part_null_sets[OF A, THEN null_setsD2, THEN sets.sets_into_space] by auto
  show ?thesis
  proof (intro bexI conjI)
    show "A \<subseteq> main_part M A \<union> N"
      using \<open>null_part M A \<subseteq> N\<close> by (subst main_part_null_part_Un[symmetric, OF A]) auto
    show "emeasure (completion M) A = emeasure M (main_part M A \<union> N)"
      using A \<open>N \<in> null_sets M\<close> by (simp add: emeasure_Un_null_set)
  qed (use A N in auto)
qed

lemma AE_in_main_part:
  assumes A: "A \<in> completion M" shows "AE x in M. x \<in> main_part M A \<longleftrightarrow> x \<in> A"
  using AE_notin_null_part[OF A]
  by (subst (2) main_part_null_part_Un[symmetric, OF A]) auto

lemma completion_density_eq:
  assumes ae: "AE x in M. 0 < f x" and [measurable]: "f \<in> M \<rightarrow>\<^sub>M borel"
  shows "completion (density M f) = density (completion M) f"
proof (intro measure_eqI)
  have "N' \<in> sets M \<and> (AE x\<in>N' in M. f x = 0) \<longleftrightarrow> N' \<in> null_sets M" for N'
  proof safe
    assume N': "N' \<in> sets M" and ae_N': "AE x\<in>N' in M. f x = 0"
    from ae_N' ae have "AE x in M. x \<notin> N'"
      by eventually_elim auto
    then show "N' \<in> null_sets M"
      using N' by (simp add: AE_iff_null_sets)
  next
    assume N': "N' \<in> null_sets M" then show "N' \<in> sets M" "AE x\<in>N' in M. f x = 0"
      using ae AE_not_in[OF N'] by (auto simp: less_le)
  qed
  then show sets_eq: "sets (completion (density M f)) = sets (density (completion M) f)"
    by (simp add: sets_completion null_sets_density_iff)

  fix A assume A: \<open>A \<in> completion (density M f)\<close>
  moreover
  have "A \<in> completion M"
    using A unfolding sets_eq by simp
  moreover
  have "main_part (density M f) A \<in> M"
    using A main_part_sets[of A "density M f"] unfolding sets_density sets_eq by simp
  moreover have "AE x in M. x \<in> main_part (density M f) A \<longleftrightarrow> x \<in> A"
    using AE_in_main_part[OF \<open>A \<in> completion (density M f)\<close>] ae by (auto simp add: AE_density)
  ultimately show "emeasure (completion (density M f)) A = emeasure (density (completion M) f) A"
    by (auto simp add: emeasure_density measurable_completion nn_integral_completion intro!: nn_integral_cong_AE)
qed

lemma null_sets_subset: "B \<in> null_sets M \<Longrightarrow> A \<in> sets M \<Longrightarrow> A \<subseteq> B \<Longrightarrow> A \<in> null_sets M"
  using emeasure_mono[of A B M] by (simp add: null_sets_def)

lemma (in complete_measure) complete2: "A \<subseteq> B \<Longrightarrow> B \<in> null_sets M \<Longrightarrow> A \<in> null_sets M"
  using complete[of A B] null_sets_subset[of B M A] by simp

lemma (in complete_measure) AE_iff_null_sets: "(AE x in M. P x) \<longleftrightarrow> {x\<in>space M. \<not> P x} \<in> null_sets M"
  unfolding eventually_ae_filter by (auto intro: complete2)

lemma (in complete_measure) null_sets_iff_AE: "A \<in> null_sets M \<longleftrightarrow> ((AE x in M. x \<notin> A) \<and> A \<subseteq> space M)"
  unfolding AE_iff_null_sets by (auto cong: rev_conj_cong dest: sets.sets_into_space simp: subset_eq)

lemma (in complete_measure) in_sets_AE:
  assumes ae: "AE x in M. x \<in> A \<longleftrightarrow> x \<in> B" and A: "A \<in> sets M" and B: "B \<subseteq> space M"
  shows "B \<in> sets M"
proof -
  have "(AE x in M. x \<notin> B - A \<and> x \<notin> A - B)"
    using ae by eventually_elim auto
  then have "B - A \<in> null_sets M" "A - B \<in> null_sets M"
    using A B unfolding null_sets_iff_AE by (auto dest: sets.sets_into_space)
  then have "A \<union> (B - A) - (A - B) \<in> sets M"
    using A by blast
  also have "A \<union> (B - A) - (A - B) = B"
    by auto
  finally show "B \<in> sets M" .
qed

lemma (in complete_measure) vimage_null_part_null_sets:
  assumes f: "f \<in> M \<rightarrow>\<^sub>M N" and eq: "null_sets N \<subseteq> null_sets (distr M N f)"
    and A: "A \<in> completion N"
  shows "f -` null_part N A \<inter> space M \<in> null_sets M"
proof -
  obtain N' where "N' \<in> null_sets N" "null_part N A \<subseteq> N'"
    using null_part[OF A] by auto
  then have N': "N' \<in> null_sets (distr M N f)"
    using eq by auto
  show ?thesis
  proof (rule complete2)
    show "f -` null_part N A \<inter> space M \<subseteq> f -` N' \<inter> space M"
      using \<open>null_part N A \<subseteq> N'\<close> by auto
    show "f -` N' \<inter> space M \<in> null_sets M"
      using f N' by (auto simp: null_sets_def emeasure_distr)
  qed
qed

lemma (in complete_measure) vimage_null_part_sets:
  "f \<in> M \<rightarrow>\<^sub>M N \<Longrightarrow> null_sets N \<subseteq> null_sets (distr M N f) \<Longrightarrow> A \<in> completion N \<Longrightarrow>
  f -` null_part N A \<inter> space M \<in> sets M"
  using vimage_null_part_null_sets[of f N A] by auto

lemma (in complete_measure) measurable_completion2:
  assumes f: "f \<in> M \<rightarrow>\<^sub>M N" and null_sets: "null_sets N \<subseteq> null_sets (distr M N f)"
  shows "f \<in> M \<rightarrow>\<^sub>M completion N"
proof (rule measurableI)
  show "x \<in> space M \<Longrightarrow> f x \<in> space (completion N)" for x
    using f[THEN measurable_space] by auto
  fix A assume A: "A \<in> sets (completion N)"
  have "f -` A \<inter> space M = (f -` main_part N A \<inter> space M) \<union> (f -` null_part N A \<inter> space M)"
    using main_part_null_part_Un[OF A] by auto
  then show "f -` A \<inter> space M \<in> sets M"
    using f A null_sets by (auto intro: vimage_null_part_sets measurable_sets)
qed

lemma (in complete_measure) completion_distr_eq:
  assumes X: "X \<in> M \<rightarrow>\<^sub>M N" and null_sets: "null_sets (distr M N X) = null_sets N"
  shows "completion (distr M N X) = distr M (completion N) X"
proof (rule measure_eqI)
  show eq: "sets (completion (distr M N X)) = sets (distr M (completion N) X)"
    by (simp add: sets_completion null_sets)

  fix A assume A: "A \<in> completion (distr M N X)"
  moreover have A': "A \<in> completion N"
    using A by (simp add: eq)
  moreover have "main_part (distr M N X) A \<in> sets N"
    using main_part_sets[OF A] by simp
  moreover have "X -` A \<inter> space M = (X -` main_part (distr M N X) A \<inter> space M) \<union> (X -` null_part (distr M N X) A \<inter> space M)"
    using main_part_null_part_Un[OF A] by auto
  moreover have "X -` null_part (distr M N X) A \<inter> space M \<in> null_sets M"
    using X A by (intro vimage_null_part_null_sets) (auto cong: distr_cong)
  ultimately show "emeasure (completion (distr M N X)) A = emeasure (distr M (completion N) X) A"
    using X by (auto simp: emeasure_distr measurable_completion null_sets measurable_completion2
                     intro!: emeasure_Un_null_set[symmetric])
qed

lemma distr_completion: "X \<in> M \<rightarrow>\<^sub>M N \<Longrightarrow> distr (completion M) N X = distr M N X"
  by (intro measure_eqI) (auto simp: emeasure_distr measurable_completion)

proposition (in complete_measure) fmeasurable_inner_outer:
  "S \<in> fmeasurable M \<longleftrightarrow>
    (\<forall>e>0. \<exists>T\<in>fmeasurable M. \<exists>U\<in>fmeasurable M. T \<subseteq> S \<and> S \<subseteq> U \<and> \<bar>measure M T - measure M U\<bar> < e)"
  (is "_ \<longleftrightarrow> ?approx")
proof safe
  let ?\<mu> = "measure M" let ?D = "\<lambda>T U . \<bar>?\<mu> T - ?\<mu> U\<bar>"
  assume ?approx
  have "\<exists>A. \<forall>n. (fst (A n) \<in> fmeasurable M \<and> snd (A n) \<in> fmeasurable M \<and> fst (A n) \<subseteq> S \<and> S \<subseteq> snd (A n) \<and>
    ?D (fst (A n)) (snd (A n)) < 1/Suc n) \<and> (fst (A n) \<subseteq> fst (A (Suc n)) \<and> snd (A (Suc n)) \<subseteq> snd (A n))"
    (is "\<exists>A. \<forall>n. ?P n (A n) \<and> ?Q (A n) (A (Suc n))")
  proof (intro dependent_nat_choice)
    show "\<exists>A. ?P 0 A"
      using \<open>?approx\<close>[THEN spec, of 1] by auto
  next
    fix A n assume "?P n A"
    moreover
    from \<open>?approx\<close>[THEN spec, of "1/Suc (Suc n)"]
    obtain T U where *: "T \<in> fmeasurable M" "U \<in> fmeasurable M" "T \<subseteq> S" "S \<subseteq> U" "?D T U < 1 / Suc (Suc n)"
      by auto
    ultimately have "?\<mu> T \<le> ?\<mu> (T \<union> fst A)" "?\<mu> (U \<inter> snd A) \<le> ?\<mu> U"
      "?\<mu> T \<le> ?\<mu> U" "?\<mu> (T \<union> fst A) \<le> ?\<mu> (U \<inter> snd A)"
      by (auto intro!: measure_mono_fmeasurable)
    then have "?D (T \<union> fst A) (U \<inter> snd A) \<le> ?D T U"
      by auto
    also have "?D T U < 1/Suc (Suc n)" by fact
    finally show "\<exists>B. ?P (Suc n) B \<and> ?Q A B"
      using \<open>?P n A\<close> *
      by (intro exI[of _ "(T \<union> fst A, U \<inter> snd A)"] conjI) auto
  qed
  then obtain A
    where lm: "\<And>n. fst (A n) \<in> fmeasurable M" "\<And>n. snd (A n) \<in> fmeasurable M"
      and set_bound: "\<And>n. fst (A n) \<subseteq> S" "\<And>n. S \<subseteq> snd (A n)"
      and mono: "\<And>n. fst (A n) \<subseteq> fst (A (Suc n))" "\<And>n. snd (A (Suc n)) \<subseteq> snd (A n)"
      and bound: "\<And>n. ?D (fst (A n)) (snd (A n)) < 1/Suc n"
    by metis

  have INT_sA: "(\<Inter>n. snd (A n)) \<in> fmeasurable M"
    using lm by (intro fmeasurable_INT[of _ 0]) auto
  have UN_fA: "(\<Union>n. fst (A n)) \<in> fmeasurable M"
    using lm order_trans[OF set_bound(1) set_bound(2)[of 0]] by (intro fmeasurable_UN[of _ _ "snd (A 0)"]) auto

  have "(\<lambda>n. ?\<mu> (fst (A n)) - ?\<mu> (snd (A n))) \<longlonglongrightarrow> 0"
    using bound
    by (subst tendsto_rabs_zero_iff[symmetric])
       (intro tendsto_sandwich[OF _ _ tendsto_const LIMSEQ_inverse_real_of_nat];
        auto intro!: always_eventually less_imp_le simp: divide_inverse)
  moreover
  have "(\<lambda>n. ?\<mu> (fst (A n)) - ?\<mu> (snd (A n))) \<longlonglongrightarrow> ?\<mu> (\<Union>n. fst (A n)) - ?\<mu> (\<Inter>n. snd (A n))"
  proof (intro tendsto_diff Lim_measure_incseq Lim_measure_decseq)
    show "range (\<lambda>i. fst (A i)) \<subseteq> sets M" "range (\<lambda>i. snd (A i)) \<subseteq> sets M"
      "incseq (\<lambda>i. fst (A i))" "decseq (\<lambda>n. snd (A n))"
      using mono lm by (auto simp: incseq_Suc_iff decseq_Suc_iff intro!: measure_mono_fmeasurable)
    show "emeasure M (\<Union>x. fst (A x)) \<noteq> \<infinity>" "emeasure M (snd (A n)) \<noteq> \<infinity>" for n
      using lm(2)[of n] UN_fA by (auto simp: fmeasurable_def)
  qed
  ultimately have eq: "0 = ?\<mu> (\<Union>n. fst (A n)) - ?\<mu> (\<Inter>n. snd (A n))"
    by (rule LIMSEQ_unique)

  show "S \<in> fmeasurable M"
    using UN_fA INT_sA
  proof (rule complete_sets_sandwich_fmeasurable)
    show "(\<Union>n. fst (A n)) \<subseteq> S" "S \<subseteq> (\<Inter>n. snd (A n))"
      using set_bound by auto
    show "?\<mu> (\<Union>n. fst (A n)) = ?\<mu> (\<Inter>n. snd (A n))"
      using eq by auto
  qed
qed (auto intro!: bexI[of _ S])

lemma (in complete_measure) fmeasurable_measure_inner_outer:
   "(S \<in> fmeasurable M \<and> m = measure M S) \<longleftrightarrow>
      (\<forall>e>0. \<exists>T\<in>fmeasurable M. T \<subseteq> S \<and> m - e < measure M T) \<and>
      (\<forall>e>0. \<exists>U\<in>fmeasurable M. S \<subseteq> U \<and> measure M U < m + e)"
    (is "?lhs = ?rhs")
proof
  assume RHS: ?rhs
  then have T: "\<And>e. 0 < e \<longrightarrow> (\<exists>T\<in>fmeasurable M. T \<subseteq> S \<and> m - e < measure M T)"
        and U: "\<And>e. 0 < e \<longrightarrow> (\<exists>U\<in>fmeasurable M. S \<subseteq> U \<and> measure M U < m + e)"
    by auto
  have "S \<in> fmeasurable M"
  proof (subst fmeasurable_inner_outer, safe)
    fix e::real assume "0 < e"
    with RHS obtain T U where T: "T \<in> fmeasurable M" "T \<subseteq> S" "m - e/2 < measure M T"
                          and U: "U \<in> fmeasurable M" "S \<subseteq> U" "measure M U < m + e/2"
      by (meson half_gt_zero)+
    moreover have "measure M U - measure M T < (m + e/2) - (m - e/2)"
      by (intro diff_strict_mono) fact+
    moreover have "measure M T \<le> measure M U"
      using T U by (intro measure_mono_fmeasurable) auto
    ultimately show "\<exists>T\<in>fmeasurable M. \<exists>U\<in>fmeasurable M. T \<subseteq> S \<and> S \<subseteq> U \<and> \<bar>measure M T - measure M U\<bar> < e"
      apply (rule_tac bexI[OF _ \<open>T \<in> fmeasurable M\<close>])
      apply (rule_tac bexI[OF _ \<open>U \<in> fmeasurable M\<close>])
      by auto
  qed
  moreover have "m = measure M S"
    using \<open>S \<in> fmeasurable M\<close> U[of "measure M S - m"] T[of "m - measure M S"]
    by (cases m "measure M S" rule: linorder_cases)
       (auto simp: not_le[symmetric] measure_mono_fmeasurable)
  ultimately show ?lhs
    by simp
qed (auto intro!: bexI[of _ S])

lemma (in complete_measure) null_sets_outer:
  "S \<in> null_sets M \<longleftrightarrow> (\<forall>e>0. \<exists>T\<in>fmeasurable M. S \<subseteq> T \<and> measure M T < e)"
proof -
  have "S \<in> null_sets M \<longleftrightarrow> (S \<in> fmeasurable M \<and> 0 = measure M S)"
    by (auto simp: null_sets_def emeasure_eq_measure2 intro: fmeasurableI) (simp add: measure_def)
  also have "\<dots> = (\<forall>e>0. \<exists>T\<in>fmeasurable M. S \<subseteq> T \<and> measure M T < e)"
    unfolding fmeasurable_measure_inner_outer by auto
  finally show ?thesis .
qed

lemma (in complete_measure) fmeasurable_measure_inner_outer_le:
     "(S \<in> fmeasurable M \<and> m = measure M S) \<longleftrightarrow>
        (\<forall>e>0. \<exists>T\<in>fmeasurable M. T \<subseteq> S \<and> m - e \<le> measure M T) \<and>
        (\<forall>e>0. \<exists>U\<in>fmeasurable M. S \<subseteq> U \<and> measure M U \<le> m + e)" (is ?T1)
  and null_sets_outer_le:
     "S \<in> null_sets M \<longleftrightarrow> (\<forall>e>0. \<exists>T\<in>fmeasurable M. S \<subseteq> T \<and> measure M T \<le> e)" (is ?T2)
proof -
  have "e > 0 \<and> m - e/2 \<le> t \<Longrightarrow> m - e < t"
       "e > 0 \<and> t \<le> m + e/2 \<Longrightarrow> t < m + e"
       "e > 0 \<longleftrightarrow> e/2 > 0"
       for e t
    by auto
  then show ?T1 ?T2
    unfolding fmeasurable_measure_inner_outer null_sets_outer
    by (meson dense le_less_trans less_imp_le)+
qed

lemma (in cld_measure) notin_sets_outer_measure_of_cover:
  assumes E: "E \<subseteq> space M" "E \<notin> sets M"
  shows "\<exists>B\<in>sets M. 0 < emeasure M B \<and> emeasure M B < \<infinity> \<and>
    outer_measure_of M (B \<inter> E) = emeasure M B \<and> outer_measure_of M (B - E) = emeasure M B"
proof -
  from locally_determined[OF \<open>E \<subseteq> space M\<close>] \<open>E \<notin> sets M\<close>
  obtain F
    where [measurable]: "F \<in> sets M" and "emeasure M F < \<infinity>" "E \<inter> F \<notin> sets M"
    by blast
  then obtain H H'
    where H: "measurable_envelope M (F \<inter> E) H" and H': "measurable_envelope M (F - E) H'"
    using measurable_envelopeI_countable_cover[of "F \<inter> E" "\<lambda>_. F" M]
       measurable_envelopeI_countable_cover[of "F - E" "\<lambda>_. F" M]
    by auto
  note measurable_envelopeD(2)[OF H', measurable] measurable_envelopeD(2)[OF H, measurable]

  from measurable_envelopeD(1)[OF H'] measurable_envelopeD(1)[OF H]
  have subset: "F - H' \<subseteq> F \<inter> E" "F \<inter> E \<subseteq> F \<inter> H"
    by auto
  moreover define G where "G = (F \<inter> H) - (F - H')"
  ultimately have G: "G = F \<inter> H \<inter> H'"
    by auto
  have "emeasure M (F \<inter> H) \<noteq> 0"
  proof
    assume "emeasure M (F \<inter> H) = 0"
    then have "F \<inter> H \<in> null_sets M"
      by auto
    with \<open>E \<inter> F \<notin> sets M\<close> show False
      using complete[OF \<open>F \<inter> E \<subseteq> F \<inter> H\<close>] by (auto simp: Int_commute)
  qed
  moreover
  have "emeasure M (F - H') \<noteq> emeasure M (F \<inter> H)"
  proof
    assume "emeasure M (F - H') = emeasure M (F \<inter> H)"
    with \<open>E \<inter> F \<notin> sets M\<close> emeasure_mono[of "F \<inter> H" F M] \<open>emeasure M F < \<infinity>\<close>
    have "F \<inter> E \<in> sets M"
      by (intro complete_sets_sandwich[OF _ _ subset]) auto
    with \<open>E \<inter> F \<notin> sets M\<close> show False
      by (simp add: Int_commute)
  qed
  moreover have "emeasure M (F - H') \<le> emeasure M (F \<inter> H)"
    using subset by (intro emeasure_mono) auto
  ultimately have "emeasure M G \<noteq> 0"
    unfolding G_def using subset
    by (subst emeasure_Diff) (auto simp: top_unique diff_eq_0_iff_ennreal)
  show ?thesis
  proof (intro bexI conjI)
    have "emeasure M G \<le> emeasure M F"
      unfolding G by (auto intro!: emeasure_mono)
    with \<open>emeasure M F < \<infinity>\<close> show "0 < emeasure M G" "emeasure M G < \<infinity>"
      using \<open>emeasure M G \<noteq> 0\<close> by (auto simp: zero_less_iff_neq_zero)
    show [measurable]: "G \<in> sets M"
      unfolding G by auto

    have "emeasure M G = outer_measure_of M (F \<inter> H' \<inter> (F \<inter> E))"
      using measurable_envelopeD(3)[OF H, of "F \<inter> H'"] unfolding G by (simp add: ac_simps)
    also have "\<dots> \<le> outer_measure_of M (G \<inter> E)"
      using measurable_envelopeD(1)[OF H] by (intro outer_measure_of_mono) (auto simp: G)
    finally show "outer_measure_of M (G \<inter> E) = emeasure M G"
      using outer_measure_of_mono[of "G \<inter> E" G M] by auto

    have "emeasure M G = outer_measure_of M (F \<inter> H \<inter> (F - E))"
      using measurable_envelopeD(3)[OF H', of "F \<inter> H"] unfolding G by (simp add: ac_simps)
    also have "\<dots> \<le> outer_measure_of M (G - E)"
      using measurable_envelopeD(1)[OF H'] by (intro outer_measure_of_mono) (auto simp: G)
    finally show "outer_measure_of M (G - E) = emeasure M G"
      using outer_measure_of_mono[of "G - E" G M] by auto
  qed
qed

text \<open>The following theorem is a specialization of D.H. Fremlin, Measure Theory vol 4I (413G). We
  only show one direction and do not use a inner regular family \<open>K\<close>.\<close>

lemma (in cld_measure) borel_measurable_cld:
  fixes f :: "'a \<Rightarrow> real"
  assumes "\<And>A a b. A \<in> sets M \<Longrightarrow> 0 < emeasure M A \<Longrightarrow> emeasure M A < \<infinity> \<Longrightarrow> a < b \<Longrightarrow>
      min (outer_measure_of M {x\<in>A. f x \<le> a}) (outer_measure_of M {x\<in>A. b \<le> f x}) < emeasure M A"
  shows "f \<in> M \<rightarrow>\<^sub>M borel"
proof (rule ccontr)
  let ?E = "\<lambda>a. {x\<in>space M. f x \<le> a}" and ?F = "\<lambda>a. {x\<in>space M. a \<le> f x}"

  assume "f \<notin> M \<rightarrow>\<^sub>M borel"
  then obtain a where "?E a \<notin> sets M"
    unfolding borel_measurable_iff_le by blast
  from notin_sets_outer_measure_of_cover[OF _ this]
  obtain K
    where K: "K \<in> sets M" "0 < emeasure M K" "emeasure M K < \<infinity>"
      and eq1: "outer_measure_of M (K \<inter> ?E a) = emeasure M K"
      and eq2: "outer_measure_of M (K - ?E a) = emeasure M K"
    by auto
  then have me_K: "measurable_envelope M (K \<inter> ?E a) K"
    by (subst measurable_envelope_eq2) auto

  define b where "b n = a + inverse (real (Suc n))" for n
  have "(SUP n. outer_measure_of M (K \<inter> ?F (b n))) = outer_measure_of M (\<Union>n. K \<inter> ?F (b n))"
  proof (intro SUP_outer_measure_of_incseq)
    have "x \<le> y \<Longrightarrow> b y \<le> b x" for x y
      by (auto simp: b_def field_simps)
    then show "incseq (\<lambda>n. K \<inter> {x \<in> space M. b n \<le> f x})"
      by (auto simp: incseq_def intro: order_trans)
  qed auto
  also have "(\<Union>n. K \<inter> ?F (b n)) = K - ?E a"
  proof -
    have "b \<longlonglongrightarrow> a"
      unfolding b_def by (rule LIMSEQ_inverse_real_of_nat_add)
    then have "\<forall>n. \<not> b n \<le> f x \<Longrightarrow> f x \<le> a" for x
      by (rule LIMSEQ_le_const) (auto intro: less_imp_le simp: not_le)
    moreover have "\<not> b n \<le> a" for n
      by (auto simp: b_def)
    ultimately show ?thesis
      using \<open>K \<in> sets M\<close>[THEN sets.sets_into_space] by (auto simp: subset_eq intro: order_trans)
  qed
  finally have "0 < (SUP n. outer_measure_of M (K \<inter> ?F (b n)))"
    using K by (simp add: eq2)
  then obtain n where pos_b: "0 < outer_measure_of M (K \<inter> ?F (b n))" and "a < b n"
    unfolding less_SUP_iff by (auto simp: b_def)
  from measurable_envelopeI_countable_cover[of "K \<inter> ?F (b n)" "\<lambda>_. K" M] K
  obtain K' where "K' \<subseteq> K" and me_K': "measurable_envelope M (K \<inter> ?F (b n)) K'"
    by auto
  then have K'_le_K: "emeasure M K' \<le> emeasure M K"
    by (intro emeasure_mono K)
  have "K' \<in> sets M"
    using me_K' by (rule measurable_envelopeD)

  have "min (outer_measure_of M {x\<in>K'. f x \<le> a}) (outer_measure_of M {x\<in>K'. b n \<le> f x}) < emeasure M K'"
  proof (rule assms)
    show "0 < emeasure M K'" "emeasure M K' < \<infinity>"
      using measurable_envelopeD2[OF me_K'] pos_b K K'_le_K by auto
  qed fact+
  also have "{x\<in>K'. f x \<le> a} = K' \<inter> (K \<inter> ?E a)"
    using \<open>K' \<in> sets M\<close>[THEN sets.sets_into_space] \<open>K' \<subseteq> K\<close> by auto
  also have "{x\<in>K'. b n \<le> f x} = K' \<inter> (K \<inter> ?F (b n))"
    using \<open>K' \<in> sets M\<close>[THEN sets.sets_into_space] \<open>K' \<subseteq> K\<close> by auto
  finally have "min (emeasure M K) (emeasure M K') < emeasure M K'"
    unfolding
      measurable_envelopeD(3)[OF me_K \<open>K' \<in> sets M\<close>, symmetric]
      measurable_envelopeD(3)[OF me_K' \<open>K' \<in> sets M\<close>, symmetric]
    using \<open>K' \<subseteq> K\<close> by (simp add: Int_absorb1 Int_absorb2)
  with K'_le_K show False
    by (auto simp: min_def split: if_split_asm)
qed

end


(*  Title:      ZF/Induct/Term.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Terms over an alphabet\<close>

theory Term imports Main begin

text \<open>
  Illustrates the list functor (essentially the same type as in \<open>Trees_Forest\<close>).
\<close>

consts
  "term" :: "i => i"

datatype "term(A)" = Apply ("a \<in> A", "l \<in> list(term(A))")
  monos list_mono
  type_elims list_univ [THEN subsetD, elim_format]

declare Apply [TC]

definition
  term_rec :: "[i, [i, i, i] => i] => i"  where
  "term_rec(t,d) ==
    Vrec(t, \<lambda>t g. term_case(\<lambda>x zs. d(x, zs, map(\<lambda>z. g`z, zs)), t))"

definition
  term_map :: "[i => i, i] => i"  where
  "term_map(f,t) == term_rec(t, \<lambda>x zs rs. Apply(f(x), rs))"

definition
  term_size :: "i => i"  where
  "term_size(t) == term_rec(t, \<lambda>x zs rs. succ(list_add(rs)))"

definition
  reflect :: "i => i"  where
  "reflect(t) == term_rec(t, \<lambda>x zs rs. Apply(x, rev(rs)))"

definition
  preorder :: "i => i"  where
  "preorder(t) == term_rec(t, \<lambda>x zs rs. Cons(x, flat(rs)))"

definition
  postorder :: "i => i"  where
  "postorder(t) == term_rec(t, \<lambda>x zs rs. flat(rs) @ [x])"

lemma term_unfold: "term(A) = A * list(term(A))"
  by (fast intro!: term.intros [unfolded term.con_defs]
    elim: term.cases [unfolded term.con_defs])

lemma term_induct2:
  "[| t \<in> term(A);
      !!x.      [| x \<in> A |] ==> P(Apply(x,Nil));
      !!x z zs. [| x \<in> A;  z \<in> term(A);  zs: list(term(A));  P(Apply(x,zs))
                |] ==> P(Apply(x, Cons(z,zs)))
     |] ==> P(t)"
  \<comment> \<open>Induction on @{term "term(A)"} followed by induction on @{term list}.\<close>
  apply (induct_tac t)
  apply (erule list.induct)
   apply (auto dest: list_CollectD)
  done

lemma term_induct_eqn [consumes 1, case_names Apply]:
  "[| t \<in> term(A);
      !!x zs. [| x \<in> A;  zs: list(term(A));  map(f,zs) = map(g,zs) |] ==>
              f(Apply(x,zs)) = g(Apply(x,zs))
   |] ==> f(t) = g(t)"
  \<comment> \<open>Induction on @{term "term(A)"} to prove an equation.\<close>
  apply (induct_tac t)
  apply (auto dest: map_list_Collect list_CollectD)
  done

text \<open>
  \medskip Lemmas to justify using @{term "term"} in other recursive
  type definitions.
\<close>

lemma term_mono: "A \<subseteq> B ==> term(A) \<subseteq> term(B)"
  apply (unfold term.defs)
  apply (rule lfp_mono)
    apply (rule term.bnd_mono)+
  apply (rule univ_mono basic_monos| assumption)+
  done

lemma term_univ: "term(univ(A)) \<subseteq> univ(A)"
  \<comment> \<open>Easily provable by induction also\<close>
  apply (unfold term.defs term.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply safe
  apply (assumption | rule Pair_in_univ list_univ [THEN subsetD])+
  done

lemma term_subset_univ: "A \<subseteq> univ(B) ==> term(A) \<subseteq> univ(B)"
  apply (rule subset_trans)
   apply (erule term_mono)
  apply (rule term_univ)
  done

lemma term_into_univ: "[| t \<in> term(A);  A \<subseteq> univ(B) |] ==> t \<in> univ(B)"
  by (rule term_subset_univ [THEN subsetD])

text \<open>
  \medskip \<open>term_rec\<close> -- by \<open>Vset\<close> recursion.
\<close>

lemma map_lemma: "[| l \<in> list(A);  Ord(i);  rank(l)<i |]
    ==> map(\<lambda>z. (\<lambda>x \<in> Vset(i).h(x)) ` z, l) = map(h,l)"
  \<comment> \<open>@{term map} works correctly on the underlying list of terms.\<close>
  apply (induct set: list)
   apply simp
  apply (subgoal_tac "rank (a) <i & rank (l) < i")
   apply (simp add: rank_of_Ord)
  apply (simp add: list.con_defs)
  apply (blast dest: rank_rls [THEN lt_trans])
  done

lemma term_rec [simp]: "ts \<in> list(A) ==>
  term_rec(Apply(a,ts), d) = d(a, ts, map (\<lambda>z. term_rec(z,d), ts))"
  \<comment> \<open>Typing premise is necessary to invoke \<open>map_lemma\<close>.\<close>
  apply (rule term_rec_def [THEN def_Vrec, THEN trans])
  apply (unfold term.con_defs)
  apply (simp add: rank_pair2 map_lemma)
  done

lemma term_rec_type:
  assumes t: "t \<in> term(A)"
    and a: "!!x zs r. [| x \<in> A;  zs: list(term(A));
                   r \<in> list(\<Union>t \<in> term(A). C(t)) |]
                ==> d(x, zs, r): C(Apply(x,zs))"
  shows "term_rec(t,d) \<in> C(t)"
  \<comment> \<open>Slightly odd typing condition on \<open>r\<close> in the second premise!\<close>
  using t
  apply induct
  apply (frule list_CollectD)
  apply (subst term_rec)
   apply (assumption | rule a)+
  apply (erule list.induct)
   apply auto
  done

lemma def_term_rec:
  "[| !!t. j(t)==term_rec(t,d);  ts: list(A) |] ==>
    j(Apply(a,ts)) = d(a, ts, map(\<lambda>Z. j(Z), ts))"
  apply (simp only:)
  apply (erule term_rec)
  done

lemma term_rec_simple_type [TC]:
  "[| t \<in> term(A);
      !!x zs r. [| x \<in> A;  zs: list(term(A));  r \<in> list(C) |]
                ==> d(x, zs, r): C
   |] ==> term_rec(t,d) \<in> C"
  apply (erule term_rec_type)
  apply (drule subset_refl [THEN UN_least, THEN list_mono, THEN subsetD])
  apply simp
  done

text \<open>
  \medskip @{term term_map}.
\<close>

lemma term_map [simp]:
  "ts \<in> list(A) ==>
    term_map(f, Apply(a, ts)) = Apply(f(a), map(term_map(f), ts))"
  by (rule term_map_def [THEN def_term_rec])

lemma term_map_type [TC]:
    "[| t \<in> term(A);  !!x. x \<in> A ==> f(x): B |] ==> term_map(f,t) \<in> term(B)"
  apply (unfold term_map_def)
  apply (erule term_rec_simple_type)
  apply fast
  done

lemma term_map_type2 [TC]:
    "t \<in> term(A) ==> term_map(f,t) \<in> term({f(u). u \<in> A})"
  apply (erule term_map_type)
  apply (erule RepFunI)
  done

text \<open>
  \medskip @{term term_size}.
\<close>

lemma term_size [simp]:
    "ts \<in> list(A) ==> term_size(Apply(a, ts)) = succ(list_add(map(term_size, ts)))"
  by (rule term_size_def [THEN def_term_rec])

lemma term_size_type [TC]: "t \<in> term(A) ==> term_size(t) \<in> nat"
  by (auto simp add: term_size_def)

text \<open>
  \medskip \<open>reflect\<close>.
\<close>

lemma reflect [simp]:
    "ts \<in> list(A) ==> reflect(Apply(a, ts)) = Apply(a, rev(map(reflect, ts)))"
  by (rule reflect_def [THEN def_term_rec])

lemma reflect_type [TC]: "t \<in> term(A) ==> reflect(t) \<in> term(A)"
  by (auto simp add: reflect_def)

text \<open>
  \medskip \<open>preorder\<close>.
\<close>

lemma preorder [simp]:
    "ts \<in> list(A) ==> preorder(Apply(a, ts)) = Cons(a, flat(map(preorder, ts)))"
  by (rule preorder_def [THEN def_term_rec])

lemma preorder_type [TC]: "t \<in> term(A) ==> preorder(t) \<in> list(A)"
  by (simp add: preorder_def)

text \<open>
  \medskip \<open>postorder\<close>.
\<close>

lemma postorder [simp]:
    "ts \<in> list(A) ==> postorder(Apply(a, ts)) = flat(map(postorder, ts)) @ [a]"
  by (rule postorder_def [THEN def_term_rec])

lemma postorder_type [TC]: "t \<in> term(A) ==> postorder(t) \<in> list(A)"
  by (simp add: postorder_def)

text \<open>
  \medskip Theorems about \<open>term_map\<close>.
\<close>

declare map_compose [simp]

lemma term_map_ident: "t \<in> term(A) ==> term_map(\<lambda>u. u, t) = t"
  by (induct rule: term_induct_eqn) simp

lemma term_map_compose:
    "t \<in> term(A) ==> term_map(f, term_map(g,t)) = term_map(\<lambda>u. f(g(u)), t)"
  by (induct rule: term_induct_eqn) simp

lemma term_map_reflect:
    "t \<in> term(A) ==> term_map(f, reflect(t)) = reflect(term_map(f,t))"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric])

text \<open>
  \medskip Theorems about \<open>term_size\<close>.
\<close>

lemma term_size_term_map: "t \<in> term(A) ==> term_size(term_map(f,t)) = term_size(t)"
  by (induct rule: term_induct_eqn) simp

lemma term_size_reflect: "t \<in> term(A) ==> term_size(reflect(t)) = term_size(t)"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric] list_add_rev)

lemma term_size_length: "t \<in> term(A) ==> term_size(t) = length(preorder(t))"
  by (induct rule: term_induct_eqn) (simp add: length_flat)

text \<open>
  \medskip Theorems about \<open>reflect\<close>.
\<close>

lemma reflect_reflect_ident: "t \<in> term(A) ==> reflect(reflect(t)) = t"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib)

text \<open>
  \medskip Theorems about preorder.
\<close>

lemma preorder_term_map:
    "t \<in> term(A) ==> preorder(term_map(f,t)) = map(f, preorder(t))"
  by (induct rule: term_induct_eqn) (simp add: map_flat)

lemma preorder_reflect_eq_rev_postorder:
    "t \<in> term(A) ==> preorder(reflect(t)) = rev(postorder(t))"
  by (induct rule: term_induct_eqn)
    (simp add: rev_app_distrib rev_flat rev_map_distrib [symmetric])

end


section \<open>Abstract Datatype for Weighted Directed Graphs\<close>
theory Directed_Graph_Specs
imports Directed_Graph
begin

locale adt_wgraph =
  fixes \<alpha> :: "'g \<Rightarrow> ('v) wgraph"
    and invar :: "'g \<Rightarrow> bool"
    and succ :: "'g \<Rightarrow> 'v \<Rightarrow> (nat\<times>'v) list"
    and empty_graph :: 'g
    and add_edge :: "'v\<times>'v \<Rightarrow> nat \<Rightarrow> 'g \<Rightarrow> 'g"
  assumes succ_correct: "invar g \<Longrightarrow> set (succ g u) = {(d,v). \<alpha> g (u,v) = enat d}"
  assumes empty_graph_correct:
    "invar empty_graph"
    "\<alpha> empty_graph = (\<lambda>_. \<infinity>)"
  assumes add_edge_correct:
    "invar g \<Longrightarrow> \<alpha> g e = \<infinity> \<Longrightarrow> invar (add_edge e d g)"
    "invar g \<Longrightarrow> \<alpha> g e = \<infinity> \<Longrightarrow> \<alpha> (add_edge e d g) = (\<alpha> g)(e:=enat d)"
begin

lemmas wgraph_specs = succ_correct empty_graph_correct add_edge_correct

end

locale adt_finite_wgraph = adt_wgraph where \<alpha>=\<alpha> for \<alpha> :: "'g \<Rightarrow> ('v) wgraph" +
  assumes finite: "invar g \<Longrightarrow> finite (WGraph.edges (\<alpha> g))"

subsection \<open>Constructing Weighted Graphs from Lists\<close>
lemma edges_empty[simp]: "WGraph.edges (\<lambda>_. \<infinity>) = {}"
  by (auto simp: WGraph.edges_def)

lemma edges_insert[simp]:
  "WGraph.edges (g(e:=enat d)) = Set.insert e (WGraph.edges g)"
  by (auto simp: WGraph.edges_def)

text \<open>A list represents a graph if there are no multi-edges or duplicate edges\<close>
definition "valid_graph_rep l \<equiv>
  (\<forall>u d d' v. (u,v,d)\<in>set l \<and> (u,v,d')\<in>set l \<longrightarrow> d=d')
\<and> distinct l
  "

text \<open>Alternative characterization: all node pairs must be distinct\<close>

text \<open>For a valid graph representation, there is exactly one graph that
  corresponds to it\<close>
lemma valid_graph_rep_ex1:
  "valid_graph_rep l \<Longrightarrow> \<exists>! w. \<forall>u v d. w (u,v) = enat d \<longleftrightarrow> (u,v,d)\<in>set l"
  unfolding valid_graph_rep_code
  apply safe
  subgoal
    apply (rule exI[where x="\<lambda>(u,v).
        if \<exists>d. (u,v,d)\<in>set l then enat (SOME d. (u,v,d)\<in>set l) else \<infinity>"])
    by (auto intro: someI simp: distinct_map inj_on_def split: prod.splits;
           blast)
  subgoal for w w'
    apply (simp add: fun_eq_iff)
    by (metis (mono_tags, hide_lams) not_enat_eq)
  done

text \<open>We define this graph using determinate choice\<close>
definition "wgraph_of_list l \<equiv> THE w. \<forall>u v d. w (u,v) = enat d \<longleftrightarrow> (u,v,d)\<in>set l"

locale wgraph_from_list_algo = adt_wgraph
begin

definition "from_list l \<equiv> fold (\<lambda>(u,v,d). add_edge (u,v) d) l empty_graph"

definition "edges_undef l w \<equiv> \<forall>u v d. (u,v,d)\<in>set l \<longrightarrow> w (u,v) = \<infinity>"

lemma edges_undef_simps[simp]:
  "edges_undef [] w"
  "edges_undef l (\<lambda>_. \<infinity>)"
  "edges_undef ((u,v,d)#l) w \<longleftrightarrow> edges_undef l w \<and> w (u,v) = \<infinity>"
  "edges_undef l (w((u,v) := enat d)) \<longleftrightarrow> edges_undef l w \<and> (\<forall>d'. (u,v,d')\<notin>set l)"
  by (auto simp: edges_undef_def)

lemma from_list_correct_aux:
  assumes "valid_graph_rep l"
  assumes "edges_undef l (\<alpha> g)"
  assumes "invar g"
  defines "g' \<equiv> fold (\<lambda>(u,v,d). add_edge (u,v) d) l g"
  shows "invar g'"
    and "(\<forall>u v d. \<alpha> g' (u,v) = enat d \<longleftrightarrow> \<alpha> g (u,v) = enat d \<or> (u,v,d)\<in>set l)"
  using assms(1-3) unfolding g'_def
  apply (induction l arbitrary: g)
  by (auto simp: wgraph_specs split: if_splits)

lemma from_list_correct':
  assumes "valid_graph_rep l"
  shows "invar (from_list l)"
    and "(u,v,d)\<in>set l \<longleftrightarrow> \<alpha> (from_list l) (u,v) = enat d"
  unfolding from_list_def
  using from_list_correct_aux[OF assms, where g=empty_graph]
  by (auto simp: wgraph_specs)

lemma from_list_correct:
  assumes "valid_graph_rep l"
  shows "invar (from_list l)" "\<alpha> (from_list l) = wgraph_of_list l"
proof -
  from theI'[OF valid_graph_rep_ex1[OF assms], folded wgraph_of_list_def]
  have "(wgraph_of_list l (u, v) = enat d) = ((u, v, d) \<in> set l)" for u v d
    by blast

  then show "\<alpha> (from_list l) = wgraph_of_list l"
    using from_list_correct_aux[OF assms, where g=empty_graph]
    apply (clarsimp simp: fun_eq_iff wgraph_specs from_list_def)
    apply (metis (no_types) enat.exhaust)
    done

  show "invar (from_list l)"
    by (simp add: assms from_list_correct')

qed

end

end


theory Chapter3
imports Main
begin

type_synonym data_object = string
type_synonym method_name = string
type_synonym thread = nat

datatype history_element = Invocation data_object method_name thread
                           | Response data_object method_name thread

fun get_task :: "history_element \<Rightarrow> nat" where
"get_task (Invocation d m t) = t" |
"get_task (Response d m t) = t"

fun get_object :: "history_element \<Rightarrow> data_object" where
"get_object (Invocation d m t) = d" |
"get_object (Response d m t) = d"

type_synonym history = "history_element list"

fun is_in :: "history \<Rightarrow> history_element \<Rightarrow> bool" where
"is_in [] e = False" |
"is_in (head#tail) e = (if (head = e) then True else (is_in tail e))"

fun history_before :: "history \<Rightarrow> history_element \<Rightarrow> history" where
"history_before [] e = []" |
"history_before (head#tail) e = (if (head = e) then [] else [head]@(history_before tail e))"

fun history_after :: "history \<Rightarrow> history_element \<Rightarrow> history" where
"history_after [] e = []" |
"history_after (head#tail) e = (if (head = e) then tail else (history_after tail e))"

fun precedes :: "history \<Rightarrow> history_element \<Rightarrow> history_element \<Rightarrow> bool" where
"precedes [] _ _ = False" |
"precedes (head#tail) e1 e2 = (if (head = e1) then True else (if (head = e2) then False else (precedes tail e1 e2)))"

value "[(Invocation ''a'' ''m'' 1)]"

fun matches :: "history_element \<Rightarrow> history_element \<Rightarrow> bool" where
"matches (Invocation d1 m1 t1) (Response d2 m2 t2) = ((d1 = d2) \<and> (m1 = m2) \<and> (t1 = t2))" |
"matches _ _ = False"

fun is_invocation :: "history_element \<Rightarrow> bool" where
"is_invocation (Invocation _ _ _) = True" |
"is_invocation _ = False"

fun has_response :: "history_element \<Rightarrow> history \<Rightarrow> bool" where
"has_response _ [] = False" |
"has_response e (head#tail) = (if (matches e head) then True else (has_response e tail))"

fun get_response :: "history_element \<Rightarrow> history \<Rightarrow> history_element option" where
"get_response _ [] = None" |
"get_response e (head#tail) = (if (matches e head) then (Some e) else (get_response e tail))"

fun is_sequential :: "history \<Rightarrow> bool" where
"is_sequential [] = True" |
"is_sequential [(Invocation _ _ _)] = True" |
"is_sequential [(Response _ _ _)] = False" |
"is_sequential (h1#tail1)
 = (case tail1 of
      h2#[] \<Rightarrow> (matches h1 h2)
    | (h2#tail2)            \<Rightarrow> if (matches h1 h2) then (is_sequential tail2) else False)"

value "(is_sequential
[
 (history_element.Invocation ''a'' ''m1'' 2),
 (history_element.Response   ''a'' ''m1'' 2)
])"

value "(is_sequential
[
 (history_element.Invocation ''a'' ''m1'' 2),
 (history_element.Response   ''a'' ''m1'' 2),
 (history_element.Invocation ''a'' ''m1'' 2),
 (history_element.Response   ''b'' ''m1'' 2)
])"

value "(is_sequential
[
 (history_element.Invocation ''a'' ''m1'' 1),
 (history_element.Response   ''a'' ''m1'' 1),
 (history_element.Invocation ''a'' ''m2'' 3),
 (history_element.Response   ''a'' ''m2'' 3)
])"

fun thread_subhistory :: "history \<Rightarrow> thread \<Rightarrow> history" where
"thread_subhistory (h1#tail) t =
  (if ((get_task h1) = t) then h1#(thread_subhistory tail t) else (thread_subhistory tail t))" |
"thread_subhistory [] t = []"

value "(thread_subhistory
[
 (history_element.Invocation ''a'' ''m1'' 1),
 (history_element.Response   ''a'' ''m1'' 1),
 (history_element.Invocation ''a'' ''m2'' 3),
 (history_element.Response   ''a'' ''m2'' 3)
]
3
)"

definition at_most_once_found :: "history \<Rightarrow> history_element \<Rightarrow> bool" where
"at_most_once_found h e = ((is_in h e) \<longrightarrow> \<not>(is_in (history_after h e) e))"

definition is_well_formed :: "history \<Rightarrow> bool" where
"is_well_formed h = ((\<forall>i.(is_sequential (thread_subhistory h i))) \<and> (\<forall>e.(at_most_once_found h e)))"

definition are_equivalent :: "history \<Rightarrow> history \<Rightarrow> bool" where
"are_equivalent h1 h2 = (\<forall>i.(thread_subhistory h1 i) = (thread_subhistory h2 i))"

(* Lemmas for sanity check *)

lemma "(is_well_formed [])"
apply(simp add:is_well_formed_def add:at_most_once_found_def)
done

lemma "h1 = h2 \<longrightarrow> (are_equivalent h1 h2)"
apply(simp add:are_equivalent_def add:at_most_once_found_def)
done

fun only_responses :: "history \<Rightarrow> bool" where
"only_responses [] = True" |
"only_responses ((Response _ _ _)#tail) = (only_responses tail)" |
"only_responses _ = False"

(* common prefix, then only responses, and a legal history: *)
definition is_extension :: "history \<Rightarrow> history \<Rightarrow> bool" where
"is_extension h1 h2 = ((is_well_formed h1)
                        \<and> (is_well_formed h2)
                        \<and> (\<exists>suffix.((h2 = h1@suffix) \<and> only_responses(suffix))))"

lemma "is_extension [(Invocation d m t)] [(Invocation d m t), (Response d m t)]"
apply(simp add:is_extension_def)
apply(simp add:is_well_formed_def)
apply(auto)
apply(simp add:at_most_once_found_def)
apply(simp add:at_most_once_found_def)
apply(auto)
done

fun complete :: "history \<Rightarrow> history" where
"complete [] = []" |
"complete ((Response d m t)#tail) = (Response d m t)#(complete tail)" |
"complete ((Invocation d m t)#tail) = (if (has_response (Invocation d m t) tail)
                                     then (Invocation d m t)#(complete tail)
                                     else (complete tail))"

value "(complete [(Invocation ''a'' ''b'' 1), (Invocation ''a'' ''b'' 2), (Response ''a'' ''b'' 1)])"

fun method_call_precedes :: "history \<Rightarrow> history_element \<Rightarrow> history_element \<Rightarrow> bool" where
"method_call_precedes h (Invocation d1 m1 t1) (Invocation d2 m2 t2) =
  (if (\<not>((is_in h (Invocation d1 m1 t1) \<and> (is_in h (Response d1 m1 t1)) \<and> (is_in h (Invocation d2 m2 t2)))))
     then False
   else
     (precedes h (Response d1 m1 t1) (Invocation d2 m2 t2)))" |
"method_call_precedes h _ _  = False"

lemma "(\<not>(is_in h (Invocation d1 m1 t1)) \<and> (is_well_formed h))
        \<longrightarrow> \<not>(method_call_precedes h (Invocation d1 m1 t1) (Invocation d2 m2 t2))"
apply(auto)
done

lemma "(\<not>(is_in h (Invocation d1 m1 t1)) \<and> (is_well_formed h))
        \<longrightarrow> \<not>(method_call_precedes h (Invocation d1 m1 t1) (Invocation d2 m2 t2))"
apply(auto)
done

definition is_linearizable :: "history \<Rightarrow> bool" where
"is_linearizable H =
  (\<exists>extension.((is_extension extension H)
              \<and> (is_well_formed extension)
              \<and> (\<exists>S.((is_sequential S)
                      \<and> (is_well_formed S)
                      \<and> (are_equivalent (complete extension) S)) (* L1 *)
                      \<and> (\<forall>m0.(\<forall>m1.(method_call_precedes H m0 m1)
                                   \<longrightarrow> (method_call_precedes S m0 m1))) (*L2*)
)))"

fun object_subhistory :: "history \<Rightarrow> data_object \<Rightarrow> history" where
"object_subhistory (h1#tail) object =
  (if ((get_object h1) = object) then h1#(object_subhistory tail object) else (object_subhistory tail object))" |
"object_subhistory [] t = []"

lemma "linearizability_is_compositional" :
    "(is_well_formed H) \<longrightarrow>
       ((\<forall>object.(is_linearizable (object_subhistory H object))) \<longrightarrow> (is_linearizable H))"
apply(auto)
apply(simp add:is_linearizable_def add:is_well_formed_def add:is_extension_def add:is_sequential_def add:at_most_once_found_def)
apply(auto)
apply(rule exI)
apply(auto)
apply(rule exI)
apply(rule mp)
apply(auto)
apply(rule allE)
apply(auto)
(* tbc *)


theory ComputeNumeral
imports ComputeHOL ComputeFloat
begin

(* equality for bit strings *)
lemmas biteq = eq_num_simps

(* x < y for bit strings *)
lemmas bitless = less_num_simps

(* x \<le> y for bit strings *)
lemmas bitle = le_num_simps

(* addition for bit strings *)
lemmas bitadd = add_num_simps

(* multiplication for bit strings *)
lemmas bitmul = mult_num_simps

lemmas bitarith = arith_simps

(* Normalization of nat literals *)
lemmas natnorm = one_eq_Numeral1_nat

fun natfac :: "nat \<Rightarrow> nat"
  where "natfac n = (if n = 0 then 1 else n * (natfac (n - 1)))"

lemmas compute_natarith =
  arith_simps rel_simps
  diff_nat_numeral nat_numeral nat_0 nat_neg_numeral
  numeral_1_eq_1 [symmetric]
  numeral_1_eq_Suc_0 [symmetric]
  Suc_numeral natfac.simps

lemmas number_norm = numeral_1_eq_1[symmetric]

lemmas compute_numberarith =
  arith_simps rel_simps number_norm

lemmas compute_num_conversions =
  real_of_nat_numeral real_of_nat_zero
  nat_numeral nat_0 nat_neg_numeral
  real_numeral real_of_int_zero

lemmas zpowerarith = zpower_numeral_even zpower_numeral_odd zpower_Pls int_pow_1

(* div, mod *)

lemma adjust: "adjust b (q, r) = (if 0 \<le> r - b then (2 * q + 1, r - b) else (2 * q, r))"
  by (auto simp only: adjust_def)

lemma divmod: "divmod_int a b = (if 0\<le>a then
                  if 0\<le>b then posDivAlg a b
                  else if a=0 then (0, 0)
                       else apsnd uminus (negDivAlg (-a) (-b))
               else
                  if 0<b then negDivAlg a b
                  else apsnd uminus (posDivAlg (-a) (-b)))"
  by (auto simp only: divmod_int_def)

lemmas compute_div_mod = div_int_def mod_int_def divmod adjust apsnd_def map_prod_def posDivAlg.simps negDivAlg.simps

(* collecting all the theorems *)

lemma even_0_int: "even (0::int) = True"
  by simp

lemma even_One_int: "even (numeral Num.One :: int) = False"
  by simp

lemma even_Bit0_int: "even (numeral (Num.Bit0 x) :: int) = True"
  by (simp only: even_numeral)

lemma even_Bit1_int: "even (numeral (Num.Bit1 x) :: int) = False"
  by (simp only: odd_numeral)

lemmas compute_even = even_0_int even_One_int even_Bit0_int even_Bit1_int

lemmas compute_numeral = compute_if compute_let compute_pair compute_bool
                         compute_natarith compute_numberarith max_def min_def compute_num_conversions zpowerarith compute_div_mod compute_even

end


theory FSet_More
imports  "HOL-Library.FSet"
begin

lemma Suc_pred_image[simp]: "0 \<notin> P \<Longrightarrow> (\<lambda>x. Suc (x - Suc 0)) ` P = P"
    unfolding image_def by safe (metis Suc_pred neq0_conv)+

context includes fset.lifting begin

lemmas Suc_pred_fimage[simp] = Suc_pred_image[Transfer.transferred]

end

lemma ffilter_eq_fempty_iff:
  "ffilter P X = {||} \<longleftrightarrow> (\<forall>x. x |\<in>| X \<longrightarrow> \<not> P x)"
  "{||} = ffilter P X \<longleftrightarrow> (\<forall>x. x |\<in>| X \<longrightarrow> \<not> P x)"
  by auto

lemma max_ffilter_below[simp]: "\<lbrakk>x |\<in>| P; x < n\<rbrakk> \<Longrightarrow>
  max n (Suc (fMax (ffilter (\<lambda>i. i < n) P))) = n"
  by (metis max.absorb1 Suc_leI fMax_in fempty_iff ffmember_filter)

lemma fMax_boundedD:
  "\<lbrakk>fMax P < n; x |\<in>| P\<rbrakk> \<Longrightarrow> x < n"
  "\<lbrakk>fMax P \<le> n; n |\<notin>| P; x |\<in>| P\<rbrakk> \<Longrightarrow> x < n"
  by (metis fMax_ge le_less_trans, metis fMax_ge leD neqE order.strict_trans2)

lemma fMax_ffilter_less: "x |\<in>| P \<Longrightarrow> x < n \<Longrightarrow> fMax (ffilter (\<lambda>i. i < n) P) < n"
  by (metis fMax_in ffilter_eq_fempty_iff(2) ffmember_filter)

end


theory quasimaxchrIs1 imports Main       (* Quasi-maximality: C. Benzmüller & X. Parent, 2020 *)

(* Quasi-maximality, Deb 1977, means maximal wrt transitive closure of the betterness relation restricted to the menu *)
(* Quasi-maximality: ideally the transitive closure should be paramatrized by a context.
It is restricted to the set of antecedent-worlds. The transitive closure should be recalculated each time
each time the set of worlds in which the antecedent is true changes  *)

begin
typedecl i (*Possible worlds.*)
type_synonym \<sigma> = "(i\<Rightarrow>bool)"
type_synonym \<alpha> = "i\<Rightarrow>\<sigma>" (*Type of betterness relation between worlds.*)
type_synonym \<tau> = "\<sigma>\<Rightarrow>\<sigma>"

consts aw::i (*Actual world.*)
abbreviation etrue  :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation efalse :: "\<sigma>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation enot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation eand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation eor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation eimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation eequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

(*Possibilist--constant domain--quantification.*)
abbreviation eforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
abbreviation eforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation eexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
abbreviation eexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

abbreviation ebox :: "\<sigma>\<Rightarrow>\<sigma>" ("\<box>") where "\<box> \<equiv> \<lambda>\<phi> w.  \<forall>v. \<phi>(v)"

(* Some useful relations for constraining accessibility relations*)

definition transitive :: "\<alpha>\<Rightarrow>bool" where "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
definition sub_rel :: "\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where "sub_rel R Q \<equiv> \<forall>u v. R u v \<longrightarrow> Q u v"

(*In HOL the transitive closure of a relation can be defined in a single line.*)
definition tc :: "\<alpha>\<Rightarrow>\<alpha>" where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"

consts BRel :: "\<alpha>" (infixr "R" 70) (*Betterness relation, cf. def. of \<circle><_|_>.*)
(*Original Max, wrt to R

abbreviation max  :: "\<sigma>\<Rightarrow>\<sigma>" ("max<_>")
  where "max<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x)\<and> x R v  \<longrightarrow>  v  R x))) )"
*)

abbreviation qmax  :: "\<sigma>\<Rightarrow>\<sigma>" ("qmax<_>")(*quasimax, i.e. max wrt to tc(R)*)
  where "qmax<\<phi>> \<equiv> (\<lambda>v. ((\<phi> v) \<and> (\<forall>x. ((\<phi> x) \<and> ((tc BRel) x v)  \<longrightarrow>  ((tc BRel) v x)))) )"

abbreviation subset :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"

abbreviation cond  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv>  \<lambda>w. qmax<\<phi>> \<^bold>\<subseteq> \<psi>"

abbreviation evalid :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)  (*Global validity.*)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
abbreviation ecjactual :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) (*Local validity — in world aw.*)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

lemma True nitpick [satisfy,user_axioms,expect=genuine] oops (*Consistency conf.*)

lemma RM: "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>" nitpick oops

lemma DR: "\<lfloor>\<circle><\<xi>|(\<phi>\<^bold>\<or>\<psi>)> \<^bold>\<rightarrow> (\<circle><\<xi>|\<phi>> \<^bold>\<or> \<circle><\<xi>|\<psi>>)\<rfloor>" nitpick[show_all,format=2]

(*Correspondence theory. old stuff
lemma assumes "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
      shows "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
  using assms by blast

lemma assumes "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
      shows "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
  nitpick [show_all,format=2] oops (*Countermodel presented by Nitpick.*)
*)
end


theory ConceptsAsModalitiesDL
  imports Main
begin
typedecl i (* type for individuals *)
typedecl v (* type for views *)
consts "vn" :: "v" (* normal view *)
type_synonym concept = "i\<times>v\<times>v\<Rightarrow>bool"
type_synonym relation = "i\<times>i\<Rightarrow>bool"

abbreviation dldisj :: "concept\<Rightarrow>concept\<Rightarrow>concept" (infixr"\<squnion>"50)
  where "C\<squnion>D \<equiv> \<lambda>(x,v1,v2). C(x,v1,v2)\<or>D(x,v1,v2)"
abbreviation dlnot :: "concept\<Rightarrow>concept" ("\<^bold>\<not>_"[53]53)
  where "\<^bold>\<not>C  \<equiv> \<lambda>(x,v1,v2). v1=v2 \<and> \<not>(\<exists>v3. C(x,v1,v3))"
abbreviation dlconj :: "concept\<Rightarrow>concept\<Rightarrow>concept" (infixr"\<sqinter>"51)
  where "C\<sqinter>D \<equiv> \<lambda>(x,v1,v2). (\<exists>v3. C(x,v1,v3))\<and>(\<exists>v4. D(x,v1,v4))\<and>(C\<squnion>D)(x,v1,v2)"
abbreviation dlexists :: "relation\<Rightarrow>concept\<Rightarrow>concept" ("\<^bold>\<exists>_._"[8]9)
  where "\<^bold>\<exists>R. C \<equiv> \<lambda>(x,v1,v2). \<exists>y. R(x,y) \<and> C(y,v1,v2)"
abbreviation dlforall :: "relation\<Rightarrow>concept\<Rightarrow>concept" ("\<^bold>\<forall>_._"[8]9)
  where "\<^bold>\<forall>R. C \<equiv> \<lambda>(x,v1,v2). \<forall>y. R(x,y)\<longrightarrow>C(y,v1,v2)"

abbreviation dlgen :: "concept\<Rightarrow>concept\<Rightarrow>concept" (infixr"\<midarrow>\<circ>"52)
  where "C \<midarrow>\<circ> D \<equiv> \<lambda>(x,v1,v2). \<exists>v3. C(x,v1,v3) \<and> D(x,v3,v2)"

abbreviation dltop :: "concept" ("\<top>")
  where "\<top> \<equiv> \<lambda>(x,v1,v2). v1=v2"
abbreviation dlbot :: "concept" ("\<bottom>")
  where "\<bottom> \<equiv> \<lambda>(x,v1,v2). False"

abbreviation subsums :: "concept\<Rightarrow>concept\<Rightarrow>bool" (infixr"\<sqsubseteq>"48)
  where "C\<sqsubseteq>D \<equiv> \<forall>v1. \<forall>x. (\<exists>v2. C(x,v1,v2))\<longrightarrow>(\<exists>v3. D(x,v1,v3))"
abbreviation equi :: "concept\<Rightarrow>concept\<Rightarrow>bool" (infixr"\<^bold>\<equiv>"48)
  where "C\<^bold>\<equiv>D \<equiv> (C\<sqsubseteq>D) \<and> (D\<sqsubseteq>C)"

abbreviation dlass :: "i \<Rightarrow> concept \<Rightarrow> bool" (infixr"\<^bold>:"52)
  where "a\<^bold>:C \<equiv> \<exists>v2. C(a,vn,v2)"

axiomatization where
 ConceptAx: "\<And>C D x y v1 v2 v3. (C::concept)(x,v1,v2) \<and> (D::concept)(y,v3,v2)
                                        \<longrightarrow> C(y,v1,v2)"
(*  ConceptRelAx: "\<And>C v1 v2. (\<exists>x. C(x,v1,v2)) \<longrightarrow> q(C,v1,v2)" and
  InViewAx: "\<And>v x. (\<exists>C. \<exists>v1. C(x,v1,v)) \<longrightarrow> e(v,x)" and
  ConceptTrippleAx: "\<And>C v1 v2 x. q(C,v1,v2) \<and> e(v2,x) \<longrightarrow> C(x,v1,v2)" *)

theorem "x \<^bold>: \<top>"
  by blast

theorem "\<bottom> \<^bold>\<equiv> \<^bold>\<not>\<top>"
  by blast

(* timed out:
theorem False sledgehammer *)
(* nitpick: empty assignment *)
(* theorem True nitpick[satisfy,user_axioms=true] *)

end