(*  Title:   Measure_QuasiBorel_Adjunction.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection \<open>Relation to Measurable Spaces\<close>

theory Measure_QuasiBorel_Adjunction
  imports "QuasiBorel"
begin

text \<open> We construct the adjunction between \textbf{Meas} and \textbf{QBS},
       where \textbf{Meas} is the category of measurable spaces and measurable functions
       and \textbf{QBS} is the category of quasi-Borel spaces and morphisms.\<close>

subsubsection \<open> The Functor $R$ \<close>
definition measure_to_qbs :: "'a measure \<Rightarrow> 'a quasi_borel" where
"measure_to_qbs X \<equiv> Abs_quasi_borel (space X, real_borel \<rightarrow>\<^sub>M X)"

lemma R_Mx_correct: "real_borel \<rightarrow>\<^sub>M X \<subseteq> UNIV \<rightarrow> space X"
  by (simp add: measurable_space subsetI)

lemma R_qbs_closed1: "qbs_closed1 (real_borel \<rightarrow>\<^sub>M X)"
  by (simp add: qbs_closed1_def)

lemma R_qbs_closed2: "qbs_closed2 (space X) (real_borel \<rightarrow>\<^sub>M X)"
  by (simp add: qbs_closed2_def)

lemma R_qbs_closed3: "qbs_closed3 (real_borel \<rightarrow>\<^sub>M (X :: 'a measure))"
proof(rule qbs_closed3I)
  fix P::"real \<Rightarrow> nat"
  fix Fi::"nat \<Rightarrow> real \<Rightarrow> 'a"
  assume h:"\<And>i. P -` {i} \<in> sets real_borel"
           "\<And>i. Fi i \<in> real_borel \<rightarrow>\<^sub>M X"
  show "(\<lambda>r. Fi (P r) r) \<in> real_borel \<rightarrow>\<^sub>M X"
  proof(rule measurableI)
    fix x
    assume "x \<in> space real_borel"
    then show "Fi (P x) x \<in> space X"
      using h(2) measurable_space[of "Fi (P x)" real_borel X x]
      by auto
  next
    fix A
    assume h':"A \<in> sets X"
    have "(\<lambda>r. Fi (P r) r) -` A = (\<Union>i::nat. ((Fi i -` A) \<inter> (P -` {i})))"
      by auto
    also have "... \<in> sets real_borel"
      using sets.Int measurable_sets[OF h(2) h'] h(1)
      by(auto intro!: countable_Un_Int(1))
    finally show "(\<lambda>r. Fi (P r) r) -` A \<inter> space real_borel \<in> sets real_borel"
      by simp
  qed
qed

lemma R_correct[simp]: "Rep_quasi_borel (measure_to_qbs X) = (space X, real_borel \<rightarrow>\<^sub>M X)"
  unfolding measure_to_qbs_def
  by (rule Abs_quasi_borel_inverse) (simp add: R_Mx_correct R_qbs_closed1 R_qbs_closed2 R_qbs_closed3)

lemma qbs_space_R[simp]: "qbs_space (measure_to_qbs X) = space X"
  by (simp add: qbs_space_def)

lemma qbs_Mx_R[simp]: "qbs_Mx (measure_to_qbs X) = real_borel \<rightarrow>\<^sub>M X"
  by (simp add: qbs_Mx_def)

text \<open> The following lemma says that @{term measure_to_qbs} is a functor from \textbf{Meas} to \textbf{QBS}. \<close>
lemma r_preserves_morphisms:
   "X \<rightarrow>\<^sub>M Y \<subseteq> (measure_to_qbs X) \<rightarrow>\<^sub>Q (measure_to_qbs Y)"
  by(auto intro!: qbs_morphismI)

subsubsection \<open> The Functor $L$ \<close>
definition sigma_Mx :: "'a quasi_borel \<Rightarrow> 'a set set" where
"sigma_Mx X \<equiv> {U \<inter> qbs_space X |U. \<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` U \<in> sets real_borel}"

definition qbs_to_measure :: "'a quasi_borel \<Rightarrow> 'a measure" where
"qbs_to_measure X \<equiv> Abs_measure (qbs_space X, sigma_Mx X, \<lambda>A. (if A = {} then 0 else if A \<in> - sigma_Mx X then 0 else \<infinity>))"

lemma measure_space_L: "measure_space (qbs_space X) (sigma_Mx X) (\<lambda>A. (if A = {} then 0 else if A \<in> - sigma_Mx X then 0 else \<infinity>))"
  unfolding measure_space_def
proof auto

  show "sigma_algebra (qbs_space X) (sigma_Mx X)"
  proof(rule sigma_algebra.intro)
    show "algebra (qbs_space X) (sigma_Mx X)"
    proof
      have "\<forall> U \<in> sigma_Mx X. U \<subseteq> qbs_space X"
        using sigma_Mx_def subset_iff by fastforce
      thus "sigma_Mx X \<subseteq> Pow (qbs_space X)" by auto
    next
      show "{} \<in> sigma_Mx X"
        unfolding sigma_Mx_def by auto
    next
      fix A
      fix B
      assume "A \<in> sigma_Mx X"
             "B \<in> sigma_Mx X"
      then have "\<exists> Ua. A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)"
        by (simp add: sigma_Mx_def)
      then obtain Ua where pa:"A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)" by auto
      have "\<exists> Ub. B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)"
        using \<open>B \<in> sigma_Mx X\<close> sigma_Mx_def by auto
      then obtain Ub where pb:"B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)" by auto
      from pa pb have [simp]:"\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (Ua \<inter> Ub) \<in> sets real_borel"
        by auto
      from this pa pb sigma_Mx_def have [simp]:"(Ua \<inter> Ub) \<inter> qbs_space X \<in> sigma_Mx X" by blast
      from pa pb have [simp]:"A \<inter> B = (Ua \<inter> Ub) \<inter> qbs_space X" by auto
      thus "A \<inter> B \<in> sigma_Mx X" by simp
    next
      fix A
      fix B
      assume "A \<in> sigma_Mx X"
             "B \<in> sigma_Mx X"
      then have "\<exists> Ua. A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)"
        by (simp add: sigma_Mx_def)
      then obtain Ua where pa:"A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)" by auto
      have "\<exists> Ub. B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)"
        using \<open>B \<in> sigma_Mx X\<close> sigma_Mx_def by auto
      then obtain Ub where pb:"B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)" by auto
      from pa pb have [simp]:"A - B = (Ua \<inter> -Ub) \<inter> qbs_space X" by auto
      from pa pb have "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -`(Ua \<inter> -Ub) \<in> sets real_borel"
        by (metis Diff_Compl double_compl sets.Diff vimage_Compl vimage_Int)
      hence 1:"A - B \<in> sigma_Mx X"
        using sigma_Mx_def \<open>A - B = Ua \<inter> - Ub \<inter> qbs_space X\<close> by blast
      show "\<exists>C\<subseteq>sigma_Mx X. finite C \<and> disjoint C \<and> A - B = \<Union> C"
      proof
        show "{A - B} \<subseteq>sigma_Mx X \<and> finite {A-B} \<and> disjoint {A-B} \<and> A - B = \<Union> {A-B}"
          using 1 by auto
      qed
    next
      fix A
      fix B
      assume "A \<in> sigma_Mx X"
             "B \<in> sigma_Mx X"
      then have "\<exists> Ua. A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)"
        by (simp add: sigma_Mx_def)
      then obtain Ua where pa:"A = Ua \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel)" by auto
      have "\<exists> Ub. B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)"
        using \<open>B \<in> sigma_Mx X\<close> sigma_Mx_def by auto
      then obtain Ub where pb:"B = Ub \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ub \<in> sets real_borel)" by auto
      from pa pb have "A \<union> B = (Ua \<union> Ub) \<inter> qbs_space X" by auto
      from pa pb have "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -`(Ua \<union> Ub) \<in> sets real_borel" by auto
      then show "A \<union> B \<in> sigma_Mx X"
        unfolding sigma_Mx_def
        using \<open>A \<union> B = (Ua \<union> Ub) \<inter> qbs_space X\<close> by blast
    next
      have "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (UNIV) \<in> sets real_borel"
        by simp
      thus "qbs_space X \<in> sigma_Mx X"
        unfolding sigma_Mx_def
        by blast
    qed
  next
    show "sigma_algebra_axioms (sigma_Mx X)"
      unfolding sigma_algebra_axioms_def
    proof(auto)
      fix A :: "nat \<Rightarrow> _"
      assume 1:"range A \<subseteq> sigma_Mx X"
      then have 2:"\<forall>i. \<exists>Ui. A i = Ui \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ui \<in> sets real_borel)"
        unfolding sigma_Mx_def by auto
      then have "\<exists> U :: nat \<Rightarrow> _. \<forall>i. A i = U i \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (U i) \<in> sets real_borel)"
        by (rule choice)
      from this obtain U where pu:"\<forall>i. A i = U i \<inter> qbs_space X \<and> (\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (U i) \<in> sets real_borel)"
        by auto
      hence "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (\<Union> (range U)) \<in> sets real_borel"
        by (simp add: countable_Un_Int(1) vimage_UN)
      from pu have "\<Union> (range A) = (\<Union>i::nat. (U i \<inter> qbs_space X))" by blast
      hence "\<Union> (range A) = \<Union> (range U) \<inter> qbs_space X" by auto
      thus "\<Union> (range A) \<in> sigma_Mx X"
        using sigma_Mx_def \<open>\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` \<Union> (range U) \<in> sets real_borel\<close> by blast
    qed
  qed
next
  show "countably_additive (sigma_Mx X) (\<lambda>A. if A = {} then 0 else if A \<in> - sigma_Mx X then 0 else \<infinity>)"
  proof(rule countably_additiveI)
    fix A :: "nat \<Rightarrow> _"
    assume h:"range A \<subseteq> sigma_Mx X"
             "\<Union> (range A) \<in> sigma_Mx X"
    consider "\<Union> (range A) = {}" | "\<Union> (range A) \<noteq> {}"
      by auto
    then show "(\<Sum>i. if A i = {} then 0 else if A i \<in> - sigma_Mx X then 0 else \<infinity>) =
               (if \<Union> (range A) = {} then 0 else if \<Union> (range A) \<in> - sigma_Mx X then 0 else (\<infinity> :: ennreal))"
    proof cases
      case 1
      then have "\<And>i. A i = {}"
        by simp
      thus ?thesis
        by(simp add: 1)
    next
      case 2
      then obtain j where hj:"A j \<noteq> {}"
        by auto
      have "(\<Sum>i. if A i = {} then 0  else if A i \<in> - sigma_Mx X then 0 else \<infinity>) = (\<infinity> :: ennreal)"
      proof -
        have hsum:"\<And>N f. sum f {..<N} \<le> (\<Sum>n. (f n :: ennreal))"
          by (simp add: sum_le_suminf)
        have hsum':"\<And>P f. (\<exists>j. j \<in> P \<and> f j = (\<infinity> :: ennreal)) \<Longrightarrow> finite P \<Longrightarrow> sum f P = \<infinity>"
          by auto
        have h1:"(\<Sum>i<j+1. if A i = {} then 0 else if A i \<in> - sigma_Mx X then 0 else \<infinity>) = (\<infinity> :: ennreal)"
        proof(rule hsum')
          show "\<exists>ja. ja \<in> {..<j + 1} \<and> (if A ja = {} then 0 else if A ja \<in> - sigma_Mx X then 0 else \<infinity>) = (\<infinity> :: ennreal)"
          proof(rule exI[where x=j],rule conjI)
            have "A j \<in> sigma_Mx X"
              using h(1) by auto
            then show "(if A j = {} then 0 else if A j \<in> - sigma_Mx X then 0 else \<infinity>) = (\<infinity> :: ennreal)"
              using hj by simp
          qed simp
        qed simp
        have "(\<Sum>i<j+1. if A i = {} then 0 else if A i \<in> - sigma_Mx X then 0 else \<infinity>) \<le> (\<Sum>i. if A i = {} then 0 else if A i \<in> - sigma_Mx X then 0 else (\<infinity> :: ennreal))"
          by(rule hsum)
        thus ?thesis
          by(simp only: h1) (simp add: top.extremum_unique)
      qed
      moreover have "(if \<Union> (range A) = {} then 0 else if \<Union> (range A) \<in> - sigma_Mx X then 0 else \<infinity>) = (\<infinity> :: ennreal)"
        using 2 h(2) by simp
      ultimately show ?thesis
        by simp
    qed
  qed
qed(simp add: positive_def)

lemma L_correct[simp]:"Rep_measure (qbs_to_measure X) = (qbs_space X, sigma_Mx X, \<lambda>A. (if A = {} then 0 else if A \<in> - sigma_Mx X then 0 else \<infinity>))"
  unfolding qbs_to_measure_def
  by(auto intro!: Abs_measure_inverse simp: measure_space_L)

lemma space_L[simp]: "space (qbs_to_measure X) = qbs_space X"
  by (simp add: space_def)

lemma sets_L[simp]: "sets (qbs_to_measure X) = sigma_Mx X"
  by (simp add: sets_def)

lemma emeasure_L[simp]: "emeasure (qbs_to_measure X) = (\<lambda>A. if A = {} \<or> A \<notin> sigma_Mx X then 0 else \<infinity>)"
  by(auto simp: emeasure_def)

lemma qbs_Mx_sigma_Mx_contra:
  assumes "qbs_space X = qbs_space Y"
      and "qbs_Mx X \<subseteq> qbs_Mx Y"
  shows "sigma_Mx Y \<subseteq> sigma_Mx X"
  using assms by(auto simp: sigma_Mx_def)

text \<open> The following lemma says that @{term qbs_to_measure} is a functor from \textbf{QBS} to \textbf{Meas}. \<close>
lemma l_preserves_morphisms:
  "X \<rightarrow>\<^sub>Q Y \<subseteq> (qbs_to_measure X) \<rightarrow>\<^sub>M (qbs_to_measure Y)"
proof(auto)
  fix f
  assume h:"f \<in> X \<rightarrow>\<^sub>Q Y"
  show "f \<in> (qbs_to_measure X) \<rightarrow>\<^sub>M (qbs_to_measure Y)"
  proof(rule measurableI)
    fix x
    assume "x \<in> space (qbs_to_measure X)"
    then show "f x \<in> space (qbs_to_measure Y)"
      using h by auto
  next
    fix A
    assume "A \<in> sets (qbs_to_measure Y)"
    then obtain Ua where pa:"A = Ua \<inter> qbs_space Y \<and> (\<forall>\<alpha>\<in>qbs_Mx Y. \<alpha> -` Ua \<in> sets real_borel)"
      by (auto simp: sigma_Mx_def)
    have "\<forall>\<alpha>\<in>qbs_Mx X. f \<circ> \<alpha> \<in> qbs_Mx Y"
         "\<forall>\<alpha>\<in> qbs_Mx X. \<alpha> -` (f -` (qbs_space Y)) = UNIV"
      using h by auto
    hence "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (f -` A) = \<alpha> -` (f -` Ua)"
      by (simp add: pa)
    from pa this qbs_morphism_def have "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` (f -` A) \<in> sets real_borel"
      by (simp add: vimage_comp \<open>\<forall>\<alpha>\<in>qbs_Mx X. f \<circ> \<alpha> \<in> qbs_Mx Y\<close>)
    thus "f -` A \<inter> space (qbs_to_measure X) \<in> sets (qbs_to_measure X)"
      using sigma_Mx_def by auto
  qed
qed

abbreviation "qbs_borel \<equiv> measure_to_qbs borel"

declare [[coercion measure_to_qbs]]

abbreviation real_quasi_borel :: "real quasi_borel" ("\<real>\<^sub>Q") where
"real_quasi_borel \<equiv> qbs_borel"
abbreviation nat_quasi_borel :: "nat quasi_borel" ("\<nat>\<^sub>Q") where
"nat_quasi_borel \<equiv> qbs_borel"
abbreviation ennreal_quasi_borel :: "ennreal quasi_borel" ("\<real>\<^sub>Q\<^sub>\<ge>\<^sub>0") where
"ennreal_quasi_borel \<equiv> qbs_borel"
abbreviation bool_quasi_borel :: "bool quasi_borel" ("\<bool>\<^sub>Q") where
"bool_quasi_borel \<equiv> qbs_borel"

lemma qbs_Mx_is_morphisms:
 "qbs_Mx X = real_quasi_borel \<rightarrow>\<^sub>Q X"
proof(auto)
  fix \<alpha>
  assume "\<alpha> \<in> qbs_Mx X"
  then have "\<alpha> \<in> UNIV \<rightarrow> qbs_space X \<and> (\<forall> f \<in> real_borel \<rightarrow>\<^sub>M real_borel. \<alpha> \<circ> f \<in> qbs_Mx X)"
    by fastforce
  thus "\<alpha> \<in> real_quasi_borel \<rightarrow>\<^sub>Q X"
    by(simp add: qbs_morphism_def)
next
  fix \<alpha>
  assume "\<alpha> \<in> real_quasi_borel \<rightarrow>\<^sub>Q X"
  have "id \<in> qbs_Mx real_quasi_borel" by simp
  then have "\<alpha> \<circ> id \<in> qbs_Mx X"
    using \<open>\<alpha> \<in> real_quasi_borel \<rightarrow>\<^sub>Q X\<close> qbs_morphism_def[of real_quasi_borel X]
    by blast
  then show "\<alpha> \<in> qbs_Mx X" by simp
qed

lemma qbs_Mx_subset_of_measurable:
  "qbs_Mx X \<subseteq> real_borel \<rightarrow>\<^sub>M qbs_to_measure X"
proof
  fix \<alpha>
  assume "\<alpha> \<in> qbs_Mx X"
  show "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M qbs_to_measure X"
  proof(rule measurableI)
    fix x
    show "\<alpha> x \<in> space (qbs_to_measure X)"
      using qbs_decomp \<open>\<alpha> \<in> qbs_Mx X\<close> by auto
  next
    fix A
    assume "A \<in> sets (qbs_to_measure X)"
    then have "\<alpha> -`(qbs_space X) = UNIV"
      using \<open>\<alpha> \<in> qbs_Mx X\<close> qbs_decomp by auto
    then show "\<alpha> -` A \<inter> space real_borel \<in> sets real_borel"
      using \<open>\<alpha> \<in> qbs_Mx X\<close> \<open>A \<in> sets (qbs_to_measure X)\<close>
      by(auto simp add: sigma_Mx_def)
  qed
qed

lemma L_max_of_measurables:
  assumes "space M = qbs_space X"
      and "qbs_Mx X \<subseteq> real_borel \<rightarrow>\<^sub>M M"
    shows "sets M \<subseteq> sets (qbs_to_measure X)"
proof
  fix U
  assume "U \<in> sets M"
  from sets.sets_into_space[OF this] in_mono[OF assms(2)] measurable_sets_borel[OF _ this]
  show "U \<in> sets (qbs_to_measure X)"
    using assms(1)
    by(auto intro!: exI[where x=U] simp: sigma_Mx_def)
qed

lemma qbs_Mx_are_measurable[simp,measurable]:
  assumes "\<alpha> \<in> qbs_Mx X"
  shows "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M qbs_to_measure X"
  using assms qbs_Mx_subset_of_measurable by auto

lemma measure_to_qbs_cong_sets:
  assumes "sets M = sets N"
  shows "measure_to_qbs M = measure_to_qbs N"
  by(rule qbs_eqI) (simp add: measurable_cong_sets[OF _ assms])

lemma lr_sets[simp,measurable_cong]:
 "sets X \<subseteq> sets (qbs_to_measure (measure_to_qbs X))"
proof auto
  fix U
  assume "U \<in> sets X"
  then have "U \<inter> space X = U" by simp
  moreover have "\<forall>\<alpha>\<in>real_borel \<rightarrow>\<^sub>M X. \<alpha> -` U \<in> sets real_borel"
    using \<open>U \<in> sets X\<close> by(auto simp add: measurable_def)
  ultimately show "U \<in> sigma_Mx (measure_to_qbs X)"
    by(auto simp add: sigma_Mx_def)
qed

lemma(in standard_borel) standard_borel_lr_sets_ident[simp, measurable_cong]:
 "sets (qbs_to_measure (measure_to_qbs M)) = sets M"
proof auto
  fix V
  assume "V \<in> sigma_Mx (measure_to_qbs M)"
  then obtain U where H2: "V = U \<inter> space M \<and> (\<forall>\<alpha>\<in>real_borel \<rightarrow>\<^sub>M M. \<alpha> -` U \<in> sets real_borel)"
    by(auto simp: sigma_Mx_def)
  hence "g -` V = g -` (U \<inter> space M)" by auto
  have "... = g -` U" using g_meas by(auto simp add: measurable_def)
  hence "f -` g -` U  \<inter> space M \<in> sets M"
    by (meson f_meas g_meas measurable_sets H2)
  moreover have "f -` g -` U  \<inter> space M  =  U \<inter> space M"
    by auto
  ultimately show "V \<in> sets M" using H2 by simp
next
  fix U
  assume "U \<in> sets M"
  then show "U \<in> sigma_Mx (measure_to_qbs M)"
    using lr_sets by auto
qed

subsubsection \<open> The Adjunction \<close>
lemma  lr_adjunction_correspondence :
 "X \<rightarrow>\<^sub>Q (measure_to_qbs Y) = (qbs_to_measure X) \<rightarrow>\<^sub>M Y"
proof(auto)
(* \<subseteq> *)
  fix f
  assume "f \<in> X \<rightarrow>\<^sub>Q (measure_to_qbs Y)"
  show "f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y"
  proof(rule measurableI)
    fix x
    assume "x \<in> space (qbs_to_measure X)"
    hence "x \<in> qbs_space X" by simp
    thus "f x \<in> space Y"
      using \<open>f \<in> X \<rightarrow>\<^sub>Q (measure_to_qbs Y)\<close> qbs_morphismE[of f X "measure_to_qbs Y"]
      by auto
  next
    fix A
    assume "A \<in> sets Y"
    have "\<forall>\<alpha> \<in> qbs_Mx X. f \<circ> \<alpha> \<in> qbs_Mx (measure_to_qbs Y)"
      using \<open>f \<in> X \<rightarrow>\<^sub>Q (measure_to_qbs Y)\<close> by auto
    hence "\<forall>\<alpha> \<in> qbs_Mx X. f \<circ> \<alpha> \<in> real_borel \<rightarrow>\<^sub>M Y" by simp
    hence "\<forall>\<alpha> \<in> qbs_Mx X. \<alpha> -` (f -` A) \<in> sets real_borel"
      using \<open>A\<in> sets Y\<close> measurable_sets_borel vimage_comp by metis
    thus "f -` A \<inter> space (qbs_to_measure X) \<in> sets (qbs_to_measure X)"
      using sigma_Mx_def by auto
  qed

(* \<supseteq> *)
next
  fix f
  assume "f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y"
  show "f \<in> X \<rightarrow>\<^sub>Q measure_to_qbs Y"
  proof(rule qbs_morphismI,simp)
    fix \<alpha>
    assume "\<alpha> \<in> qbs_Mx X"
    show "f \<circ> \<alpha> \<in> real_borel \<rightarrow>\<^sub>M Y"
    proof(rule measurableI)
      fix x
      assume "x \<in> space real_borel"
      from this \<open>\<alpha> \<in> qbs_Mx X \<close>qbs_decomp have "\<alpha> x \<in> qbs_space X" by auto
      hence "\<alpha> x \<in> space (qbs_to_measure X)" by simp
      thus "(f \<circ> \<alpha>) x \<in> space Y"
        using \<open>f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y\<close>
        by (metis comp_def measurable_space)
    next
      fix A
      assume "A \<in> sets Y"
      from \<open>f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y\<close> measurable_sets this measurable_def
      have "f -` A \<inter> space (qbs_to_measure X) \<in> sets (qbs_to_measure X)"
        by blast
      hence "f -` A \<inter> qbs_space X \<in> sigma_Mx X" by simp
      then have "\<exists> V. f -` A \<inter> qbs_space X = V \<inter> qbs_space X \<and> (\<forall>\<beta>\<in> qbs_Mx X. \<beta> -` V \<in> sets real_borel)"
        by (simp add:sigma_Mx_def)
      then obtain V where h:"f -` A \<inter> qbs_space X = V \<inter> qbs_space X \<and> (\<forall>\<beta>\<in> qbs_Mx X. \<beta> -` V \<in> sets real_borel)" by auto
      have 1:"\<alpha> -` (f -` A) = \<alpha> -` (f -` A \<inter> qbs_space X)"
        using \<open>\<alpha> \<in> qbs_Mx X\<close> by blast
      have 2:"\<alpha> -` (V \<inter> qbs_space X) = \<alpha> -` V"
        using \<open>\<alpha> \<in> qbs_Mx X\<close> by blast
      from 1 2 h have "(f \<circ> \<alpha>) -` A = \<alpha> -` V" by (simp add: vimage_comp)
      from this h \<open>\<alpha> \<in> qbs_Mx X \<close>show "(f \<circ> \<alpha>) -` A \<inter> space real_borel \<in> sets real_borel" by simp
    qed
  qed
qed

lemma(in standard_borel) standard_borel_r_full_faithful:
  "M \<rightarrow>\<^sub>M Y = measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y"
proof(standard;standard)
  fix h
  assume "h \<in> M \<rightarrow>\<^sub>M Y"
  then show "h \<in> measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y"
    using r_preserves_morphisms by auto
next
  fix h
  assume h:"h \<in> measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y"
  show "h \<in> M \<rightarrow>\<^sub>M Y"
  proof(rule measurableI)
    fix x
    assume "x \<in> space M"
    then show "h x \<in> space Y"
      using h by auto
  next
    fix U
    assume "U \<in> sets Y"
    have "h \<circ> g \<in> real_borel \<rightarrow>\<^sub>M Y"
      using \<open>h \<in> measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y\<close>
      by(simp add: qbs_morphism_def)
    hence "(h \<circ> g) -` U \<in> sets real_borel"
      by (simp add: \<open>U \<in> sets Y\<close> measurable_sets_borel)
    hence "f -` ((h \<circ> g) -` U) \<inter> space M \<in> sets M"
      using f_meas in_borel_measurable_borel by blast
    moreover have "f -` ((h \<circ> g) -` U) \<inter> space M = h -` U \<inter> space M"
      using f_meas by auto
    ultimately show "h -` U \<inter> space M \<in> sets M" by simp
  qed
qed

lemma qbs_morphism_dest[dest]:
  assumes "f \<in> X \<rightarrow>\<^sub>Q measure_to_qbs Y"
  shows "f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y"
  using assms lr_adjunction_correspondence by auto

lemma(in standard_borel) qbs_morphism_dest[dest]:
  assumes "k \<in> measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y"
  shows "k \<in> M \<rightarrow>\<^sub>M Y"
  using standard_borel_r_full_faithful assms by auto

lemma qbs_morphism_measurable_intro[intro!]:
  assumes "f \<in> qbs_to_measure X \<rightarrow>\<^sub>M Y"
  shows "f \<in> X \<rightarrow>\<^sub>Q measure_to_qbs Y"
  using assms lr_adjunction_correspondence by auto

lemma(in standard_borel) qbs_morphism_measurable_intro[intro!]:
  assumes "k \<in> M \<rightarrow>\<^sub>M Y"
  shows "k \<in> measure_to_qbs M \<rightarrow>\<^sub>Q measure_to_qbs Y"
  using standard_borel_r_full_faithful assms by auto

text \<open> We can use the measurability prover when we reason about morphisms. \<close>
lemma
  assumes "f \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
  shows "(\<lambda>x. 2 * f x + (f x)^2) \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
  using assms by auto

lemma
  assumes "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
      and "\<alpha> \<in> qbs_Mx X"
    shows "(\<lambda>x. 2 * f (\<alpha> x) + (f (\<alpha> x))^2) \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
  using assms by auto

lemma qbs_morphisn_from_countable:
  fixes X :: "'a quasi_borel"
  assumes "countable (qbs_space X)"
          "qbs_Mx X \<subseteq> real_borel \<rightarrow>\<^sub>M count_space (qbs_space X)"
      and "\<And>i. i \<in> qbs_space X \<Longrightarrow> f i \<in> qbs_space Y"
    shows "f \<in> X \<rightarrow>\<^sub>Q Y"
proof(rule qbs_morphismI)
  fix \<alpha>
  assume "\<alpha> \<in> qbs_Mx X"
  then have [measurable]: "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M count_space (qbs_space X)"
    using assms(2) ..
  define k :: "'a \<Rightarrow> real \<Rightarrow> _"
    where "k \<equiv> (\<lambda>i _. f i)"
  have "f \<circ> \<alpha> = (\<lambda>r. k (\<alpha> r) r)"
    by(auto simp add: k_def)
  also have "... \<in> qbs_Mx Y"
    by(rule qbs_closed3_dest2[OF assms(1)]) (use assms(3) k_def in simp_all)
  finally show "f \<circ> \<alpha> \<in> qbs_Mx Y" .
qed

corollary nat_qbs_morphism:
  assumes "\<And>n. f n \<in> qbs_space Y"
  shows "f \<in> \<nat>\<^sub>Q \<rightarrow>\<^sub>Q Y"
  using assms measurable_cong_sets[OF refl sets_borel_eq_count_space,of real_borel]
  by(auto intro!: qbs_morphisn_from_countable)

corollary bool_qbs_morphism:
  assumes "\<And>b. f b \<in> qbs_space Y"
  shows "f \<in> \<bool>\<^sub>Q \<rightarrow>\<^sub>Q Y"
  using assms measurable_cong_sets[OF refl sets_borel_eq_count_space,of real_borel]
  by(auto intro!: qbs_morphisn_from_countable)

subsubsection \<open> The Adjunction w.r.t. Ordering\<close>
lemma l_mono:
 "mono qbs_to_measure"
  apply standard
  subgoal for X Y
  proof(induction rule: less_eq_quasi_borel.induct)
    case (1 X Y)
    then show ?case
      by(simp add: less_eq_measure.intros(1))
  next
    case (2 X Y)
    then have "sigma_Mx X \<subseteq> sigma_Mx Y"
      by(auto simp add: sigma_Mx_def)
    then consider "sigma_Mx X \<subset> sigma_Mx Y" | "sigma_Mx X = sigma_Mx Y"
      by auto
    then show ?case
      apply(cases)
       apply(rule less_eq_measure.intros(2))
        apply(simp_all add: 2)
      by(rule less_eq_measure.intros(3),simp_all add: 2)
  qed
  done

lemma r_mono:
 "mono measure_to_qbs"
  apply standard
  subgoal for M N
  proof(induction rule: less_eq_measure.inducts)
    case (1 M N)
    then show ?case
      by(simp add: less_eq_quasi_borel.intros(1))
  next
    case (2 M N)
    then have "real_borel \<rightarrow>\<^sub>M N \<subseteq> real_borel \<rightarrow>\<^sub>M M"
      by(simp add: measurable_mono)
    then consider "real_borel \<rightarrow>\<^sub>M N \<subset> real_borel \<rightarrow>\<^sub>M M" | "real_borel \<rightarrow>\<^sub>M N = real_borel \<rightarrow>\<^sub>M M"
      by auto
    then show ?case
      by cases (rule less_eq_quasi_borel.intros(2),simp_all add: 2)+
  next
    case (3 M N)
    then show ?case
      apply -
      by(rule less_eq_quasi_borel.intros(2)) (simp_all add: measurable_mono)
  qed
  done

lemma rl_order_adjunction:
  "X \<le> qbs_to_measure Y \<longleftrightarrow> measure_to_qbs X \<le> Y"
proof
  assume 1: "X \<le> qbs_to_measure Y"
  then show "measure_to_qbs X \<le> Y"
  proof(induction rule: less_eq_measure.cases)
    case (1 M N)
    then have [simp]:"qbs_space Y = space N"
      by(simp add: 1(2)[symmetric])
    show ?case
      by(rule less_eq_quasi_borel.intros(1),simp add: 1)
  next
    case (2 M N)
    then have [simp]:"qbs_space Y = space N"
      by(simp add: 2(2)[symmetric])
    show ?case
    proof(rule less_eq_quasi_borel.intros(2),simp add:2,auto)
      fix \<alpha>
      assume h:"\<alpha> \<in> qbs_Mx Y"
      show "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M X"
      proof(rule measurableI,simp_all)
        show "\<And>x. \<alpha> x \<in> space X"
          using h by (auto simp add: 2)
      next
        fix A
        assume "A \<in> sets X"
        then have "A \<in> sets (qbs_to_measure Y)"
          using 2 by auto
        then obtain U where
          hu:"A = U \<inter> space N"
             "(\<forall>\<alpha>\<in>qbs_Mx Y. \<alpha> -` U \<in> sets real_borel)"
          by(auto simp add: sigma_Mx_def)
        have "\<alpha> -` A  = \<alpha> -` U"
          using h qbs_decomp[of Y]
          by(auto simp add: hu)
        thus "\<alpha> -` A \<in> sets borel"
          using h hu(2) by simp
      qed
    qed
  next
    case (3 M N)
    then have [simp]:"qbs_space Y = space N"
      by(simp add: 3(2)[symmetric])
    show ?case
    proof(rule less_eq_quasi_borel.intros(2),simp add: 3,auto)
      fix \<alpha>
      assume h:"\<alpha> \<in> qbs_Mx Y"
      show "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M X"
      proof(rule measurableI,simp_all)
        show "\<And>x. \<alpha> x \<in> space X"
          using h by(auto simp: 3)
      next
        fix A
        assume "A \<in> sets X"
        then have "A \<in> sets (qbs_to_measure Y)"
          using 3 by auto
        then obtain U where
          hu:"A = U \<inter> space N"
             "(\<forall>\<alpha>\<in>qbs_Mx Y. \<alpha> -` U \<in> sets real_borel)"
          by(auto simp add: sigma_Mx_def)
        have "\<alpha> -` A  = \<alpha> -` U"
          using h qbs_decomp[of Y]
          by(auto simp add: hu)
        thus "\<alpha> -` A \<in> sets borel"
          using h hu(2) by simp
      qed
    qed
  qed
next
  assume "measure_to_qbs X \<le> Y"
  then show "X \<le> qbs_to_measure Y"
  proof(induction rule: less_eq_quasi_borel.cases)
    case (1 A B)
    have [simp]: "space X = qbs_space A"
      by(simp add: 1(1)[symmetric])
    show ?case
      by(rule less_eq_measure.intros(1)) (simp add: 1)
  next
    case (2 A B)
    then have hmy:"qbs_Mx Y \<subseteq> real_borel \<rightarrow>\<^sub>M X"
      by auto
    have [simp]: "space X = qbs_space A"
      by(simp add: 2(1)[symmetric])
    have "sets X \<subseteq> sigma_Mx Y"
    proof
      fix U
      assume hu:"U \<in> sets X"
      show "U \<in> sigma_Mx Y"
      proof(simp add: sigma_Mx_def,rule exI[where x=U],auto)
        show "\<And>x. x \<in> U \<Longrightarrow> x \<in> qbs_space Y"
          using sets.sets_into_space[OF hu]
          by(auto simp add: 2)
      next
        fix \<alpha>
        assume "\<alpha> \<in> qbs_Mx Y"
        then have "\<alpha> \<in> real_borel \<rightarrow>\<^sub>M X"
          using hmy by(auto)
        thus "\<alpha> -` U \<in> sets real_borel"
          using hu by(simp add: measurable_sets_borel)
      qed
    qed
    then consider "sets X = sigma_Mx Y" | "sets X \<subset> sigma_Mx Y"
      by auto
    then show ?case
    proof cases
      case 1
      show ?thesis
        apply(rule less_eq_measure.intros(3),simp_all add: 1 2)
      proof(rule le_funI)
        fix U
        consider "U = {}" | "U \<notin> sigma_Mx B" | "U \<noteq> {} \<and> U \<in> sigma_Mx B"
          by auto
        then show "emeasure X U \<le> (if U = {} \<or> U \<notin> sigma_Mx B then 0 else \<infinity>)"
        proof cases
          case 1
          then show ?thesis by simp
        next
          case h:2
          then have "U \<notin> sigma_Mx A"
            using qbs_Mx_sigma_Mx_contra[OF 2(3)[symmetric] 2(4)]
            by auto
          hence "U \<notin> sets X"
            using lr_sets 2(1) by auto
          thus ?thesis
            by(simp add: h emeasure_notin_sets)
        next
          case 3
          then show ?thesis
            by simp
        qed
      qed
    next
      case h2:2
      show ?thesis
        by(rule less_eq_measure.intros(2)) (simp add: 2,simp add: h2)
    qed
  qed
qed

end


(* Title: RTS/Common/Semantics.thy *)
(* Author: Susannah Mansky, UIUC 2020 *)

section "Semantics model"

theory Semantics
imports Main
begin

text "General model for small-step semantics:"
locale Semantics =
 fixes
  small :: "'prog \<Rightarrow> 'state \<Rightarrow> 'state set" and
  endset :: "'state set"
 assumes
  endset_final: "\<sigma> \<in> endset \<Longrightarrow> \<forall>P. small P \<sigma> = {}"

context Semantics begin

subsection "Extending @{term small} to multiple steps"

primrec small_nstep :: "'prog \<Rightarrow> 'state \<Rightarrow> nat \<Rightarrow> 'state set" where
small_nstep_base:
 "small_nstep P \<sigma> 0 = {\<sigma>}" |
small_nstep_Rec:
 "small_nstep P \<sigma> (Suc n) =
  { \<sigma>2. \<exists>\<sigma>1. \<sigma>1 \<in> small_nstep P \<sigma> n \<and> \<sigma>2 \<in> small P \<sigma>1 }"

lemma small_nstep_Rec2:
 "small_nstep P \<sigma> (Suc n) =
  { \<sigma>2. \<exists>\<sigma>1. \<sigma>1 \<in> small P \<sigma> \<and> \<sigma>2 \<in> small_nstep P \<sigma>1 n }"
proof(induct n arbitrary: \<sigma>)
  case (Suc n)
  have right: "\<And>\<sigma>'. \<sigma>' \<in> small_nstep P \<sigma> (Suc(Suc n))
    \<Longrightarrow> \<exists>\<sigma>1. \<sigma>1 \<in> small P \<sigma> \<and> \<sigma>' \<in> small_nstep P \<sigma>1 (Suc n)"
  proof -
    fix \<sigma>'
    assume "\<sigma>' \<in> small_nstep P \<sigma> (Suc(Suc n))"
    then obtain \<sigma>1 where Sucnstep: "\<sigma>1 \<in> small_nstep P \<sigma> (Suc n)" "\<sigma>' \<in> small P \<sigma>1" by fastforce
    obtain \<sigma>12 where nstep: "\<sigma>12 \<in> small P \<sigma> \<and> \<sigma>1 \<in> small_nstep P \<sigma>12 n"
      using Suc Sucnstep(1) by fastforce
    then show "\<exists>\<sigma>1. \<sigma>1 \<in> small P \<sigma> \<and> \<sigma>' \<in> small_nstep P \<sigma>1 (Suc n)"
     using Sucnstep by fastforce
  qed
  have left: "\<And>\<sigma>' . \<exists>\<sigma>1. \<sigma>1 \<in> small P \<sigma> \<and> \<sigma>' \<in> small_nstep P \<sigma>1 (Suc n)
    \<Longrightarrow> \<sigma>' \<in> small_nstep P \<sigma> (Suc(Suc n))"
  proof -
    fix \<sigma>'
    assume "\<exists>\<sigma>1. \<sigma>1 \<in> small P \<sigma> \<and> \<sigma>' \<in> small_nstep P \<sigma>1 (Suc n)"
    then obtain \<sigma>1 where Sucnstep: "\<sigma>1 \<in> small P \<sigma>" "\<sigma>' \<in> small_nstep P \<sigma>1 (Suc n)"
      by fastforce
    obtain \<sigma>12 where nstep: "\<sigma>12 \<in> small_nstep P \<sigma>1 n \<and> \<sigma>' \<in> small P \<sigma>12"
      using Sucnstep(2) by auto
    then show "\<sigma>' \<in> small_nstep P \<sigma> (Suc(Suc n))" using Suc Sucnstep by fastforce
  qed
  show ?case using right left by fast
qed(simp)

lemma small_nstep_SucD:
assumes "\<sigma>' \<in> small_nstep P \<sigma> (Suc n)"
shows "\<exists>\<sigma>1. \<sigma>1 \<in> small P \<sigma> \<and> \<sigma>' \<in> small_nstep P \<sigma>1 n"
  using small_nstep_Rec2 case_prodD assms by fastforce

lemma small_nstep_Suc_nend: "\<sigma>' \<in> small_nstep P \<sigma> (Suc n1) \<Longrightarrow> \<sigma> \<notin> endset"
  using endset_final small_nstep_SucD by fastforce

subsection "Extending @{term small} to a big-step semantics"

definition big :: "'prog \<Rightarrow> 'state \<Rightarrow> 'state set" where
"big P \<sigma> \<equiv> { \<sigma>'. \<exists>n. \<sigma>' \<in> small_nstep P \<sigma> n \<and> \<sigma>' \<in> endset }"

lemma bigI:
 "\<lbrakk> \<sigma>' \<in> small_nstep P \<sigma> n; \<sigma>' \<in> endset \<rbrakk> \<Longrightarrow> \<sigma>' \<in> big P \<sigma>"
by (fastforce simp add: big_def)

lemma bigD:
 "\<lbrakk> \<sigma>' \<in> big P \<sigma> \<rbrakk> \<Longrightarrow> \<exists>n. \<sigma>' \<in> small_nstep P \<sigma> n \<and> \<sigma>' \<in> endset"
by (simp add: big_def)

lemma big_def2:
 "\<sigma>' \<in> big P \<sigma> \<longleftrightarrow> (\<exists>n. \<sigma>' \<in> small_nstep P \<sigma> n \<and> \<sigma>' \<in> endset)"
proof(rule iffI)
  assume "\<sigma>' \<in> big P \<sigma>"
  then show "\<exists>n. \<sigma>' \<in> small_nstep P \<sigma> n \<and> \<sigma>' \<in> endset" using bigD big_def by auto
next
  assume "\<exists>n. \<sigma>' \<in> small_nstep P \<sigma> n \<and> \<sigma>' \<in> endset"
  then show "\<sigma>' \<in> big P \<sigma>" using big_def big_def by auto
qed

lemma big_stepD:
assumes big: "\<sigma>' \<in> big P \<sigma>" and nend: "\<sigma> \<notin> endset"
shows "\<exists>\<sigma>1. \<sigma>1 \<in> small P \<sigma> \<and> \<sigma>' \<in> big P \<sigma>1"
proof -
  obtain n where n: "\<sigma>' \<in> small_nstep P \<sigma> n" "\<sigma>' \<in> endset"
    using big_def2 big by auto
  then show ?thesis using small_nstep_SucD nend big_def2 by(cases n, simp) blast
qed

(***)

lemma small_nstep_det_last_eq:
assumes det: "\<forall>\<sigma>. small P \<sigma> = {} \<or> (\<exists>\<sigma>'. small P \<sigma> = {\<sigma>'})"
shows "\<lbrakk> \<sigma>' \<in> big P \<sigma>; \<sigma>' \<in> small_nstep P \<sigma> n; \<sigma>' \<in> small_nstep P \<sigma> n' \<rbrakk> \<Longrightarrow> n = n'"
proof(induct n arbitrary: n' \<sigma> \<sigma>')
  case 0
  have "\<sigma>' = \<sigma>" using "0.prems"(2) small_nstep_base by blast
  then have endset: "\<sigma> \<in> endset" using "0.prems"(1) bigD by blast
  show ?case
  proof(cases n')
    case Suc then show ?thesis using "0.prems"(3) small_nstep_SucD endset_final[OF endset] by blast
  qed(simp)
next
  case (Suc n1)
  then have endset: "\<sigma>' \<in> endset" using Suc.prems(1) bigD by blast
  have nend: "\<sigma> \<notin> endset" using small_nstep_Suc_nend[OF Suc.prems(2)] by simp
  then have neq: "\<sigma>' \<noteq> \<sigma>" using endset by auto
  obtain \<sigma>1 where \<sigma>1: "\<sigma>1 \<in> small P \<sigma>" "\<sigma>' \<in> small_nstep P \<sigma>1 n1"
    using small_nstep_SucD[OF Suc.prems(2)] by clarsimp
  then have big: "\<sigma>' \<in> big P \<sigma>1" using endset by(auto simp: big_def)
  show ?case
  proof(cases n')
    case 0 then show ?thesis using neq Suc.prems(3) using small_nstep_base by blast
  next
    case Suc': (Suc n1')
    then obtain \<sigma>1' where \<sigma>1': "\<sigma>1' \<in> small P \<sigma>" "\<sigma>' \<in> small_nstep P \<sigma>1' n1'"
      using small_nstep_SucD[where \<sigma>=\<sigma> and \<sigma>'=\<sigma>' and n=n1'] Suc.prems(3) by blast
    then have "\<sigma>1=\<sigma>1'" using \<sigma>1(1) det by auto
    then show ?thesis using Suc.hyps(1)[OF big \<sigma>1(2)] \<sigma>1'(2) Suc' by blast
  qed
qed

end \<comment> \<open> Semantics \<close>

end


subsection "Verification Condition Generator"
theory Quant_VCG
imports Quant_Hoare
begin

datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile qassn bexp acom  ("({_}/ WHILE _/ DO _)"  [0, 0, 61] 61)

notation com.SKIP ("SKIP")

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_} WHILE b DO C) = (WHILE b DO strip C)"

fun pre :: "acom \<Rightarrow> qassn \<Rightarrow> qassn" where
"pre SKIP Q = (\<lambda>s. eSuc (Q s))" |
"pre (x ::= a) Q = (\<lambda>s. eSuc (Q (s[a/x])))" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>s. eSuc (if bval b s then pre C\<^sub>1 Q s  else pre C\<^sub>2 Q s  ))" |
"pre ({I} WHILE b DO C) Q = (\<lambda>s. I s + 1)"

fun vc :: "acom \<Rightarrow> qassn \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1 ;; C\<^sub>2) Q = ((vc C\<^sub>1 (pre C\<^sub>2 Q)) \<and> (vc C\<^sub>2 Q) )" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
"vc ({I} WHILE b DO C) Q =  ((\<forall>s. (pre C (\<lambda>s. I s + 1) s \<le> I s + \<up>(bval b s)) \<and> (Q s \<le> I s + \<up> (\<not> bval b s))) \<and> vc C (%s. I s + 1))"

subsubsection "Soundness of VCG"

lemma vc_sound: "vc C Q \<Longrightarrow>  \<turnstile>\<^sub>2 {pre C Q} strip C { Q }"
proof (induct C arbitrary: Q)
  case (Aif b C1 C2)
  then have Aif1: "\<turnstile>\<^sub>2 {pre C1 Q} strip C1 {Q}" and Aif2: "\<turnstile>\<^sub>2 {pre C2 Q} strip C2 {Q}" by auto
    show ?case apply auto apply(rule hoare2.conseq)
      apply(rule hoare2.If[where P="%s. if bval b s then pre C1 Q s else pre C2 Q s" and Q="Q"])
    subgoal
      apply(rule hoare2.conseq)
        apply (fact Aif1)
      subgoal for s apply(cases "bval b s") by auto
      apply simp done
    subgoal
      apply(rule hoare2.conseq)
        apply (fact Aif2)
      subgoal for s apply(cases "bval b s") by auto
      apply simp done
     apply auto
    done
next
  case (Awhile I b C)
  then have i: "(\<And>Q. vc C Q \<Longrightarrow> \<turnstile>\<^sub>2 {pre C Q} strip C {Q})"
   and ii: " \<forall>s. pre C (\<lambda>s. I s + 1) s \<le> I s + \<up> (bval b s) \<and> Q s \<le>  I s + \<up> (\<not> bval b s)"
     and iii: "vc C (\<lambda>s. I s + 1)" by auto

  from i iii have  A: "\<turnstile>\<^sub>2 {pre C (\<lambda>s. I s + 1)} strip C {(\<lambda>s. I s + 1)}" by auto

  have   "\<turnstile>\<^sub>2 {\<lambda>s. I s + 1} WHILE b DO strip C {Q}"
    apply(rule hoare2.conseq)
     apply(rule hoare2.While[where I=I])
      apply(rule hoare2.conseq)
        apply(rule A) using ii by auto
  then show ?case by auto
qed (auto intro: hoare2.Skip hoare2.Assign hoare2.Seq )

lemma vc_sound': "\<lbrakk>vc C Q ; (\<forall>s. pre C Q s \<le> P s) \<rbrakk> \<Longrightarrow>  \<turnstile>\<^sub>2 {P} strip C { Q }"
  apply(rule hoare2.conseq)
    apply(rule vc_sound) by auto

subsubsection "Completeness"

lemma pre_mono: assumes "\<And>s. P' s \<le> P s"
  shows "\<And>s. pre C P' s \<le> pre C P s"
  using assms by (induct C arbitrary: P P', auto)

lemma vc_mono: assumes "\<And>s. P' s \<le> P s"
  shows "vc C P \<Longrightarrow> vc C P'"
  using assms proof (induct C arbitrary: P P')
  case (Awhile I b C)
  thus ?case
    apply (auto simp: pre_mono)
    using order.trans by blast
qed (auto simp: pre_mono)

lemma "\<turnstile>\<^sub>2 { P } c { Q } \<Longrightarrow> \<exists>C. strip C = c \<and> vc C Q \<and> (\<forall>s. pre C Q s \<le> P s)"
  (is "_ \<Longrightarrow>   \<exists>C. ?G P c Q C")
proof (induction rule: hoare2.induct)
  case (Skip P)
  show ?case (is "\<exists>C. ?C C")
  proof show "?C Askip" by auto
  qed
next
  case (Assign P a x)
  show ?case (is "\<exists>C. ?C C")
  proof show "?C(Aassign x a)" by simp qed
next
  case (If P b c\<^sub>1 Q c\<^sub>2)
  from If(3) obtain C1 where strip1: "strip C1 = c\<^sub>1" and vc1: "vc C1 Q"
    and pre1: "(\<And>s. pre C1 Q s \<le> P s + \<up> (bval b s))"  by blast
  from If(4) obtain C2 where strip2: "strip C2 = c\<^sub>2" and vc2: "vc C2 Q"
    and pre2: "(\<And>s. pre C2 Q s \<le> P s + \<up> (\<not> bval b s))"  by blast

  show ?case
    apply(rule exI[where x="IF b THEN C1 ELSE C2"], safe)
    subgoal using strip1 strip2 by auto
    subgoal using vc1 vc2 by auto
    subgoal for s using pre1[of s] pre2[of s] by auto
    done
next
  case (Seq P\<^sub>1 c\<^sub>1 P\<^sub>2 c\<^sub>2 P\<^sub>3)
  from Seq(3) obtain C1 where strip1: "strip C1 = c\<^sub>1" and vc1: "vc C1 P\<^sub>2"
    and pre1: "(\<forall>s. pre C1 P\<^sub>2 s \<le> P\<^sub>1 s)"  by blast
  from Seq(4) obtain C2 where strip2: "strip C2 = c\<^sub>2" and vc2: "vc C2 P\<^sub>3"
    and pre2: "(\<forall>s. pre C2 P\<^sub>3 s \<le> P\<^sub>2 s)"  by blast
  {
    fix s
    have "pre C1 (pre C2 P\<^sub>3) s \<le> P\<^sub>1 s"
      apply(rule order.trans[where b="pre C1 P\<^sub>2 s"])
       apply(rule pre_mono) using pre2 apply simp using pre1 by simp
  } note pre = this
  show ?case
    apply(rule exI[where x="C1 ;; C2"], safe)
    subgoal using strip1 strip2 by simp
    subgoal using vc1 vc2 vc_mono pre2 by auto
    subgoal using pre by auto
    done
next
  case (While I b c)
  from While(2) obtain C where strip: "strip C = c" and vc: "vc C (\<lambda>a. I a + 1)"
    and pre: "\<And>s. pre C (\<lambda>a. I a + 1) s \<le> I s + \<up> (bval b s)" by blast
  show ?case
    apply(rule exI[where x="{I} WHILE b DO C"], safe)
    subgoal using strip by simp
    subgoal using pre vc by auto
    subgoal by simp
  done
next
  case (conseq P c Q P' Q')
  then obtain C where "strip C = c" and vc: "vc C Q" and pre: "\<And>s. pre C Q s \<le> P s" by blast

  from pre_mono[OF conseq(3)] have 1: "\<And>s. pre C Q' s \<le> pre C Q s" by auto

  show ?case
    apply(rule exI[where x=C])
    apply safe
      apply fact
    subgoal using vc conseq(3) vc_mono by auto
    subgoal using pre conseq(2) 1 using order.trans  by metis
    done
qed

end


(*  Title:      HOL/Hahn_Banach/Bounds.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Bounds\<close>

theory Bounds
imports Main "~~/src/HOL/Library/ContNotDenum"
begin

locale lub =
  fixes A and x
  assumes least [intro?]: "(\<And>a. a \<in> A \<Longrightarrow> a \<le> b) \<Longrightarrow> x \<le> b"
    and upper [intro?]: "a \<in> A \<Longrightarrow> a \<le> x"

lemmas [elim?] = lub.least lub.upper

definition the_lub :: "'a::order set \<Rightarrow> 'a"  ("\<Squnion>_" [90] 90)
  where "the_lub A = The (lub A)"

lemma the_lub_equality [elim?]:
  assumes "lub A x"
  shows "\<Squnion>A = (x::'a::order)"
proof -
  interpret lub A x by fact
  show ?thesis
  proof (unfold the_lub_def)
    from \<open>lub A x\<close> show "The (lub A) = x"
    proof
      fix x' assume lub': "lub A x'"
      show "x' = x"
      proof (rule order_antisym)
        from lub' show "x' \<le> x"
        proof
          fix a assume "a \<in> A"
          then show "a \<le> x" ..
        qed
        show "x \<le> x'"
        proof
          fix a assume "a \<in> A"
          with lub' show "a \<le> x'" ..
        qed
      qed
    qed
  qed
qed

lemma the_lubI_ex:
  assumes ex: "\<exists>x. lub A x"
  shows "lub A (\<Squnion>A)"
proof -
  from ex obtain x where x: "lub A x" ..
  also from x have [symmetric]: "\<Squnion>A = x" ..
  finally show ?thesis .
qed

lemma real_complete: "\<exists>a::real. a \<in> A \<Longrightarrow> \<exists>y. \<forall>a \<in> A. a \<le> y \<Longrightarrow> \<exists>x. lub A x"
  by (intro exI[of _ "Sup A"]) (auto intro!: cSup_upper cSup_least simp: lub_def)

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Author: Jeremy Dawson, NICTA *)

section \<open>Operation variant for setting and unsetting bits\<close>

theory Generic_set_bit
  imports
    "HOL-Library.Word"
    Bits_Int
    Most_significant_bit
begin

class set_bit = semiring_bits +
  fixes set_bit :: \<open>'a \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> 'a\<close>
  assumes bit_set_bit_iff [bit_simps]:
    \<open>bit (set_bit a m b) n \<longleftrightarrow>
      (if m = n then b else bit a n) \<and> 2 ^ n \<noteq> 0\<close>

lemma set_bit_eq:
  \<open>set_bit a n b = (if b then Bit_Operations.set_bit else unset_bit) n a\<close>
  for a :: \<open>'a::{ring_bit_operations, set_bit}\<close>
  by (rule bit_eqI) (simp add: bit_simps)

instantiation int :: set_bit
begin

definition set_bit_int :: \<open>int \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> int\<close>
  where \<open>set_bit i n b = bin_sc n b i\<close>

instance
  by standard
    (simp_all add: set_bit_int_def bin_nth_sc_gen bit_simps)

end

lemma int_set_bit_0 [simp]: fixes x :: int shows
  "set_bit x 0 b = of_bool b + 2 * (x div 2)"
  by (auto simp add: set_bit_int_def intro: bin_rl_eqI)

lemma int_set_bit_Suc: fixes x :: int shows
  "set_bit x (Suc n) b = of_bool (odd x) + 2 * set_bit (x div 2) n b"
  by (auto simp add: set_bit_int_def intro: bin_rl_eqI)

lemma bin_last_set_bit:
  "bin_last (set_bit x n b) = (if n > 0 then bin_last x else b)"
  by (cases n) (simp_all add: int_set_bit_Suc)

lemma bin_rest_set_bit:
  "bin_rest (set_bit x n b) = (if n > 0 then set_bit (x div 2) (n - 1) b else x div 2)"
  by (cases n) (simp_all add: int_set_bit_Suc)

lemma int_set_bit_numeral: fixes x :: int shows
  "set_bit x (numeral w) b = of_bool (odd x) + 2 * set_bit (x div 2) (pred_numeral w) b"
  by (simp add: set_bit_int_def)

lemmas int_set_bit_numerals [simp] =
  int_set_bit_numeral[where x="numeral w'"]
  int_set_bit_numeral[where x="- numeral w'"]
  int_set_bit_numeral[where x="Numeral1"]
  int_set_bit_numeral[where x="1"]
  int_set_bit_numeral[where x="0"]
  int_set_bit_Suc[where x="numeral w'"]
  int_set_bit_Suc[where x="- numeral w'"]
  int_set_bit_Suc[where x="Numeral1"]
  int_set_bit_Suc[where x="1"]
  int_set_bit_Suc[where x="0"]
  for w'

lemma msb_set_bit [simp]: "msb (set_bit (x :: int) n b) \<longleftrightarrow> msb x"
by(simp add: msb_conv_bin_sign set_bit_int_def)

instantiation word :: (len) set_bit
begin

definition set_bit_word :: \<open>'a word \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> 'a word\<close>
  where word_set_bit_def: \<open>set_bit a n x = word_of_int (bin_sc n x (uint a))\<close>

instance
  by standard
    (auto simp add: word_set_bit_def bin_nth_sc_gen bit_simps)

end

lemma set_bit_unfold:
  \<open>set_bit w n b = (if b then Bit_Operations.set_bit n w else unset_bit n w)\<close>
  for w :: \<open>'a::len word\<close>
  by (simp add: set_bit_eq)

lemma bit_set_bit_word_iff [bit_simps]:
  \<open>bit (set_bit w m b) n \<longleftrightarrow> (if m = n then n < LENGTH('a) \<and> b else bit w n)\<close>
  for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps dest: bit_imp_le_length)

lemma word_set_nth [simp]: "set_bit w n (test_bit w n) = w"
  for w :: "'a::len word"
  by (auto simp: word_test_bit_def word_set_bit_def)

lemma test_bit_set: "(set_bit w n x) !! n \<longleftrightarrow> n < size w \<and> x"
  for w :: "'a::len word"
  by (auto simp: word_size word_test_bit_def word_set_bit_def nth_bintr)

lemma test_bit_set_gen:
  "test_bit (set_bit w n x) m = (if m = n then n < size w \<and> x else test_bit w m)"
  for w :: "'a::len word"
  apply (unfold word_size word_test_bit_def word_set_bit_def)
  apply (clarsimp simp add: nth_bintr bin_nth_sc_gen)
  apply (auto elim!: test_bit_size [unfolded word_size]
      simp add: word_test_bit_def [symmetric])
  done

lemma word_set_set_same [simp]: "set_bit (set_bit w n x) n y = set_bit w n y"
  for w :: "'a::len word"
  by (rule word_eqI) (simp add : test_bit_set_gen word_size)

lemma word_set_set_diff:
  fixes w :: "'a::len word"
  assumes "m \<noteq> n"
  shows "set_bit (set_bit w m x) n y = set_bit (set_bit w n y) m x"
  by (rule word_eqI) (auto simp: test_bit_set_gen word_size assms)

lemma set_bit_word_of_int: "set_bit (word_of_int x) n b = word_of_int (bin_sc n b x)"
  unfolding word_set_bit_def
  by (rule word_eqI)(simp add: word_size bin_nth_sc_gen nth_bintr)

lemma word_set_numeral [simp]:
  "set_bit (numeral bin::'a::len word) n b =
    word_of_int (bin_sc n b (numeral bin))"
  unfolding word_numeral_alt by (rule set_bit_word_of_int)

lemma word_set_neg_numeral [simp]:
  "set_bit (- numeral bin::'a::len word) n b =
    word_of_int (bin_sc n b (- numeral bin))"
  unfolding word_neg_numeral_alt by (rule set_bit_word_of_int)

lemma word_set_bit_0 [simp]: "set_bit 0 n b = word_of_int (bin_sc n b 0)"
  unfolding word_0_wi by (rule set_bit_word_of_int)

lemma word_set_bit_1 [simp]: "set_bit 1 n b = word_of_int (bin_sc n b 1)"
  unfolding word_1_wi by (rule set_bit_word_of_int)

lemma word_set_nth_iff: "set_bit w n b = w \<longleftrightarrow> w !! n = b \<or> n \<ge> size w"
  for w :: "'a::len word"
  apply (rule iffI)
   apply (rule disjCI)
   apply (drule word_eqD)
   apply (erule sym [THEN trans])
   apply (simp add: test_bit_set)
  apply (erule disjE)
   apply clarsimp
  apply (rule word_eqI)
  apply (clarsimp simp add : test_bit_set_gen)
  apply (drule test_bit_size)
  apply force
  done

lemma word_clr_le: "w \<ge> set_bit w n False"
  for w :: "'a::len word"
  apply (simp add: word_set_bit_def word_le_def)
  apply transfer
  apply (rule order_trans)
   apply (rule bintr_bin_clr_le)
  apply simp
  done

lemma word_set_ge: "w \<le> set_bit w n True"
  for w :: "'a::len word"
  apply (simp add: word_set_bit_def word_le_def)
  apply transfer
  apply (rule order_trans [OF _ bintr_bin_set_ge])
  apply simp
  done

lemma set_bit_beyond:
  "size x \<le> n \<Longrightarrow> set_bit x n b = x" for x :: "'a :: len word"
  by (auto intro: word_eqI simp add: test_bit_set_gen word_size)

lemma one_bit_shiftl: "set_bit 0 n True = (1 :: 'a :: len word) << n"
  apply (rule word_eqI)
  apply (auto simp add: test_bit_set_gen nth_shiftl word_size
              simp del: word_set_bit_0 shiftl_1)
  done

lemmas one_bit_pow = trans [OF one_bit_shiftl shiftl_1]

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory UnboxedNats
imports
  HOLCF
  Nats
  WorkerWrapperNew
begin
(*>*)

section\<open>Unboxing types.\<close>

text\<open>The original application of the worker/wrapper transformation
was the unboxing of flat types by \<^citet>\<open>"SPJ-JL:1991"\<close>. We can model
the boxed and unboxed types as (respectively) pointed and unpointed
domains in HOLCF. Concretely @{typ "UNat"} denotes the discrete domain
of naturals, @{typ "UNat\<^sub>\<bottom>"} the lifted (flat and pointed) variant, and
@{typ "Nat"} the standard boxed domain, isomorphic to @{typ
"UNat\<^sub>\<bottom>"}. This latter distinction helps us keep the boxed naturals and
lifted function codomains separated; applications of @{term "unbox"}
should be thought of in the same way as Haskell's @{term "newtype"}
constructors, i.e. operationally equivalent to @{term "ID"}.

The divergence monad is used to handle the unboxing, see below.\<close>

subsection\<open>Factorial example.\<close>

text\<open>Standard definition of factorial.\<close>

fixrec fac :: "Nat \<rightarrow> Nat"
where
  "fac\<cdot>n = If n =\<^sub>B 0 then 1 else n * fac\<cdot>(n - 1)"

declare fac.simps[simp del]

lemma fac_strict[simp]: "fac\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

definition
  fac_body :: "(Nat \<rightarrow> Nat) \<rightarrow> Nat \<rightarrow> Nat" where
  "fac_body \<equiv> \<Lambda> r n. If n =\<^sub>B 0 then 1 else n * r\<cdot>(n - 1)"

lemma fac_body_strict[simp]: "fac_body\<cdot>r\<cdot>\<bottom> = \<bottom>"
  unfolding fac_body_def by simp

lemma fac_fac_body_eq: "fac = fix\<cdot>fac_body"
  unfolding fac_body_def by (rule cfun_eqI, subst fac_def, simp)

text\<open>Wrap / unwrap functions. Note the explicit lifting of the
co-domain. For some reason the published version of
\<^citet>\<open>"GillHutton:2009"\<close> does not discuss this point: if we're going to
handle recursive functions, we need a bottom.

@{term "unbox"} simply removes the tag, yielding a possibly-divergent
unboxed value, the result of the function.\<close>

definition
  unwrapB :: "(Nat \<rightarrow> Nat) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "unwrapB \<equiv> \<Lambda> f. unbox oo f oo box"

text\<open>Note that the monadic bind operator @{term "(>>=)"} here stands
in for the \textsf{case} construct in the paper.\<close>

definition
  wrapB :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> Nat \<rightarrow> Nat" where
  "wrapB \<equiv> \<Lambda> f x . unbox\<cdot>x >>= f >>= box"

lemma wrapB_unwrapB_body:
  assumes strictF: "f\<cdot>\<bottom> = \<bottom>"
  shows "(wrapB oo unwrapB)\<cdot>f = f" (is "?lhs = ?rhs")
proof(rule cfun_eqI)
  fix x :: Nat
  have "?lhs\<cdot>x = unbox\<cdot>x >>= (\<Lambda> x'. unwrapB\<cdot>f\<cdot>x' >>= box)"
    unfolding wrapB_def by simp
  also have "\<dots> = unbox\<cdot>x >>= (\<Lambda> x'. unbox\<cdot>(f\<cdot>(box\<cdot>x')) >>= box)"
    unfolding unwrapB_def by simp
  also from strictF have "\<dots> = f\<cdot>x" by (cases x, simp_all)
  finally show "?lhs\<cdot>x = ?rhs\<cdot>x" .
qed

text\<open>Apply worker/wrapper.\<close>

definition
  fac_work :: "UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_work \<equiv> fix\<cdot>(unwrapB oo fac_body oo wrapB)"

definition
  fac_wrap :: "Nat \<rightarrow> Nat" where
  "fac_wrap \<equiv> wrapB\<cdot>fac_work"

lemma fac_fac_ww_eq: "fac = fac_wrap" (is "?lhs = ?rhs")
proof -
  have "wrapB oo unwrapB oo fac_body = fac_body"
    using wrapB_unwrapB_body[OF fac_body_strict]
    by - (rule cfun_eqI, simp)
  thus ?thesis
    using worker_wrapper_body[where computation=fac and body=fac_body and wrap=wrapB and unwrap=unwrapB]
    unfolding fac_work_def fac_wrap_def by (simp add: fac_fac_body_eq)
qed

text\<open>This is not entirely faithful to the paper, as they don't
explicitly handle the lifting of the codomain.\<close>

definition
  fac_body' :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_body' \<equiv> \<Lambda> r n.
     unbox\<cdot>(If box\<cdot>n =\<^sub>B 0
              then 1
              else unbox\<cdot>(box\<cdot>n - 1) >>= r >>= (\<Lambda> b. box\<cdot>n * box\<cdot>b))"

text\<open>The @{term "up"} constructors here again mediate the
isomorphism, operationally doing nothing. Note the switch to the
machine-oriented \emph{if} construct: the test @{term "n = 0"} cannot
diverge.\<close>

definition
  fac_body_final :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_body_final \<equiv> \<Lambda> r n.
     if n = 0 then up\<cdot>1 else r\<cdot>(n -\<^sub># 1) >>= (\<Lambda> b. up\<cdot>(n *\<^sub># b))"

lemma fac_body_final_fac_body': "fac_body_final = fac_body'" (is "?lhs = ?rhs")
proof(rule cfun_eqI)+
  fix r x
  show "?lhs\<cdot>r\<cdot>x = ?rhs\<cdot>r\<cdot>x"
    using bbind_case_distr_strict[where f="unbox" and g="r\<cdot>(x -\<^sub># 1)" and h="(\<Lambda> b. box\<cdot>(x *\<^sub># b))"]
    unfolding fac_body_final_def fac_body'_def uMinus_def uMult_def zero_Nat_def one_Nat_def
    by simp
qed

definition
  fac_work_final :: "UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_work_final \<equiv> fix\<cdot>fac_body_final"

definition
  fac_final :: "Nat \<rightarrow> Nat" where
  "fac_final \<equiv> \<Lambda> n. unbox\<cdot>n >>= fac_work_final >>= box"

lemma fac_fac_final: "fac = fac_final" (is "?lhs=?rhs")
proof -
  have "?lhs = fac_wrap" by (rule fac_fac_ww_eq)
  also have "\<dots> = wrapB\<cdot>fac_work" by (simp only: fac_wrap_def)
  also have "\<dots> = wrapB\<cdot>(fix\<cdot>(unwrapB oo fac_body oo wrapB))" by (simp only: fac_work_def)
  also have "\<dots> = wrapB\<cdot>(fix\<cdot>fac_body')" by (simp only: fac_body'_fac_body)
  also have "\<dots> = wrapB\<cdot>fac_work_final" by (simp only: fac_body_final_fac_body' fac_work_final_def)
  also have "\<dots> = fac_final" by (simp add: fac_final_def wrapB_def)
  finally show ?thesis .
qed

(* **************************************** *)

subsection\<open>Introducing an accumulator.\<close>

text\<open>

The final version of factorial uses unboxed naturals but is not
tail-recursive. We can apply worker/wrapper once more to introduce an
accumulator, similar to \S\ref{sec:accum}.

The monadic machinery complicates things slightly here. We use
\emph{Kleisli composition}, denoted @{term "(>=>)"}, in the
homomorphism.

Firstly we introduce an ``accumulator'' monoid and show the
homomorphism.

\<close>

type_synonym UNatAcc = "UNat \<rightarrow> UNat\<^sub>\<bottom>"

definition
  n2a :: "UNat \<rightarrow> UNatAcc" where
  "n2a \<equiv> \<Lambda> m n. up\<cdot>(m *\<^sub># n)"

definition
  a2n :: "UNatAcc \<rightarrow> UNat\<^sub>\<bottom>" where
  "a2n \<equiv> \<Lambda> a. a\<cdot>1"

lemma a2n_strict[simp]: "a2n\<cdot>\<bottom> = \<bottom>"
  unfolding a2n_def by simp

lemma a2n_n2a: "a2n\<cdot>(n2a\<cdot>u) = up\<cdot>u"
  unfolding a2n_def n2a_def by (simp add: uMult_arithmetic)

lemma A_hom_mult: "n2a\<cdot>(x *\<^sub># y) = (n2a\<cdot>x >=> n2a\<cdot>y)"
  unfolding n2a_def bKleisli_def by (simp add: uMult_arithmetic)

definition
  unwrapA :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "unwrapA \<equiv> \<Lambda> f n. f\<cdot>n >>= n2a"

lemma unwrapA_strict[simp]: "unwrapA\<cdot>\<bottom> = \<bottom>"
  unfolding unwrapA_def by (rule cfun_eqI) simp

definition
  wrapA :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "wrapA \<equiv> \<Lambda> f. a2n oo f"

lemma wrapA_unwrapA_id: "wrapA oo unwrapA = ID"
  unfolding wrapA_def unwrapA_def
  apply (rule cfun_eqI)+
  apply (case_tac "x\<cdot>xa")
  apply (simp_all add: a2n_n2a)
  done

text\<open>Some steps along the way.\<close>

definition
  fac_acc_body1 :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body1 \<equiv> \<Lambda> r n.
     if n = 0 then n2a\<cdot>1 else wrapA\<cdot>r\<cdot>(n -\<^sub># 1) >>= (\<Lambda> res. n2a\<cdot>(n *\<^sub># res))"

lemma fac_acc_body1_fac_body_final_eq: "fac_acc_body1 = unwrapA oo fac_body_final oo wrapA"
  unfolding fac_acc_body1_def fac_body_final_def wrapA_def unwrapA_def
  by (rule cfun_eqI)+ simp

text\<open>Use the homomorphism.\<close>

definition
  fac_acc_body2 :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body2 \<equiv> \<Lambda> r n.
     if n = 0 then n2a\<cdot>1 else wrapA\<cdot>r\<cdot>(n -\<^sub># 1) >>= (\<Lambda> res. n2a\<cdot>n >=> n2a\<cdot>res)"

lemma fac_acc_body2_body1_eq: "fac_acc_body2 = fac_acc_body1"
  unfolding fac_acc_body1_def fac_acc_body2_def
  by (rule cfun_eqI)+ (simp add: A_hom_mult)

text\<open>Apply worker/wrapper.\<close>

definition
  fac_acc_body3 :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body3 \<equiv> \<Lambda> r n.
     if n = 0 then n2a\<cdot>1 else n2a\<cdot>n >=> r\<cdot>(n -\<^sub># 1)"

lemma fac_acc_body3_body2: "fac_acc_body3 oo (unwrapA oo wrapA) = fac_acc_body2" (is "?lhs=?rhs")
proof(rule cfun_eqI)+
  fix r n acc
  show "((fac_acc_body3 oo (unwrapA oo wrapA))\<cdot>r\<cdot>n\<cdot>acc) = fac_acc_body2\<cdot>r\<cdot>n\<cdot>acc"
    unfolding fac_acc_body2_def fac_acc_body3_def unwrapA_def
    using bbind_case_distr_strict[where f="\<Lambda> y. n2a\<cdot>n >=> y" and h="n2a", symmetric]
    by simp
qed

lemma fac_work_final_body3_eq: "fac_work_final = wrapA\<cdot>(fix\<cdot>fac_acc_body3)"
  unfolding fac_work_final_def
  by (rule worker_wrapper_fusion_new[OF wrapA_unwrapA_id unwrapA_strict])
     (simp add: fac_acc_body3_body2 fac_acc_body2_body1_eq fac_acc_body1_fac_body_final_eq)

definition
  fac_acc_body_final :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body_final \<equiv> \<Lambda> r n acc.
     if n = 0 then up\<cdot>acc else r\<cdot>(n -\<^sub># 1)\<cdot>(n *\<^sub># acc)"

definition
  fac_acc_work_final :: "UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_acc_work_final \<equiv> \<Lambda> x. fix\<cdot>fac_acc_body_final\<cdot>x\<cdot>1"

lemma fac_acc_work_final_fac_acc_work3_eq: "fac_acc_body_final = fac_acc_body3" (is "?lhs=?rhs")
  unfolding fac_acc_body3_def fac_acc_body_final_def n2a_def bKleisli_def
  by (rule cfun_eqI)+
     (simp add: uMult_arithmetic)

lemma fac_acc_work_final_fac_work: "fac_acc_work_final = fac_work_final" (is "?lhs=?rhs")
proof -
  have "?rhs = wrapA\<cdot>(fix\<cdot>fac_acc_body3)" by (rule fac_work_final_body3_eq)
  also have "\<dots> = wrapA\<cdot>(fix\<cdot>fac_acc_body_final)"
    using fac_acc_work_final_fac_acc_work3_eq by simp
  also have "\<dots> = ?lhs"
    unfolding fac_acc_work_final_def wrapA_def a2n_def
    by (simp add: cfcomp1)
  finally show ?thesis by simp
qed

(*<*)
end
(*>*)


theory TAO_99_Paradox
imports TAO_9_PLM TAO_98_ArtificialTheorems
begin

section\<open>Paradox\<close>

(*<*)
locale Paradox = PLM
begin
(*>*)

text\<open>
\label{TAO_Paradox_paradox}
Under the additional assumption that expressions of the form
@{term "(\<lambda>x . \<lparr>G,\<^bold>\<iota>y . \<phi> y x\<rparr>)"} for arbitrary \<open>\<phi>\<close> are
\emph{proper maps}, for which \<open>\<beta>\<close>-conversion holds,
the theory becomes inconsistent.
\<close>

subsection\<open>Auxiliary Lemmas\<close>

  lemma exe_impl_exists:
    "[\<lparr>(\<^bold>\<lambda>x . \<^bold>\<forall> p . p \<^bold>\<rightarrow> p), \<^bold>\<iota>y . \<phi> y x\<rparr> \<^bold>\<equiv> (\<^bold>\<exists>!y . \<^bold>\<A>\<phi> y x) in v]"
    proof (rule "\<^bold>\<equiv>I"; rule CP)
      fix \<phi> :: "\<nu>\<Rightarrow>\<nu>\<Rightarrow>\<o>" and x :: \<nu> and v :: i
      assume "[\<lparr>(\<^bold>\<lambda>x . \<^bold>\<forall> p . p \<^bold>\<rightarrow> p),\<^bold>\<iota>y . \<phi> y x\<rparr> in v]"
      hence "[\<^bold>\<exists>y. \<^bold>\<A>\<phi> y x \<^bold>& (\<^bold>\<forall>z. \<^bold>\<A>\<phi> z x \<^bold>\<rightarrow> z \<^bold>= y)
              \<^bold>& \<lparr>(\<^bold>\<lambda>x . \<^bold>\<forall> p . p \<^bold>\<rightarrow> p), y\<^sup>P\<rparr> in v]"
        using nec_russell_axiom[equiv_lr] SimpleExOrEnc.intros by auto
      then obtain y where
        "[\<^bold>\<A>\<phi> y x \<^bold>& (\<^bold>\<forall>z. \<^bold>\<A>\<phi> z x \<^bold>\<rightarrow> z \<^bold>= y)
          \<^bold>& \<lparr>(\<^bold>\<lambda>x . \<^bold>\<forall> p . p \<^bold>\<rightarrow> p), y\<^sup>P\<rparr> in v]"
        by (rule Instantiate)
      hence "[\<^bold>\<A>\<phi> y x \<^bold>& (\<^bold>\<forall>z. \<^bold>\<A>\<phi> z x \<^bold>\<rightarrow> z \<^bold>= y) in v]"
        using "\<^bold>&E" by blast
      hence "[\<^bold>\<exists>y . \<^bold>\<A>\<phi> y x \<^bold>& (\<^bold>\<forall>z. \<^bold>\<A>\<phi> z x \<^bold>\<rightarrow> z \<^bold>= y) in v]"
        by (rule existential)
      thus "[\<^bold>\<exists>!y. \<^bold>\<A>\<phi> y x in v]"
        unfolding exists_unique_def by simp
    next
      fix \<phi> :: "\<nu>\<Rightarrow>\<nu>\<Rightarrow>\<o>" and x :: \<nu> and v :: i
      assume "[\<^bold>\<exists>!y. \<^bold>\<A>\<phi> y x in v]"
      hence "[\<^bold>\<exists>y. \<^bold>\<A>\<phi> y x \<^bold>& (\<^bold>\<forall>z. \<^bold>\<A>\<phi> z x \<^bold>\<rightarrow> z \<^bold>= y) in v]"
        unfolding exists_unique_def by simp
      then obtain y where
        "[\<^bold>\<A>\<phi> y x \<^bold>& (\<^bold>\<forall>z. \<^bold>\<A>\<phi> z x \<^bold>\<rightarrow> z \<^bold>= y) in v]"
        by (rule Instantiate)
      moreover have "[\<lparr>(\<^bold>\<lambda>x . \<^bold>\<forall> p . p \<^bold>\<rightarrow> p),y\<^sup>P\<rparr> in v]"
        apply (rule beta_C_meta_1[equiv_rl])
          apply show_proper
        by PLM_solver
      ultimately have "[\<^bold>\<A>\<phi> y x \<^bold>& (\<^bold>\<forall>z. \<^bold>\<A>\<phi> z x \<^bold>\<rightarrow> z \<^bold>= y)
                        \<^bold>& \<lparr>(\<^bold>\<lambda>x . \<^bold>\<forall> p . p \<^bold>\<rightarrow> p),y\<^sup>P\<rparr> in v]"
        using "\<^bold>&I" by blast
      hence "[\<^bold>\<exists> y . \<^bold>\<A>\<phi> y x \<^bold>& (\<^bold>\<forall>z. \<^bold>\<A>\<phi> z x \<^bold>\<rightarrow> z \<^bold>= y)
              \<^bold>& \<lparr>(\<^bold>\<lambda>x . \<^bold>\<forall> p . p \<^bold>\<rightarrow> p),y\<^sup>P\<rparr> in v]"
        by (rule existential)
      thus "[\<lparr>(\<^bold>\<lambda>x . \<^bold>\<forall> p . p \<^bold>\<rightarrow> p), \<^bold>\<iota>y. \<phi> y x\<rparr> in v]"
        using nec_russell_axiom[equiv_rl]
          SimpleExOrEnc.intros by auto
    qed

  lemma exists_unique_actual_equiv:
    "[(\<^bold>\<exists>!y . \<^bold>\<A>(y \<^bold>= x \<^bold>& \<psi> (x\<^sup>P))) \<^bold>\<equiv> \<^bold>\<A>\<psi> (x\<^sup>P) in v]"
  proof (rule "\<^bold>\<equiv>I"; rule CP)
    fix x v
    let ?\<phi> = "\<lambda> y x. y \<^bold>= x \<^bold>& \<psi> (x\<^sup>P)"
    assume "[\<^bold>\<exists>!y. \<^bold>\<A>?\<phi> y x in v]"
    hence "[\<^bold>\<exists>\<alpha>. \<^bold>\<A>?\<phi> \<alpha> x \<^bold>& (\<^bold>\<forall>\<beta>. \<^bold>\<A>?\<phi> \<beta> x \<^bold>\<rightarrow> \<beta> \<^bold>= \<alpha>) in v]"
      unfolding exists_unique_def by simp
    then obtain \<alpha> where
      "[\<^bold>\<A>?\<phi> \<alpha> x \<^bold>& (\<^bold>\<forall>\<beta>. \<^bold>\<A>?\<phi> \<beta> x \<^bold>\<rightarrow> \<beta> \<^bold>= \<alpha>) in v]"
      by (rule Instantiate)
    hence "[\<^bold>\<A>(\<alpha> \<^bold>= x \<^bold>& \<psi> (x\<^sup>P)) in v]"
      using "\<^bold>&E" by blast
    thus "[\<^bold>\<A>(\<psi> (x\<^sup>P)) in v]"
      using Act_Basic_2[equiv_lr] "\<^bold>&E" by blast
  next
    fix x v
    let ?\<phi> = "\<lambda> y x. y \<^bold>= x \<^bold>& \<psi> (x\<^sup>P)"
    assume 1: "[\<^bold>\<A>\<psi> (x\<^sup>P) in v]"
    have "[x \<^bold>= x in v]"
      using id_eq_1[where 'a=\<nu>] by simp
    hence "[\<^bold>\<A>(x \<^bold>= x) in v]"
      using id_act_3[equiv_lr] by fast
    hence "[\<^bold>\<A>(x \<^bold>= x \<^bold>& \<psi> (x\<^sup>P)) in v]"
      using 1 Act_Basic_2[equiv_rl] "\<^bold>&I" by blast
    hence "[\<^bold>\<A>?\<phi> x x in v]"
      by simp
    moreover have "[\<^bold>\<forall>\<beta>. \<^bold>\<A>?\<phi> \<beta> x \<^bold>\<rightarrow> \<beta> \<^bold>= x in v]"
    proof (rule "\<^bold>\<forall>I"; rule CP)
      fix \<beta>
      assume "[\<^bold>\<A>?\<phi> \<beta> x in v]"
      hence "[\<^bold>\<A>(\<beta> \<^bold>= x) in v]"
        using Act_Basic_2[equiv_lr] "\<^bold>&E" by fast
      thus "[\<beta> \<^bold>= x in v]" using id_act_3[equiv_rl] by fast
    qed
    ultimately have "[\<^bold>\<A>?\<phi> x x \<^bold>& (\<^bold>\<forall>\<beta>. \<^bold>\<A>?\<phi> \<beta> x \<^bold>\<rightarrow> \<beta> \<^bold>= x) in v]"
      using "\<^bold>&I" by fast
    hence "[\<^bold>\<exists>\<alpha>. \<^bold>\<A>?\<phi> \<alpha> x \<^bold>& (\<^bold>\<forall>\<beta>. \<^bold>\<A>?\<phi> \<beta> x \<^bold>\<rightarrow> \<beta> \<^bold>= \<alpha>) in v]"
      by (rule existential)
    thus "[\<^bold>\<exists>!y. \<^bold>\<A>?\<phi> y x in v]"
      unfolding exists_unique_def by simp
  qed

subsection\<open>Fake $\beta$-Conversion using Description Backdoor\<close>
text\<open>
  \label{TAO_Paradox_description_backdoor}
\<close>

  definition backdoor where
    "backdoor \<equiv> \<lambda> \<psi> . \<^bold>\<lambda>x . \<lparr>(\<^bold>\<lambda>x . \<^bold>\<forall> p . p \<^bold>\<rightarrow> p), \<^bold>\<iota>y . y \<^bold>= x \<^bold>& \<psi> (x\<^sup>P)\<rparr>"

  lemma fake_beta:
    assumes "\<And> G \<phi>. IsProperInX (\<lambda>x . \<lparr>G,\<^bold>\<iota>y . \<phi> y x\<rparr>)"
    shows "[\<lparr>backdoor (\<lambda> x . \<psi> x), x\<^sup>P\<rparr> \<^bold>\<equiv> \<^bold>\<A>\<psi> (x\<^sup>P) in v]"
  proof (rule "\<^bold>\<equiv>I"; rule CP)
    assume "[\<lparr>backdoor \<psi>,x\<^sup>P\<rparr> in v]"
    hence "[\<lparr>\<^bold>\<lambda>x. \<^bold>\<forall>p. p \<^bold>\<rightarrow> p,\<^bold>\<iota>y. y \<^bold>= x \<^bold>& \<psi> (x\<^sup>P)\<rparr> in v]"
      using beta_C_meta_1[equiv_lr, OF assms]
      unfolding backdoor_def identity_\<nu>_def by fast
    hence "[\<^bold>\<exists>!y. \<^bold>\<A> (y \<^bold>= x \<^bold>& \<psi> (x\<^sup>P)) in v]"
      using exe_impl_exists[equiv_lr] by fast
    thus "[\<^bold>\<A>\<psi> (x\<^sup>P) in v]"
      using exists_unique_actual_equiv[equiv_lr] by blast
  next
    assume "[\<^bold>\<A>\<psi> (x\<^sup>P) in v]"
    hence "[\<^bold>\<exists>!y. \<^bold>\<A> (y \<^bold>= x \<^bold>& \<psi> (x\<^sup>P)) in v]"
      using exists_unique_actual_equiv[equiv_rl] by blast
    hence "[\<lparr>\<^bold>\<lambda>x. \<^bold>\<forall>p. p \<^bold>\<rightarrow> p,\<^bold>\<iota>y. y \<^bold>= x \<^bold>& \<psi> (x\<^sup>P)\<rparr> in v]"
      using exe_impl_exists[equiv_rl] by fast
    thus "[\<lparr>backdoor \<psi>,x\<^sup>P\<rparr> in v]"
      using beta_C_meta_1[equiv_rl, OF assms]
      unfolding backdoor_def unfolding identity_\<nu>_def by fast
  qed

  lemma fake_beta_act:
    assumes "\<And> G \<phi>. IsProperInX (\<lambda>x . \<lparr>G,\<^bold>\<iota>y . \<phi> y x\<rparr>)"
    shows "[\<lparr>backdoor (\<lambda> x . \<psi> x), x\<^sup>P\<rparr> \<^bold>\<equiv> \<psi> (x\<^sup>P) in dw]"
    using fake_beta[OF assms]
      logic_actual[necessitation_averse_axiom_instance]
      intro_elim_6_e by blast

subsection\<open>Resulting Paradox\<close>

text\<open>
  \label{TAO_Paradox_russell-paradox}
\<close>

  lemma paradox:
    assumes "\<And> G \<phi>. IsProperInX (\<lambda>x . \<lparr>G,\<^bold>\<iota>y . \<phi> y x\<rparr>)"
    shows "False"
  proof -
    obtain K where K_def:
      "K = backdoor (\<lambda> x . \<^bold>\<exists> F . \<lbrace>x,F\<rbrace> \<^bold>& \<^bold>\<not>\<lparr>F,x\<rparr>)" by auto
    have "[\<^bold>\<exists>x. \<lparr>A!,x\<^sup>P\<rparr> \<^bold>& (\<^bold>\<forall>F. \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv> (F \<^bold>= K)) in dw]"
      using A_objects[axiom_instance] by fast
    then obtain x where x_prop:
      "[\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& (\<^bold>\<forall>F. \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv> (F \<^bold>= K)) in dw]"
      by (rule Instantiate)
    {
      assume "[\<lparr>K,x\<^sup>P\<rparr> in dw]"
      hence "[\<^bold>\<exists> F . \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>& \<^bold>\<not>\<lparr>F,x\<^sup>P\<rparr> in dw]"
        unfolding K_def using fake_beta_act[OF assms, equiv_lr]
        by blast
      then obtain F where F_def:
        "[\<lbrace>x\<^sup>P,F\<rbrace> \<^bold>& \<^bold>\<not>\<lparr>F,x\<^sup>P\<rparr> in dw]" by (rule Instantiate)
      hence "[F \<^bold>= K in dw]"
        using x_prop[conj2, THEN "\<^bold>\<forall>E"[where \<beta>=F], equiv_lr]
          "\<^bold>&E" unfolding K_def by blast
      hence "[\<^bold>\<not>\<lparr>K,x\<^sup>P\<rparr> in dw]"
        using l_identity[axiom_instance,deduction,deduction]
             F_def[conj2] by fast
    }
    hence 1: "[\<^bold>\<not>\<lparr>K,x\<^sup>P\<rparr> in dw]"
      using reductio_aa_1 by blast
    hence "[\<^bold>\<not>(\<^bold>\<exists> F . \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>& \<^bold>\<not>\<lparr>F,x\<^sup>P\<rparr>) in dw]"
      using fake_beta_act[OF assms,
            THEN oth_class_taut_5_d[equiv_lr],
            equiv_lr]
      unfolding K_def by blast
    hence "[\<^bold>\<forall> F . \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<rightarrow> \<lparr>F,x\<^sup>P\<rparr> in dw]"
      apply - unfolding exists_def by PLM_solver
    moreover have "[\<lbrace>x\<^sup>P,K\<rbrace> in dw]"
      using x_prop[conj2, THEN "\<^bold>\<forall>E"[where \<beta>=K], equiv_rl]
            id_eq_1 by blast
    ultimately have "[\<lparr>K,x\<^sup>P\<rparr> in dw]"
      using "\<^bold>\<forall>E" vdash_properties_10 by blast
    hence "\<And>\<phi>. [\<phi> in dw]"
      using raa_cor_2 1 by blast
    thus "False" using Semantics.T4 by auto
  qed

subsection\<open>Original Version of the Paradox\<close>

text\<open>
  \label{TAO_Paradox_original-paradox}
  Originally the paradox was discovered using the following
  construction based on the comprehension theorem for relations
  without the explicit construction of the description backdoor
  and the resulting fake-\<open>\<beta>\<close>-conversion.
\<close>

  lemma assumes "\<And> G \<phi>. IsProperInX (\<lambda>x . \<lparr>G,\<^bold>\<iota>y . \<phi> y x\<rparr>)"
  shows Fx_equiv_xH: "[\<^bold>\<forall> H . \<^bold>\<exists> F . \<^bold>\<box>(\<^bold>\<forall>x. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lbrace>x\<^sup>P,H\<rbrace>) in v]"
  proof (rule "\<^bold>\<forall>I")
    fix H
    let ?G = "(\<^bold>\<lambda>x . \<^bold>\<forall> p . p \<^bold>\<rightarrow> p)"
    obtain \<phi> where \<phi>_def: "\<phi> = (\<lambda> y x . (y\<^sup>P) \<^bold>= x \<^bold>& \<lbrace>x,H\<rbrace>)" by auto
    have "[\<^bold>\<exists>F. \<^bold>\<box>(\<^bold>\<forall>x. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>?G,\<^bold>\<iota>y . \<phi> y (x\<^sup>P)\<rparr>) in v]"
      using relations_1[OF assms] by simp
    hence 1: "[\<^bold>\<exists>F. \<^bold>\<box>(\<^bold>\<forall>x. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> (\<^bold>\<exists>!y . \<^bold>\<A>\<phi> y (x\<^sup>P))) in v]"
      apply - apply (PLM_subst_method
          "\<lambda> x . \<lparr>?G,\<^bold>\<iota>y . \<phi> y (x\<^sup>P)\<rparr>" "\<lambda> x . (\<^bold>\<exists>!y. \<^bold>\<A>\<phi> y (x\<^sup>P))")
      using exe_impl_exists by auto
    then obtain F where F_def: "[\<^bold>\<box>(\<^bold>\<forall>x. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> (\<^bold>\<exists>!y . \<^bold>\<A>\<phi> y (x\<^sup>P))) in v]"
      by (rule Instantiate)
    moreover have 2: "\<And> v x . [(\<^bold>\<exists>!y . \<^bold>\<A>\<phi> y (x\<^sup>P)) \<^bold>\<equiv> \<lbrace>x\<^sup>P,H\<rbrace> in v]"
    proof (rule "\<^bold>\<equiv>I"; rule CP)
      fix x v
      assume "[\<^bold>\<exists>!y. \<^bold>\<A>\<phi> y (x\<^sup>P) in v]"
      hence "[\<^bold>\<exists>\<alpha>. \<^bold>\<A>\<phi> \<alpha> (x\<^sup>P) \<^bold>& (\<^bold>\<forall>\<beta>. \<^bold>\<A>\<phi> \<beta> (x\<^sup>P) \<^bold>\<rightarrow> \<beta> \<^bold>= \<alpha>) in v]"
        unfolding exists_unique_def by simp
      then obtain \<alpha> where "[\<^bold>\<A>\<phi> \<alpha> (x\<^sup>P) \<^bold>& (\<^bold>\<forall>\<beta>. \<^bold>\<A>\<phi> \<beta> (x\<^sup>P) \<^bold>\<rightarrow> \<beta> \<^bold>= \<alpha>) in v]"
        by (rule Instantiate)
      hence "[\<^bold>\<A>(\<alpha>\<^sup>P \<^bold>= x\<^sup>P \<^bold>& \<lbrace>x\<^sup>P,H\<rbrace>) in v]"
        unfolding \<phi>_def using "\<^bold>&E" by blast
      hence "[\<^bold>\<A>(\<lbrace>x\<^sup>P,H\<rbrace>) in v]"
        using Act_Basic_2[equiv_lr] "\<^bold>&E" by blast
      thus "[\<lbrace>x\<^sup>P,H\<rbrace> in v]"
        using en_eq_10[equiv_lr] by simp
    next
      fix x v
      assume "[\<lbrace>x\<^sup>P,H\<rbrace> in v]"
      hence 1: "[\<^bold>\<A>(\<lbrace>x\<^sup>P,H\<rbrace>) in v]"
        using en_eq_10[equiv_rl] by blast
      have "[x \<^bold>= x in v]"
        using id_eq_1[where 'a=\<nu>] by simp
      hence "[\<^bold>\<A>(x \<^bold>= x) in v]"
        using id_act_3[equiv_lr] by fast
      hence "[\<^bold>\<A>(x\<^sup>P \<^bold>= x\<^sup>P \<^bold>& \<lbrace>x\<^sup>P,H\<rbrace>) in v]"
        unfolding identity_\<nu>_def using 1 Act_Basic_2[equiv_rl] "\<^bold>&I" by blast
      hence "[\<^bold>\<A>\<phi> x (x\<^sup>P) in v]"
        unfolding \<phi>_def by simp
      moreover have "[\<^bold>\<forall>\<beta>. \<^bold>\<A>\<phi> \<beta> (x\<^sup>P) \<^bold>\<rightarrow> \<beta> \<^bold>= x in v]"
      proof (rule "\<^bold>\<forall>I"; rule CP)
        fix \<beta>
        assume "[\<^bold>\<A>\<phi> \<beta> (x\<^sup>P) in v]"
        hence "[\<^bold>\<A>(\<beta> \<^bold>= x) in v]"
          unfolding \<phi>_def identity_\<nu>_def
          using Act_Basic_2[equiv_lr] "\<^bold>&E" by fast
        thus "[\<beta> \<^bold>= x in v]" using id_act_3[equiv_rl] by fast
      qed
      ultimately have "[\<^bold>\<A>\<phi> x (x\<^sup>P) \<^bold>& (\<^bold>\<forall>\<beta>. \<^bold>\<A>\<phi> \<beta> (x\<^sup>P) \<^bold>\<rightarrow> \<beta> \<^bold>= x) in v]"
        using "\<^bold>&I" by fast
      hence "[\<^bold>\<exists>\<alpha>. \<^bold>\<A>\<phi> \<alpha> (x\<^sup>P) \<^bold>& (\<^bold>\<forall>\<beta>. \<^bold>\<A>\<phi> \<beta> (x\<^sup>P) \<^bold>\<rightarrow> \<beta> \<^bold>= \<alpha>) in v]"
        by (rule existential)
      thus "[\<^bold>\<exists>!y. \<^bold>\<A>\<phi> y (x\<^sup>P) in v]"
        unfolding exists_unique_def by simp
    qed
    have "[\<^bold>\<box>(\<^bold>\<forall>x. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lbrace>x\<^sup>P,H\<rbrace>) in v]"
      apply (PLM_subst_goal_method
          "\<lambda>\<phi> . \<^bold>\<box>(\<^bold>\<forall>x. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<phi> x)"
          "\<lambda> x . (\<^bold>\<exists>!y . \<^bold>\<A>\<phi> y (x\<^sup>P))")
      using 2 F_def by auto
    thus "[\<^bold>\<exists> F . \<^bold>\<box>(\<^bold>\<forall>x. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lbrace>x\<^sup>P,H\<rbrace>) in v]"
      by (rule existential)
  qed

  lemma
    assumes is_propositional: "(\<And>G \<phi>. IsProperInX (\<lambda>x. \<lparr>G,\<^bold>\<iota>y. \<phi> y x\<rparr>))"
        and Abs_x: "[\<lparr>A!,x\<^sup>P\<rparr> in v]"
        and Abs_y: "[\<lparr>A!,y\<^sup>P\<rparr> in v]"
        and noteq: "[x \<^bold>\<noteq> y in v]"
  shows diffprop: "[\<^bold>\<exists> F . \<^bold>\<not>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) in v]"
  proof -
    have "[\<^bold>\<exists> F . \<^bold>\<not>(\<lbrace>x\<^sup>P, F\<rbrace> \<^bold>\<equiv> \<lbrace>y\<^sup>P, F\<rbrace>) in v]"
      using noteq unfolding exists_def
    proof (rule reductio_aa_2)
      assume 1: "[\<^bold>\<forall>F. \<^bold>\<not>\<^bold>\<not>(\<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv> \<lbrace>y\<^sup>P,F\<rbrace>) in v]"
      {
        fix F
        have "[(\<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv> \<lbrace>y\<^sup>P,F\<rbrace>) in v]"
          using 1[THEN "\<^bold>\<forall>E"] useful_tautologies_1[deduction] by blast
      }
      hence "[\<^bold>\<forall>F. \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv> \<lbrace>y\<^sup>P,F\<rbrace> in v]" by (rule "\<^bold>\<forall>I")
      thus "[x \<^bold>= y in v]"
        unfolding identity_\<nu>_def
        using ab_obey_1[deduction, deduction]
              Abs_x Abs_y "\<^bold>&I" by blast
    qed
    then obtain H where H_def: "[\<^bold>\<not>(\<lbrace>x\<^sup>P, H\<rbrace> \<^bold>\<equiv> \<lbrace>y\<^sup>P, H\<rbrace>) in v]"
      by (rule Instantiate)
    hence 2: "[(\<lbrace>x\<^sup>P, H\<rbrace> \<^bold>& \<^bold>\<not>\<lbrace>y\<^sup>P, H\<rbrace>) \<^bold>\<or> (\<^bold>\<not>\<lbrace>x\<^sup>P, H\<rbrace> \<^bold>& \<lbrace>y\<^sup>P, H\<rbrace>) in v]"
      apply - by PLM_solver
    have "[\<^bold>\<exists>F. \<^bold>\<box>(\<^bold>\<forall>x. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lbrace>x\<^sup>P,H\<rbrace>) in v]"
      using Fx_equiv_xH[OF is_propositional, THEN "\<^bold>\<forall>E"] by simp
    then obtain F where "[\<^bold>\<box>(\<^bold>\<forall>x. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lbrace>x\<^sup>P,H\<rbrace>) in v]"
      by (rule Instantiate)
    hence F_prop: "[\<^bold>\<forall>x. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lbrace>x\<^sup>P,H\<rbrace> in v]"
      using qml_2[axiom_instance, deduction] by blast
    hence a: "[\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lbrace>x\<^sup>P,H\<rbrace> in v]"
      using "\<^bold>\<forall>E" by blast
    have b: "[\<lparr>F,y\<^sup>P\<rparr> \<^bold>\<equiv> \<lbrace>y\<^sup>P,H\<rbrace> in v]"
      using F_prop "\<^bold>\<forall>E" by blast
    {
      assume 1: "[\<lbrace>x\<^sup>P, H\<rbrace> \<^bold>& \<^bold>\<not>\<lbrace>y\<^sup>P, H\<rbrace> in v]"
      hence "[\<lparr>F,x\<^sup>P\<rparr> in v]"
        using a[equiv_rl] "\<^bold>&E" by blast
      moreover have "[\<^bold>\<not>\<lparr>F,y\<^sup>P\<rparr> in v]"
        using b[THEN oth_class_taut_5_d[equiv_lr], equiv_rl] 1[conj2] by auto
      ultimately have "[\<lparr>F,x\<^sup>P\<rparr> \<^bold>& (\<^bold>\<not>\<lparr>F,y\<^sup>P\<rparr>) in v]"
        by (rule "\<^bold>&I")
      hence "[(\<lparr>F,x\<^sup>P\<rparr> \<^bold>& \<^bold>\<not>\<lparr>F,y\<^sup>P\<rparr>) \<^bold>\<or> (\<^bold>\<not>\<lparr>F,x\<^sup>P\<rparr> \<^bold>& \<lparr>F,y\<^sup>P\<rparr>) in v]"
        using "\<^bold>\<or>I" by blast
      hence "[\<^bold>\<not>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) in v]"
        using oth_class_taut_5_j[equiv_rl] by blast
    }
    moreover {
      assume 1: "[\<^bold>\<not>\<lbrace>x\<^sup>P, H\<rbrace> \<^bold>& \<lbrace>y\<^sup>P, H\<rbrace> in v]"
      hence "[\<lparr>F,y\<^sup>P\<rparr> in v]"
        using b[equiv_rl] "\<^bold>&E" by blast
      moreover have "[\<^bold>\<not>\<lparr>F,x\<^sup>P\<rparr> in v]"
        using a[THEN oth_class_taut_5_d[equiv_lr], equiv_rl] 1[conj1] by auto
      ultimately have "[\<^bold>\<not>\<lparr>F,x\<^sup>P\<rparr> \<^bold>& \<lparr>F,y\<^sup>P\<rparr> in v]"
        using "\<^bold>&I" by blast
      hence "[(\<lparr>F,x\<^sup>P\<rparr> \<^bold>& \<^bold>\<not>\<lparr>F,y\<^sup>P\<rparr>) \<^bold>\<or> (\<^bold>\<not>\<lparr>F,x\<^sup>P\<rparr> \<^bold>& \<lparr>F,y\<^sup>P\<rparr>) in v]"
        using "\<^bold>\<or>I" by blast
      hence "[\<^bold>\<not>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) in v]"
        using oth_class_taut_5_j[equiv_rl] by blast
    }
    ultimately have "[\<^bold>\<not>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) in v]"
      using 2 intro_elim_4_b reductio_aa_1 by blast
    thus "[\<^bold>\<exists> F . \<^bold>\<not>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) in v]"
      by (rule existential)
  qed

  lemma original_paradox:
    assumes is_propositional: "(\<And>G \<phi>. IsProperInX (\<lambda>x. \<lparr>G,\<^bold>\<iota>y. \<phi> y x\<rparr>))"
    shows "False"
  proof -
    fix v
    have "[\<^bold>\<exists>x y. \<lparr>A!,x\<^sup>P\<rparr> \<^bold>& \<lparr>A!,y\<^sup>P\<rparr> \<^bold>& x \<^bold>\<noteq> y \<^bold>& (\<^bold>\<forall>F. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) in v]"
      using aclassical2 by auto
    then obtain x where
      "[\<^bold>\<exists> y. \<lparr>A!,x\<^sup>P\<rparr> \<^bold>& \<lparr>A!,y\<^sup>P\<rparr> \<^bold>& x \<^bold>\<noteq> y \<^bold>& (\<^bold>\<forall>F. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) in v]"
      by (rule Instantiate)
    then obtain y where xy_def:
      "[\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& \<lparr>A!,y\<^sup>P\<rparr> \<^bold>& x \<^bold>\<noteq> y \<^bold>& (\<^bold>\<forall>F. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) in v]"
      by (rule Instantiate)
    have "[\<^bold>\<exists> F . \<^bold>\<not>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) in v]"
      using diffprop[OF assms, OF xy_def[conj1,conj1,conj1],
                     OF xy_def[conj1,conj1,conj2],
                     OF xy_def[conj1,conj2]]
      by auto
    then obtain F where "[\<^bold>\<not>(\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>) in v]"
      by (rule Instantiate)
    moreover have "[\<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr> in v]"
      using xy_def[conj2] by (rule "\<^bold>\<forall>E")
    ultimately have "\<And>\<phi>.[\<phi> in v]"
      using PLM.raa_cor_2 by blast
    thus "False"
      using Semantics.T4 by auto
  qed

(*<*)
end
(*>*)

end