(*  Title:      HOL/Probability/Measurable.thy
    Author:     Johannes Hölzl <hoelzl@in.tum.de>
*)
theory Measurable
  imports
    Sigma_Algebra
    "~~/src/HOL/Library/Order_Continuity"
begin

hide_const (open) Order_Continuity.continuous

subsection {* Measurability prover *}

lemma (in algebra) sets_Collect_finite_All:
  assumes "\<And>i. i \<in> S \<Longrightarrow> {x\<in>\<Omega>. P i x} \<in> M" "finite S"
  shows "{x\<in>\<Omega>. \<forall>i\<in>S. P i x} \<in> M"
proof -
  have "{x\<in>\<Omega>. \<forall>i\<in>S. P i x} = (if S = {} then \<Omega> else \<Inter>i\<in>S. {x\<in>\<Omega>. P i x})"
    by auto
  with assms show ?thesis by (auto intro!: sets_Collect_finite_All')
qed

abbreviation "pred M P \<equiv> P \<in> measurable M (count_space (UNIV::bool set))"

lemma pred_def: "pred M P \<longleftrightarrow> {x\<in>space M. P x} \<in> sets M"
proof
  assume "pred M P"
  then have "P -` {True} \<inter> space M \<in> sets M"
    by (auto simp: measurable_count_space_eq2)
  also have "P -` {True} \<inter> space M = {x\<in>space M. P x}" by auto
  finally show "{x\<in>space M. P x} \<in> sets M" .
next
  assume P: "{x\<in>space M. P x} \<in> sets M"
  moreover
  { fix X
    have "X \<in> Pow (UNIV :: bool set)" by simp
    then have "P -` X \<inter> space M = {x\<in>space M. ((X = {True} \<longrightarrow> P x) \<and> (X = {False} \<longrightarrow> \<not> P x) \<and> X \<noteq> {})}"
      unfolding UNIV_bool Pow_insert Pow_empty by auto
    then have "P -` X \<inter> space M \<in> sets M"
      by (auto intro!: sets.sets_Collect_neg sets.sets_Collect_imp sets.sets_Collect_conj sets.sets_Collect_const P) }
  then show "pred M P"
    by (auto simp: measurable_def)
qed

lemma pred_sets1: "{x\<in>space M. P x} \<in> sets M \<Longrightarrow> f \<in> measurable N M \<Longrightarrow> pred N (\<lambda>x. P (f x))"
  by (rule measurable_compose[where f=f and N=M]) (auto simp: pred_def)

lemma pred_sets2: "A \<in> sets N \<Longrightarrow> f \<in> measurable M N \<Longrightarrow> pred M (\<lambda>x. f x \<in> A)"
  by (rule measurable_compose[where f=f and N=N]) (auto simp: pred_def Int_def[symmetric])

ML_file "measurable.ML"

attribute_setup measurable = {*
  Scan.lift (
    (Args.add >> K true || Args.del >> K false || Scan.succeed true) --
    Scan.optional (Args.parens (
      Scan.optional (Args.$$$ "raw" >> K true) false --
      Scan.optional (Args.$$$ "generic" >> K Measurable.Generic) Measurable.Concrete))
    (false, Measurable.Concrete) >>
    Measurable.measurable_thm_attr)
*} "declaration of measurability theorems"

attribute_setup measurable_dest = Measurable.dest_thm_attr
  "add dest rule to measurability prover"

attribute_setup measurable_app = Measurable.app_thm_attr
  "add application rule to measurability prover"

attribute_setup measurable_cong = Measurable.cong_thm_attr
  "add congurence rules to measurability prover"

method_setup measurable = \<open> Scan.lift (Scan.succeed (METHOD o Measurable.measurable_tac)) \<close>
  "measurability prover"

simproc_setup measurable ("A \<in> sets M" | "f \<in> measurable M N") = {* K Measurable.simproc *}

setup {*
  Global_Theory.add_thms_dynamic (@{binding measurable}, Measurable.get_all)
*}

declare
  measurable_compose_rev[measurable_dest]
  pred_sets1[measurable_dest]
  pred_sets2[measurable_dest]
  sets.sets_into_space[measurable_dest]

declare
  sets.top[measurable]
  sets.empty_sets[measurable (raw)]
  sets.Un[measurable (raw)]
  sets.Diff[measurable (raw)]

declare
  measurable_count_space[measurable (raw)]
  measurable_ident[measurable (raw)]
  measurable_id[measurable (raw)]
  measurable_const[measurable (raw)]
  measurable_If[measurable (raw)]
  measurable_comp[measurable (raw)]
  measurable_sets[measurable (raw)]

declare measurable_cong_sets[measurable_cong]
declare sets_restrict_space_cong[measurable_cong]

lemma predE[measurable (raw)]:
  "pred M P \<Longrightarrow> {x\<in>space M. P x} \<in> sets M"
  unfolding pred_def .

lemma pred_intros_imp'[measurable (raw)]:
  "(K \<Longrightarrow> pred M (\<lambda>x. P x)) \<Longrightarrow> pred M (\<lambda>x. K \<longrightarrow> P x)"
  by (cases K) auto

lemma pred_intros_conj1'[measurable (raw)]:
  "(K \<Longrightarrow> pred M (\<lambda>x. P x)) \<Longrightarrow> pred M (\<lambda>x. K \<and> P x)"
  by (cases K) auto

lemma pred_intros_conj2'[measurable (raw)]:
  "(K \<Longrightarrow> pred M (\<lambda>x. P x)) \<Longrightarrow> pred M (\<lambda>x. P x \<and> K)"
  by (cases K) auto

lemma pred_intros_disj1'[measurable (raw)]:
  "(\<not> K \<Longrightarrow> pred M (\<lambda>x. P x)) \<Longrightarrow> pred M (\<lambda>x. K \<or> P x)"
  by (cases K) auto

lemma pred_intros_disj2'[measurable (raw)]:
  "(\<not> K \<Longrightarrow> pred M (\<lambda>x. P x)) \<Longrightarrow> pred M (\<lambda>x. P x \<or> K)"
  by (cases K) auto

lemma pred_intros_logic[measurable (raw)]:
  "pred M (\<lambda>x. x \<in> space M)"
  "pred M (\<lambda>x. P x) \<Longrightarrow> pred M (\<lambda>x. \<not> P x)"
  "pred M (\<lambda>x. Q x) \<Longrightarrow> pred M (\<lambda>x. P x) \<Longrightarrow> pred M (\<lambda>x. Q x \<and> P x)"
  "pred M (\<lambda>x. Q x) \<Longrightarrow> pred M (\<lambda>x. P x) \<Longrightarrow> pred M (\<lambda>x. Q x \<longrightarrow> P x)"
  "pred M (\<lambda>x. Q x) \<Longrightarrow> pred M (\<lambda>x. P x) \<Longrightarrow> pred M (\<lambda>x. Q x \<or> P x)"
  "pred M (\<lambda>x. Q x) \<Longrightarrow> pred M (\<lambda>x. P x) \<Longrightarrow> pred M (\<lambda>x. Q x = P x)"
  "pred M (\<lambda>x. f x \<in> UNIV)"
  "pred M (\<lambda>x. f x \<in> {})"
  "pred M (\<lambda>x. P' (f x) x) \<Longrightarrow> pred M (\<lambda>x. f x \<in> {y. P' y x})"
  "pred M (\<lambda>x. f x \<in> (B x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> - (B x))"
  "pred M (\<lambda>x. f x \<in> (A x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (B x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (A x) - (B x))"
  "pred M (\<lambda>x. f x \<in> (A x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (B x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (A x) \<inter> (B x))"
  "pred M (\<lambda>x. f x \<in> (A x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (B x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (A x) \<union> (B x))"
  "pred M (\<lambda>x. g x (f x) \<in> (X x)) \<Longrightarrow> pred M (\<lambda>x. f x \<in> (g x) -` (X x))"
  by (auto simp: iff_conv_conj_imp pred_def)

lemma pred_intros_countable[measurable (raw)]:
  fixes P :: "'a \<Rightarrow> 'i :: countable \<Rightarrow> bool"
  shows
    "(\<And>i. pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<forall>i. P x i)"
    "(\<And>i. pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<exists>i. P x i)"
  by (auto intro!: sets.sets_Collect_countable_All sets.sets_Collect_countable_Ex simp: pred_def)

lemma pred_intros_countable_bounded[measurable (raw)]:
  fixes X :: "'i :: countable set"
  shows
    "(\<And>i. i \<in> X \<Longrightarrow> pred M (\<lambda>x. x \<in> N x i)) \<Longrightarrow> pred M (\<lambda>x. x \<in> (\<Inter>i\<in>X. N x i))"
    "(\<And>i. i \<in> X \<Longrightarrow> pred M (\<lambda>x. x \<in> N x i)) \<Longrightarrow> pred M (\<lambda>x. x \<in> (\<Union>i\<in>X. N x i))"
    "(\<And>i. i \<in> X \<Longrightarrow> pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<forall>i\<in>X. P x i)"
    "(\<And>i. i \<in> X \<Longrightarrow> pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<exists>i\<in>X. P x i)"
  by (auto simp: Bex_def Ball_def)

lemma pred_intros_finite[measurable (raw)]:
  "finite I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> pred M (\<lambda>x. x \<in> N x i)) \<Longrightarrow> pred M (\<lambda>x. x \<in> (\<Inter>i\<in>I. N x i))"
  "finite I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> pred M (\<lambda>x. x \<in> N x i)) \<Longrightarrow> pred M (\<lambda>x. x \<in> (\<Union>i\<in>I. N x i))"
  "finite I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<forall>i\<in>I. P x i)"
  "finite I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> pred M (\<lambda>x. P x i)) \<Longrightarrow> pred M (\<lambda>x. \<exists>i\<in>I. P x i)"
  by (auto intro!: sets.sets_Collect_finite_Ex sets.sets_Collect_finite_All simp: iff_conv_conj_imp pred_def)

lemma countable_Un_Int[measurable (raw)]:
  "(\<And>i :: 'i :: countable. i \<in> I \<Longrightarrow> N i \<in> sets M) \<Longrightarrow> (\<Union>i\<in>I. N i) \<in> sets M"
  "I \<noteq> {} \<Longrightarrow> (\<And>i :: 'i :: countable. i \<in> I \<Longrightarrow> N i \<in> sets M) \<Longrightarrow> (\<Inter>i\<in>I. N i) \<in> sets M"
  by auto

declare
  finite_UN[measurable (raw)]
  finite_INT[measurable (raw)]

lemma sets_Int_pred[measurable (raw)]:
  assumes space: "A \<inter> B \<subseteq> space M" and [measurable]: "pred M (\<lambda>x. x \<in> A)" "pred M (\<lambda>x. x \<in> B)"
  shows "A \<inter> B \<in> sets M"
proof -
  have "{x\<in>space M. x \<in> A \<inter> B} \<in> sets M" by auto
  also have "{x\<in>space M. x \<in> A \<inter> B} = A \<inter> B"
    using space by auto
  finally show ?thesis .
qed

lemma [measurable (raw generic)]:
  assumes f: "f \<in> measurable M N" and c: "c \<in> space N \<Longrightarrow> {c} \<in> sets N"
  shows pred_eq_const1: "pred M (\<lambda>x. f x = c)"
    and pred_eq_const2: "pred M (\<lambda>x. c = f x)"
proof -
  show "pred M (\<lambda>x. f x = c)"
  proof cases
    assume "c \<in> space N"
    with measurable_sets[OF f c] show ?thesis
      by (auto simp: Int_def conj_commute pred_def)
  next
    assume "c \<notin> space N"
    with f[THEN measurable_space] have "{x \<in> space M. f x = c} = {}" by auto
    then show ?thesis by (auto simp: pred_def cong: conj_cong)
  qed
  then show "pred M (\<lambda>x. c = f x)"
    by (simp add: eq_commute)
qed

lemma pred_count_space_const1[measurable (raw)]:
  "f \<in> measurable M (count_space UNIV) \<Longrightarrow> Measurable.pred M (\<lambda>x. f x = c)"
  by (intro pred_eq_const1[where N="count_space UNIV"]) (auto )

lemma pred_count_space_const2[measurable (raw)]:
  "f \<in> measurable M (count_space UNIV) \<Longrightarrow> Measurable.pred M (\<lambda>x. c = f x)"
  by (intro pred_eq_const2[where N="count_space UNIV"]) (auto )

lemma pred_le_const[measurable (raw generic)]:
  assumes f: "f \<in> measurable M N" and c: "{.. c} \<in> sets N" shows "pred M (\<lambda>x. f x \<le> c)"
  using measurable_sets[OF f c]
  by (auto simp: Int_def conj_commute eq_commute pred_def)

lemma pred_const_le[measurable (raw generic)]:
  assumes f: "f \<in> measurable M N" and c: "{c ..} \<in> sets N" shows "pred M (\<lambda>x. c \<le> f x)"
  using measurable_sets[OF f c]
  by (auto simp: Int_def conj_commute eq_commute pred_def)

lemma pred_less_const[measurable (raw generic)]:
  assumes f: "f \<in> measurable M N" and c: "{..< c} \<in> sets N" shows "pred M (\<lambda>x. f x < c)"
  using measurable_sets[OF f c]
  by (auto simp: Int_def conj_commute eq_commute pred_def)

lemma pred_const_less[measurable (raw generic)]:
  assumes f: "f \<in> measurable M N" and c: "{c <..} \<in> sets N" shows "pred M (\<lambda>x. c < f x)"
  using measurable_sets[OF f c]
  by (auto simp: Int_def conj_commute eq_commute pred_def)

declare
  sets.Int[measurable (raw)]

lemma pred_in_If[measurable (raw)]:
  "(P \<Longrightarrow> pred M (\<lambda>x. x \<in> A x)) \<Longrightarrow> (\<not> P \<Longrightarrow> pred M (\<lambda>x. x \<in> B x)) \<Longrightarrow>
    pred M (\<lambda>x. x \<in> (if P then A x else B x))"
  by auto

lemma sets_range[measurable_dest]:
  "A ` I \<subseteq> sets M \<Longrightarrow> i \<in> I \<Longrightarrow> A i \<in> sets M"
  by auto

lemma pred_sets_range[measurable_dest]:
  "A ` I \<subseteq> sets N \<Longrightarrow> i \<in> I \<Longrightarrow> f \<in> measurable M N \<Longrightarrow> pred M (\<lambda>x. f x \<in> A i)"
  using pred_sets2[OF sets_range] by auto

lemma sets_All[measurable_dest]:
  "\<forall>i. A i \<in> sets (M i) \<Longrightarrow> A i \<in> sets (M i)"
  by auto

lemma pred_sets_All[measurable_dest]:
  "\<forall>i. A i \<in> sets (N i) \<Longrightarrow> f \<in> measurable M (N i) \<Longrightarrow> pred M (\<lambda>x. f x \<in> A i)"
  using pred_sets2[OF sets_All, of A N f] by auto

lemma sets_Ball[measurable_dest]:
  "\<forall>i\<in>I. A i \<in> sets (M i) \<Longrightarrow> i\<in>I \<Longrightarrow> A i \<in> sets (M i)"
  by auto

lemma pred_sets_Ball[measurable_dest]:
  "\<forall>i\<in>I. A i \<in> sets (N i) \<Longrightarrow> i\<in>I \<Longrightarrow> f \<in> measurable M (N i) \<Longrightarrow> pred M (\<lambda>x. f x \<in> A i)"
  using pred_sets2[OF sets_Ball, of _ _ _ f] by auto

lemma measurable_finite[measurable (raw)]:
  fixes S :: "'a \<Rightarrow> nat set"
  assumes [measurable]: "\<And>i. {x\<in>space M. i \<in> S x} \<in> sets M"
  shows "pred M (\<lambda>x. finite (S x))"
  unfolding finite_nat_set_iff_bounded by (simp add: Ball_def)

lemma measurable_Least[measurable]:
  assumes [measurable]: "(\<And>i::nat. (\<lambda>x. P i x) \<in> measurable M (count_space UNIV))"q
  shows "(\<lambda>x. LEAST i. P i x) \<in> measurable M (count_space UNIV)"
  unfolding measurable_def by (safe intro!: sets_Least) simp_all

lemma measurable_Max_nat[measurable (raw)]:
  fixes P :: "nat \<Rightarrow> 'a \<Rightarrow> bool"
  assumes [measurable]: "\<And>i. Measurable.pred M (P i)"
  shows "(\<lambda>x. Max {i. P i x}) \<in> measurable M (count_space UNIV)"
  unfolding measurable_count_space_eq2_countable
proof safe
  fix n

  { fix x assume "\<forall>i. \<exists>n\<ge>i. P n x"
    then have "infinite {i. P i x}"
      unfolding infinite_nat_iff_unbounded_le by auto
    then have "Max {i. P i x} = the None"
      by (rule Max.infinite) }
  note 1 = this

  { fix x i j assume "P i x" "\<forall>n\<ge>j. \<not> P n x"
    then have "finite {i. P i x}"
      by (auto simp: subset_eq not_le[symmetric] finite_nat_iff_bounded)
    with `P i x` have "P (Max {i. P i x}) x" "i \<le> Max {i. P i x}" "finite {i. P i x}"
      using Max_in[of "{i. P i x}"] by auto }
  note 2 = this

  have "(\<lambda>x. Max {i. P i x}) -` {n} \<inter> space M = {x\<in>space M. Max {i. P i x} = n}"
    by auto
  also have "\<dots> =
    {x\<in>space M. if (\<forall>i. \<exists>n\<ge>i. P n x) then the None = n else
      if (\<exists>i. P i x) then P n x \<and> (\<forall>i>n. \<not> P i x)
      else Max {} = n}"
    by (intro arg_cong[where f=Collect] ext conj_cong)
       (auto simp add: 1 2 not_le[symmetric] intro!: Max_eqI)
  also have "\<dots> \<in> sets M"
    by measurable
  finally show "(\<lambda>x. Max {i. P i x}) -` {n} \<inter> space M \<in> sets M" .
qed simp

lemma measurable_Min_nat[measurable (raw)]:
  fixes P :: "nat \<Rightarrow> 'a \<Rightarrow> bool"
  assumes [measurable]: "\<And>i. Measurable.pred M (P i)"
  shows "(\<lambda>x. Min {i. P i x}) \<in> measurable M (count_space UNIV)"
  unfolding measurable_count_space_eq2_countable
proof safe
  fix n

  { fix x assume "\<forall>i. \<exists>n\<ge>i. P n x"
    then have "infinite {i. P i x}"
      unfolding infinite_nat_iff_unbounded_le by auto
    then have "Min {i. P i x} = the None"
      by (rule Min.infinite) }
  note 1 = this

  { fix x i j assume "P i x" "\<forall>n\<ge>j. \<not> P n x"
    then have "finite {i. P i x}"
      by (auto simp: subset_eq not_le[symmetric] finite_nat_iff_bounded)
    with `P i x` have "P (Min {i. P i x}) x" "Min {i. P i x} \<le> i" "finite {i. P i x}"
      using Min_in[of "{i. P i x}"] by auto }
  note 2 = this

  have "(\<lambda>x. Min {i. P i x}) -` {n} \<inter> space M = {x\<in>space M. Min {i. P i x} = n}"
    by auto
  also have "\<dots> =
    {x\<in>space M. if (\<forall>i. \<exists>n\<ge>i. P n x) then the None = n else
      if (\<exists>i. P i x) then P n x \<and> (\<forall>i<n. \<not> P i x)
      else Min {} = n}"
    by (intro arg_cong[where f=Collect] ext conj_cong)
       (auto simp add: 1 2 not_le[symmetric] intro!: Min_eqI)
  also have "\<dots> \<in> sets M"
    by measurable
  finally show "(\<lambda>x. Min {i. P i x}) -` {n} \<inter> space M \<in> sets M" .
qed simp

lemma measurable_count_space_insert[measurable (raw)]:
  "s \<in> S \<Longrightarrow> A \<in> sets (count_space S) \<Longrightarrow> insert s A \<in> sets (count_space S)"
  by simp

lemma sets_UNIV [measurable (raw)]: "A \<in> sets (count_space UNIV)"
  by simp

lemma measurable_card[measurable]:
  fixes S :: "'a \<Rightarrow> nat set"
  assumes [measurable]: "\<And>i. {x\<in>space M. i \<in> S x} \<in> sets M"
  shows "(\<lambda>x. card (S x)) \<in> measurable M (count_space UNIV)"
  unfolding measurable_count_space_eq2_countable
proof safe
  fix n show "(\<lambda>x. card (S x)) -` {n} \<inter> space M \<in> sets M"
  proof (cases n)
    case 0
    then have "(\<lambda>x. card (S x)) -` {n} \<inter> space M = {x\<in>space M. infinite (S x) \<or> (\<forall>i. i \<notin> S x)}"
      by auto
    also have "\<dots> \<in> sets M"
      by measurable
    finally show ?thesis .
  next
    case (Suc i)
    then have "(\<lambda>x. card (S x)) -` {n} \<inter> space M =
      (\<Union>F\<in>{A\<in>{A. finite A}. card A = n}. {x\<in>space M. (\<forall>i. i \<in> S x \<longleftrightarrow> i \<in> F)})"
      unfolding set_eq_iff[symmetric] Collect_bex_eq[symmetric] by (auto intro: card_ge_0_finite)
    also have "\<dots> \<in> sets M"
      by (intro sets.countable_UN' countable_Collect countable_Collect_finite) auto
    finally show ?thesis .
  qed
qed rule

lemma measurable_pred_countable[measurable (raw)]:
  assumes "countable X"
  shows
    "(\<And>i. i \<in> X \<Longrightarrow> Measurable.pred M (\<lambda>x. P x i)) \<Longrightarrow> Measurable.pred M (\<lambda>x. \<forall>i\<in>X. P x i)"
    "(\<And>i. i \<in> X \<Longrightarrow> Measurable.pred M (\<lambda>x. P x i)) \<Longrightarrow> Measurable.pred M (\<lambda>x. \<exists>i\<in>X. P x i)"
  unfolding pred_def
  by (auto intro!: sets.sets_Collect_countable_All' sets.sets_Collect_countable_Ex' assms)

subsection {* Measurability for (co)inductive predicates *}

lemma measurable_bot[measurable]: "bot \<in> measurable M (count_space UNIV)"
  by (simp add: bot_fun_def)

lemma measurable_top[measurable]: "top \<in> measurable M (count_space UNIV)"
  by (simp add: top_fun_def)

lemma measurable_SUP[measurable]:
  fixes F :: "'i \<Rightarrow> 'a \<Rightarrow> 'b::{complete_lattice, countable}"
  assumes [simp]: "countable I"
  assumes [measurable]: "\<And>i. i \<in> I \<Longrightarrow> F i \<in> measurable M (count_space UNIV)"
  shows "(\<lambda>x. SUP i:I. F i x) \<in> measurable M (count_space UNIV)"
  unfolding measurable_count_space_eq2_countable
proof (safe intro!: UNIV_I)
  fix a
  have "(\<lambda>x. SUP i:I. F i x) -` {a} \<inter> space M =
    {x\<in>space M. (\<forall>i\<in>I. F i x \<le> a) \<and> (\<forall>b. (\<forall>i\<in>I. F i x \<le> b) \<longrightarrow> a \<le> b)}"
    unfolding SUP_le_iff[symmetric] by auto
  also have "\<dots> \<in> sets M"
    by measurable
  finally show "(\<lambda>x. SUP i:I. F i x) -` {a} \<inter> space M \<in> sets M" .
qed

lemma measurable_INF[measurable]:
  fixes F :: "'i \<Rightarrow> 'a \<Rightarrow> 'b::{complete_lattice, countable}"
  assumes [simp]: "countable I"
  assumes [measurable]: "\<And>i. i \<in> I \<Longrightarrow> F i \<in> measurable M (count_space UNIV)"
  shows "(\<lambda>x. INF i:I. F i x) \<in> measurable M (count_space UNIV)"
  unfolding measurable_count_space_eq2_countable
proof (safe intro!: UNIV_I)
  fix a
  have "(\<lambda>x. INF i:I. F i x) -` {a} \<inter> space M =
    {x\<in>space M. (\<forall>i\<in>I. a \<le> F i x) \<and> (\<forall>b. (\<forall>i\<in>I. b \<le> F i x) \<longrightarrow> b \<le> a)}"
    unfolding le_INF_iff[symmetric] by auto
  also have "\<dots> \<in> sets M"
    by measurable
  finally show "(\<lambda>x. INF i:I. F i x) -` {a} \<inter> space M \<in> sets M" .
qed

lemma measurable_lfp_coinduct[consumes 1, case_names continuity step]:
  fixes F :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes "P M"
  assumes F: "Order_Continuity.continuous F"
  assumes *: "\<And>M A. P M \<Longrightarrow> (\<And>N. P N \<Longrightarrow> A \<in> measurable N (count_space UNIV)) \<Longrightarrow> F A \<in> measurable M (count_space UNIV)"
  shows "lfp F \<in> measurable M (count_space UNIV)"
proof -
  { fix i from `P M` have "((F ^^ i) bot) \<in> measurable M (count_space UNIV)"
      by (induct i arbitrary: M) (auto intro!: *) }
  then have "(\<lambda>x. SUP i. (F ^^ i) bot x) \<in> measurable M (count_space UNIV)"
    by measurable
  also have "(\<lambda>x. SUP i. (F ^^ i) bot x) = lfp F"
    by (subst continuous_lfp) (auto intro: F)
  finally show ?thesis .
qed

lemma measurable_lfp:
  fixes F :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes F: "Order_Continuity.continuous F"
  assumes *: "\<And>A. A \<in> measurable M (count_space UNIV) \<Longrightarrow> F A \<in> measurable M (count_space UNIV)"
  shows "lfp F \<in> measurable M (count_space UNIV)"
  by (coinduction rule: measurable_lfp_coinduct[OF _ F]) (blast intro: *)

lemma measurable_gfp_coinduct[consumes 1, case_names continuity step]:
  fixes F :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes "P M"
  assumes F: "Order_Continuity.down_continuous F"
  assumes *: "\<And>M A. P M \<Longrightarrow> (\<And>N. P N \<Longrightarrow> A \<in> measurable N (count_space UNIV)) \<Longrightarrow> F A \<in> measurable M (count_space UNIV)"
  shows "gfp F \<in> measurable M (count_space UNIV)"
proof -
  { fix i from `P M` have "((F ^^ i) top) \<in> measurable M (count_space UNIV)"
      by (induct i arbitrary: M) (auto intro!: *) }
  then have "(\<lambda>x. INF i. (F ^^ i) top x) \<in> measurable M (count_space UNIV)"
    by measurable
  also have "(\<lambda>x. INF i. (F ^^ i) top x) = gfp F"
    by (subst down_continuous_gfp) (auto intro: F)
  finally show ?thesis .
qed

lemma measurable_gfp:
  fixes F :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes F: "Order_Continuity.down_continuous F"
  assumes *: "\<And>A. A \<in> measurable M (count_space UNIV) \<Longrightarrow> F A \<in> measurable M (count_space UNIV)"
  shows "gfp F \<in> measurable M (count_space UNIV)"
  by (coinduction rule: measurable_gfp_coinduct[OF _ F]) (blast intro: *)

lemma measurable_lfp2_coinduct[consumes 1, case_names continuity step]:
  fixes F :: "('a \<Rightarrow> 'c \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes "P M s"
  assumes F: "Order_Continuity.continuous F"
  assumes *: "\<And>M A s. P M s \<Longrightarrow> (\<And>N t. P N t \<Longrightarrow> A t \<in> measurable N (count_space UNIV)) \<Longrightarrow> F A s \<in> measurable M (count_space UNIV)"
  shows "lfp F s \<in> measurable M (count_space UNIV)"
proof -
  { fix i from `P M s` have "(\<lambda>x. (F ^^ i) bot s x) \<in> measurable M (count_space UNIV)"
      by (induct i arbitrary: M s) (auto intro!: *) }
  then have "(\<lambda>x. SUP i. (F ^^ i) bot s x) \<in> measurable M (count_space UNIV)"
    by measurable
  also have "(\<lambda>x. SUP i. (F ^^ i) bot s x) = lfp F s"
    by (subst continuous_lfp) (auto simp: F)
  finally show ?thesis .
qed

lemma measurable_gfp2_coinduct[consumes 1, case_names continuity step]:
  fixes F :: "('a \<Rightarrow> 'c \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c \<Rightarrow> 'b::{complete_lattice, countable})"
  assumes "P M s"
  assumes F: "Order_Continuity.down_continuous F"
  assumes *: "\<And>M A s. P M s \<Longrightarrow> (\<And>N t. P N t \<Longrightarrow> A t \<in> measurable N (count_space UNIV)) \<Longrightarrow> F A s \<in> measurable M (count_space UNIV)"
  shows "gfp F s \<in> measurable M (count_space UNIV)"
proof -
  { fix i from `P M s` have "(\<lambda>x. (F ^^ i) top s x) \<in> measurable M (count_space UNIV)"
      by (induct i arbitrary: M s) (auto intro!: *) }
  then have "(\<lambda>x. INF i. (F ^^ i) top s x) \<in> measurable M (count_space UNIV)"
    by measurable
  also have "(\<lambda>x. INF i. (F ^^ i) top s x) = gfp F s"
    by (subst down_continuous_gfp) (auto simp: F)
  finally show ?thesis .
qed

lemma measurable_enat_coinduct:
  fixes f :: "'a \<Rightarrow> enat"
  assumes "R f"
  assumes *: "\<And>f. R f \<Longrightarrow> \<exists>g h i P. R g \<and> f = (\<lambda>x. if P x then h x else eSuc (g (i x))) \<and>
    Measurable.pred M P \<and>
    i \<in> measurable M M \<and>
    h \<in> measurable M (count_space UNIV)"
  shows "f \<in> measurable M (count_space UNIV)"
proof (simp add: measurable_count_space_eq2_countable, rule )
  fix a :: enat
  have "f -` {a} \<inter> space M = {x\<in>space M. f x = a}"
    by auto
  { fix i :: nat
    from `R f` have "Measurable.pred M (\<lambda>x. f x = enat i)"
    proof (induction i arbitrary: f)
      case 0
      from *[OF this] obtain g h i P
        where f: "f = (\<lambda>x. if P x then h x else eSuc (g (i x)))" and
          [measurable]: "Measurable.pred M P" "i \<in> measurable M M" "h \<in> measurable M (count_space UNIV)"
        by auto
      have "Measurable.pred M (\<lambda>x. P x \<and> h x = 0)"
        by measurable
      also have "(\<lambda>x. P x \<and> h x = 0) = (\<lambda>x. f x = enat 0)"
        by (auto simp: f zero_enat_def[symmetric])
      finally show ?case .
    next
      case (Suc n)
      from *[OF Suc.prems] obtain g h i P
        where f: "f = (\<lambda>x. if P x then h x else eSuc (g (i x)))" and "R g" and
          M[measurable]: "Measurable.pred M P" "i \<in> measurable M M" "h \<in> measurable M (count_space UNIV)"
        by auto
      have "(\<lambda>x. f x = enat (Suc n)) =
        (\<lambda>x. (P x \<longrightarrow> h x = enat (Suc n)) \<and> (\<not> P x \<longrightarrow> g (i x) = enat n))"
        by (auto simp: f zero_enat_def[symmetric] eSuc_enat[symmetric])
      also have "Measurable.pred M \<dots>"
        by (intro pred_intros_logic measurable_compose[OF M(2)] Suc `R g`) measurable
      finally show ?case .
    qed
    then have "f -` {enat i} \<inter> space M \<in> sets M"
      by (simp add: pred_def Int_def conj_commute) }
  note fin = this
  show "f -` {a} \<inter> space M \<in> sets M"
  proof (cases a)
    case infinity
    then have "f -` {a} \<inter> space M = space M - (\<Union>n. f -` {enat n} \<inter> space M)"
      by auto
    also have "\<dots> \<in> sets M"
      by (intro sets.Diff sets.top sets.Un sets.countable_UN) (auto intro!: fin)
    finally show ?thesis .
  qed (simp add: fin)
qed

lemma measurable_THE:
  fixes P :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  assumes [measurable]: "\<And>i. Measurable.pred M (P i)"
  assumes I[simp]: "countable I" "\<And>i x. x \<in> space M \<Longrightarrow> P i x \<Longrightarrow> i \<in> I"
  assumes unique: "\<And>x i j. x \<in> space M \<Longrightarrow> P i x \<Longrightarrow> P j x \<Longrightarrow> i = j"
  shows "(\<lambda>x. THE i. P i x) \<in> measurable M (count_space UNIV)"
  unfolding measurable_def
proof safe
  fix X
  def f \<equiv> "\<lambda>x. THE i. P i x" def undef \<equiv> "THE i::'a. False"
  { fix i x assume "x \<in> space M" "P i x" then have "f x = i"
      unfolding f_def using unique by auto }
  note f_eq = this
  { fix x assume "x \<in> space M" "\<forall>i\<in>I. \<not> P i x"
    then have "\<And>i. \<not> P i x"
      using I(2)[of x] by auto
    then have "f x = undef"
      by (auto simp: undef_def f_def) }
  then have "f -` X \<inter> space M = (\<Union>i\<in>I \<inter> X. {x\<in>space M. P i x}) \<union>
     (if undef \<in> X then space M - (\<Union>i\<in>I. {x\<in>space M. P i x}) else {})"
    by (auto dest: f_eq)
  also have "\<dots> \<in> sets M"
    by (auto intro!: sets.Diff sets.countable_UN')
  finally show "f -` X \<inter> space M \<in> sets M" .
qed simp

lemma measurable_Ex1[measurable (raw)]:
  assumes [simp]: "countable I" and [measurable]: "\<And>i. i \<in> I \<Longrightarrow> Measurable.pred M (P i)"
  shows "Measurable.pred M (\<lambda>x. \<exists>!i\<in>I. P i x)"
  unfolding bex1_def by measurable

lemma measurable_split_if[measurable (raw)]:
  "(c \<Longrightarrow> Measurable.pred M f) \<Longrightarrow> (\<not> c \<Longrightarrow> Measurable.pred M g) \<Longrightarrow>
   Measurable.pred M (if c then f else g)"
  by simp

lemma pred_restrict_space:
  assumes "S \<in> sets M"
  shows "Measurable.pred (restrict_space M S) P \<longleftrightarrow> Measurable.pred M (\<lambda>x. x \<in> S \<and> P x)"
  unfolding pred_def sets_Collect_restrict_space_iff[OF assms] ..

lemma measurable_predpow[measurable]:
  assumes "Measurable.pred M T"
  assumes "\<And>Q. Measurable.pred M Q \<Longrightarrow> Measurable.pred M (R Q)"
  shows "Measurable.pred M ((R ^^ n) T)"
  by (induct n) (auto intro: assms)

hide_const (open) pred

end


(*  Title:      HOL/IOA/Asig.thy
    Author:     Tobias Nipkow & Konrad Slind
    Copyright   1994  TU Muenchen
*)

section \<open>Action signatures\<close>

theory Asig
imports Main
begin

type_synonym 'a signature = "('a set * 'a set * 'a set)"

definition "inputs" :: "'action signature => 'action set"
  where asig_inputs_def: "inputs == fst"

definition "outputs" :: "'action signature => 'action set"
  where asig_outputs_def: "outputs == (fst o snd)"

definition "internals" :: "'action signature => 'action set"
  where asig_internals_def: "internals == (snd o snd)"

definition "actions" :: "'action signature => 'action set"
  where actions_def: "actions(asig) == (inputs(asig) Un outputs(asig) Un internals(asig))"

definition externals :: "'action signature => 'action set"
  where externals_def: "externals(asig) == (inputs(asig) Un outputs(asig))"

definition is_asig :: "'action signature => bool"
  where "is_asig(triple) ==
    ((inputs(triple) Int outputs(triple) = {})    &
     (outputs(triple) Int internals(triple) = {}) &
     (inputs(triple) Int internals(triple) = {}))"

definition mk_ext_asig :: "'action signature => 'action signature"
  where "mk_ext_asig(triple) == (inputs(triple), outputs(triple), {})"

lemmas asig_projections = asig_inputs_def asig_outputs_def asig_internals_def

lemma int_and_ext_is_act: "[| a~:internals(S) ;a~:externals(S)|] ==> a~:actions(S)"
  apply (simp add: externals_def actions_def)
  done

lemma ext_is_act: "[|a:externals(S)|] ==> a:actions(S)"
  apply (simp add: externals_def actions_def)
  done

end


(* Title: thys/Turing_HaltingConditions.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten

   Further contributions by Franz Regensburger (FABR) 02/2022
 *)

section \<open>Halting Conditions and Standard Halting Configuration\<close>

theory Turing_HaltingConditions
  imports Turing_Hoare
begin

subsection \<open>Looping of Turing Machines\<close>

definition TMC_loops :: "tprog0 \<Rightarrow> nat list \<Rightarrow> bool"
  where
    "TMC_loops p ns \<equiv> (\<forall>stp.\<not> is_final (steps0 (1, [], <ns::nat list>) p stp))"

subsection \<open>Reaching the Final State\<close>

definition reaches_final :: "tprog0 \<Rightarrow> nat list \<Rightarrow> bool"
  where
    "reaches_final p ns \<equiv> \<lbrace>(\<lambda>tap. tap = ([], <ns>))\<rbrace> p \<lbrace>(\<lambda>tap. True)\<rbrace>"

text \<open>The definition @{term reaches_final} and all lemmas about it are only needed for the special halting problem K0. \<close>

lemma True_holds_for_all: "(\<lambda>tap. True) holds_for c"
  by (cases c)(auto)

lemma reaches_final_iff: "reaches_final p ns \<longleftrightarrow> (\<exists>n. is_final (steps0 (1, ([], <ns>)) p n))"
  by (auto simp add: reaches_final_def Hoare_halt_def True_holds_for_all)

text \<open>Some lemmas about reaching the Final State.\<close>

lemma Hoare_halt_from_init_imp_reaches_final:
  assumes "\<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> p \<lbrace>Q\<rbrace>"
  shows "reaches_final p ns"
proof -
  from assms have "\<forall>tap. tap = ([], <ns>) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) p n))"
    using Hoare_halt_def by auto
  then show ?thesis
    using reaches_final_iff by auto
qed

lemma Hoare_unhalt_impl_not_reaches_final:
  assumes "\<lbrace>(\<lambda>tap. tap = ([], <ns>))\<rbrace> p \<up>"
  shows "\<not>(reaches_final p ns)"
proof
  assume "reaches_final p ns"
  then have "(\<exists>n. is_final (steps0 (1, ([], <ns>)) p n))" by (auto simp add: reaches_final_iff)
  then obtain n where w_n: "is_final (steps0 (1, ([], <ns>)) p n)" by blast
  from assms have "\<forall>tap. (\<lambda>tap. tap = ([], <ns>)) tap \<longrightarrow> (\<forall> n . \<not> (is_final (steps0 (1, tap) p n)))"
    by (auto simp add: Hoare_unhalt_def)
  then have "\<not> (is_final (steps0 (1, ([], <ns>)) p n))" by blast
  with w_n show False by auto
qed

subsection \<open>What is a Standard Tape\<close>

text \<open>A tape is called {\em standard}, if the left tape is empty or contains only blanks and
the right tape contains a single nonempty block of strokes (occupied cells) followed by zero or more blanks..

Thus, by definition of left and right tape, the head of the machine is always
scanning the first cell of this single block of strokes.

We extend the notion of a standard tape to lists of numerals as well.
\<close>

definition std_tap :: "tape \<Rightarrow> bool"
  where
    "std_tap tap  \<equiv> (\<exists>k n l. tap = (Bk \<up> k,  <n::nat> @ Bk \<up> l))"

definition std_tap_list :: "tape \<Rightarrow> bool"
  where
    "std_tap_list tap  \<equiv> (\<exists>k ml l. tap = (Bk \<up> k,  <ml::nat list> @ Bk \<up> l))"

lemma "std_tap tap \<Longrightarrow> std_tap_list tap"
  unfolding std_tap_def std_tap_list_def
  by (metis tape_of_list_def tape_of_nat_list.simps(2))

text \<open>A configuration @{term "(st, l, r)"} of a Turing machine is called a {\em standard configuration},
 if the state  @{term "st"} is the final state $0$ and the @{term "(l, r)"} is a standard tape.
\<close>

(* A duplicate from UTM just for comparison of concepts *)

definition TSTD':: "config \<Rightarrow> bool"
  where
    "TSTD' c = ((let (st, l, r) = c in
             st = 0 \<and> (\<exists> m. l = Bk\<up>(m)) \<and> (\<exists> rs n. r = Oc\<up>(Suc rs) @ Bk\<up>(n))))"

(* Relate definition of TSTD' to std_tap *)

lemma "TSTD' (st, l, r) = ((st = 0) \<and> std_tap (l,r))"
  unfolding TSTD'_def std_tap_def
proof -
  have "(let (st, l, r) = (st, l, r) in st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>rs n. r = Oc \<up> Suc rs @ Bk \<up> n))
        = (st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>rs n. r = Oc \<up> Suc rs @ Bk \<up> n))"
    by auto
  also have "... = (st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>n la. r = (<n::nat> @ Bk \<up> la)))"
    by (auto simp add: tape_of_nat_def)
  finally have "(let (st, l, r) = (st, l, r) in st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>rs n. r = Oc \<up> Suc rs @ Bk \<up> n))
                = (st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>n la. r = (<n::nat> @ Bk \<up> la)))"
    by (auto simp add: tape_of_nat_def)
  moreover have "((\<exists>m. l = Bk \<up> m) \<and> (\<exists>n la. r = <n::nat> @ Bk \<up> la)) = (\<exists>k n la. (l, r) = (Bk \<up> k, <n::nat> @ Bk \<up> la))"
    by auto
  ultimately show "(let (st, l, r) = (st, l, r)
                    in  st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>rs n. r = Oc \<up> Suc rs @ Bk \<up> n))
                    =
                    (st = 0 \<and> (\<exists>k n la. (l, r) = (Bk \<up> k, <n::nat> @ Bk \<up> la)))"
    by blast
qed

subsection \<open>What does Hoare\_halt mean in general?\<close>

text \<open>We say {\em in general} because the result computed on the right tape is not necessarily a numeral but some arbitrary component @{term "r'"} . \<close>

lemma Hoare_halt2_iff:
"\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, r @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>
 \<longleftrightarrow>
 (\<forall>kl ll. \<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr)))"
proof
  assume "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, r @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
  then show "\<forall>kl ll. \<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
    by (smt Hoare_halt_def Pair_inject holds_for.elims(2) is_final.elims(2))
next
  assume "\<forall>kl ll. \<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
  then show "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, r @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
  unfolding Hoare_halt_def
  using holds_for.simps by fastforce
qed

lemma Hoare_halt_D:
  assumes "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, r @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
  shows "\<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
proof -
  from assms show "\<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
    by (simp add: Hoare_halt2_iff is_final_eq)
qed

lemma Hoare_halt_I2:
  assumes "\<And>kl ll. \<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
  shows "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, r @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
  unfolding Hoare_halt_def
  using assms holds_for.simps by fastforce

lemma Hoare_halt_D_Nil:
  assumes "\<lbrace>\<lambda>tap. tap = ([], r)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
  shows "\<exists>n. is_final (steps0 (1, ([], r)) p n) \<and> (\<exists>kr lr. steps0 (1, ([], r)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
proof -
  from assms have "\<lbrace>\<lambda>tap. tap = (Bk \<up> 0, r @ Bk \<up> 0)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
    by simp
  then have "\<exists>n. is_final (steps0 (1, (Bk \<up> 0, r @ Bk \<up> 0)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> 0, r @ Bk \<up> 0)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
    using Hoare_halt_E0 append_self_conv assms is_final_eq old.prod.inject prod.inject replicate_0
    by force
  then show ?thesis by auto
qed

lemma Hoare_halt_I2_Nil:
  assumes "\<exists>n. is_final (steps0 (1, ([], r )) p n) \<and> (\<exists>kr lr. steps0 (1, ([], r )) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
  shows "\<lbrace>\<lambda>tap. tap = ([], r)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
proof -
  from assms have "\<exists>n. is_final (steps0 (1, (Bk \<up> 0, r @ Bk \<up> 0)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> 0, r @ Bk \<up> 0)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
    by auto
  then have "\<lbrace>\<lambda>tap. tap = (Bk \<up> 0, r @ Bk \<up> 0)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
    using Hoare_halt_iff by auto
  then show ?thesis by auto
qed

lemma Hoare_halt2_Nil_iff:
  "\<lbrace>\<lambda>tap. tap = ([], r)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>
   \<longleftrightarrow>
   (\<exists>n. is_final (steps0 (1, ([], r)) p n) \<and> (\<exists>kr lr. steps0 (1, ([], r)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr)))"
  using Hoare_halt_D_Nil Hoare_halt_I2_Nil by blast

corollary Hoare_halt_left_tape_Nil_imp_All_left_and_right:
  assumes "\<lbrace>\<lambda>tap.       tap = ([]    , r         )\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k , r' @ Bk \<up> l)\<rbrace>"
  shows   "\<lbrace>\<lambda>tap. \<exists>x y. tap = (Bk \<up> x, r @ Bk \<up> y)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k , r' @ Bk \<up> l)\<rbrace>"
proof -
  from assms have "\<exists>n. is_final (steps0 (1, ([], r)) p n) \<and> (\<exists>k l. steps0 (1, ([], r)) p n = (0, Bk \<up> k,  r' @ Bk \<up> l))"
    using Hoare_halt_D_Nil by auto
  then have "\<And>x y. \<exists>n. is_final (steps0 (1, (Bk \<up> x, r @ Bk \<up> y)) p n) \<and> (\<exists>k l. steps0 (1, (Bk \<up> x, r @ Bk \<up> y)) p n = (0, Bk \<up> k,  r' @ Bk \<up> l))"
    using ex_steps_left_tape_Nil_imp_All_left_and_right
    using is_final.simps by force
  then show ?thesis using Hoare_halt_I2
    by auto
qed

subsubsection \<open>What does Hoare\_halt with a numeral list result mean?\<close>

text \<open>About computations that result in numeral lists on the final right tape.\<close>

(* Adding trailing blanks to the initial right tape needs tough lemmas (see BlanksDoNotMatter)  *)

lemma TMC_has_num_res_list_without_initial_Bks_imp_TMC_has_num_res_list_after_adding_Bks_to_initial_right_tape:
  " \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>
  \<Longrightarrow>
    \<lbrace>\<lambda>tap. \<exists>ll. tap = ([], <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
proof -
  assume A: "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
  then have "\<exists>n. is_final (steps0 (1, ([], <ns::nat list>)) p n) \<and>
                 (\<exists>ms kr lr. steps0 (1, ([], <ns::nat list>)) p n = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr))"
    using Hoare_halt_E0 is_finalI by force
  then obtain stp where
    w_stp: "is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and>
            (\<exists>ms kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr))"
    by blast

  then obtain ms where  "\<exists>kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)" by blast

  then have "\<forall>ll. \<exists>kr lr. steps0 (1, ([], <ns::nat list>@ Bk \<up> ll)) p stp = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)"
    using ex_steps_left_tape_Nil_imp_All_left_and_right steps_left_tape_ShrinkBkCtx_to_NIL by blast

  then have "\<forall>ll. is_final (steps0 (1, ([], <ns::nat list>@ Bk \<up> ll)) p stp) \<and>
                 (\<exists>ms kr lr. steps0 (1, ([], <ns::nat list>@ Bk \<up> ll)) p stp = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr))"
    by (metis is_finalI)

  then have "\<forall>tap. (\<exists>ll. tap = ([], <ns::nat list> @ Bk \<up> ll))
                    \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) p n) \<and>
                             (\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)) holds_for steps0 (1, tap) p n)"
    using holds_for.simps by force
  then show ?thesis
    unfolding Hoare_halt_def
    by auto
qed

(* Removing trailing blanks on the initial right tape (is easy) *)

lemma TMC_has_num_res_list_without_initial_Bks_iff_TMC_has_num_res_list_after_adding_Bks_to_initial_right_tape:
  "\<lbrace>\<lambda>tap.      tap = ([], <ns::nat list>)          \<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>
    \<longleftrightarrow>
   \<lbrace>\<lambda>tap. \<exists>ll. tap = ([], <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
proof
  assume "\<lbrace>\<lambda>tap.      tap = ([], <ns::nat list>)          \<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
  then show "\<lbrace>\<lambda>tap. \<exists>ll. tap = ([], <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
  using  TMC_has_num_res_list_without_initial_Bks_imp_TMC_has_num_res_list_after_adding_Bks_to_initial_right_tape by blast
next
  assume "\<lbrace>\<lambda>tap. \<exists>ll. tap = ([], <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
  then show "\<lbrace>\<lambda>tap.      tap = ([], <ns::nat list>)          \<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
    by (simp add: Hoare_halt_def assert_imp_def)
qed

(* In addition we may add or remove blanks on the initial left tape *)

lemma TMC_has_num_res_list_without_initial_Bks_imp_TMC_has_num_res_list_after_adding_Bks_to_initial_left_and_right_tape:
  " \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap.\<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>
  \<Longrightarrow>
    \<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
  using Hoare_halt_left_tape_Nil_imp_All_left_and_right by auto

(*
proof -
  assume A: "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap.\<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"

  then have "\<exists>stp. is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and>
                   (\<exists> kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr,  <ms::nat list> @ Bk \<up> lr))"
    using Hoare_halt2_Nil_iff tape_of_list_def tape_of_nat_list.simps(2)  by blast

  then obtain stp where
    w_stp: "is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and>
                   (\<exists> kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr,  <ms::nat list> @ Bk \<up> lr))"
    by blast

  then have "\<forall>kl ll.\<exists>kr lr. steps0 (1, Bk \<up> kl, <ns::nat list> @ Bk \<up> ll) p stp = (0, Bk \<up> kr,  <ms::nat list> @ Bk \<up> lr)"
    using ex_steps_left_tape_Nil_imp_All_left_and_right steps_left_tape_ShrinkBkCtx_to_NIL by blast

  then have "\<forall>kl ll. is_final (steps0 (1, Bk \<up> kl, <ns::nat list> @ Bk \<up> ll) p stp) \<and>
                  (\<exists>kr lr. steps0 (1, Bk \<up> kl , <ns::nat list> @ Bk \<up> ll) p stp = (0, Bk \<up> kr,  <ms::nat list> @ Bk \<up> lr))"
    by (metis is_finalI)

  then have "\<forall>tap. (\<exists>kl ll. tap = (Bk \<up> kl, <ns::nat list> @ Bk \<up> ll) )
                    \<longrightarrow> (\<exists>stp. is_final (steps0 (1, tap) p stp) \<and>
                  (\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr,  <ms::nat list> @ Bk \<up> lr)) holds_for steps0 (1, tap) p stp)"
    using holds_for.simps by force
  then show ?thesis
    unfolding Hoare_halt_def
    by auto
qed
*)

lemma TMC_has_num_res_list_without_initial_Bks_iff_TMC_has_num_res_list_after_adding_Bks_to_initial_left_and_right_tape:
  " \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap.\<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>
  \<longleftrightarrow>
    \<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
proof
  assume "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap.\<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
  then show "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
    using TMC_has_num_res_list_without_initial_Bks_imp_TMC_has_num_res_list_after_adding_Bks_to_initial_left_and_right_tape by auto
next
  assume "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
  then show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap.\<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
    by (simp add: Hoare_halt_def assert_imp_def)
qed

subsection \<open>Halting in a Standard Configuration\<close>

subsubsection \<open>Definition of Halting in a Standard Configuration\<close>

text \<open>The predicates \<open>TMC_has_num_res p ns\<close> and \<open>TMC_has_num_list_res\<close> describe that
 a run of the Turing program \<open>p\<close> on input \<open>ns\<close> reaches the final state 0
 and the final tape produced thereby is standard.
 Thus, the computation of the Turing machine \<open>p\<close> produced a result, which is
 either a single numeral or a list of numerals.

Since trailing blanks on the initial left or right tape do not matter,
we may restrict our definitions to the case where
 the initial left tape is empty and
 there are no trailing blanks on the initial right tape!
\<close>

definition TMC_has_num_res :: "tprog0 \<Rightarrow> nat list \<Rightarrow> bool"
  where
    "TMC_has_num_res p ns \<equiv>
     \<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"

lemma TMC_has_num_res_iff: "TMC_has_num_res p ns
         \<longleftrightarrow>
       (\<exists>stp. is_final (steps0 (1, [],<ns::nat list>) p stp) \<and>
              (\<exists>k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)))"
  unfolding TMC_has_num_res_def
proof
  assume "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
  then show "\<exists>stp. is_final (steps0 (1, [], <ns::nat list>) p stp) \<and> (\<exists>k n l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
    by (smt Hoare_halt_def holds_for.elims(2) is_final.elims(2) is_final_eq)
next
  assume "\<exists>stp. is_final (steps0 (1, [], <ns::nat list>) p stp) \<and> (\<exists>k n l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
  then show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
    by (metis (mono_tags, lifting) Hoare_halt_def holds_for.simps)
qed

(* for clarification
lemma TMC_has_num_res_iff': "TMC_has_num_res p ns \<equiv>
       (\<exists>stp k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
  by (smt TMC_has_num_res_iff is_finalI steps_0 steps_add)
*)

(* --- *)

definition TMC_has_num_list_res :: "tprog0 \<Rightarrow> nat list \<Rightarrow> bool"
  where
    "TMC_has_num_list_res p ns \<equiv>
     \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr ms lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"

lemma TMC_has_num_list_res_iff: "TMC_has_num_list_res p ns
         \<longleftrightarrow>
       (\<exists>stp. is_final (steps0 (1, [],<ns::nat list>) p stp) \<and>
              (\<exists>k ms l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk \<up> l)))"
  unfolding TMC_has_num_list_res_def
proof
  assume "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k ms l. tap = (Bk \<up> k, <ms::nat list> @ Bk \<up> l)\<rbrace>"
  then show "\<exists>stp. is_final (steps0 (1, [], <ns::nat list>) p stp) \<and> (\<exists>k ms l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk \<up> l))"
    by (smt Hoare_halt_def holds_for.elims(2) is_final.elims(2) is_final_eq)
next
  assume "\<exists>stp. is_final (steps0 (1, [], <ns::nat list>) p stp) \<and> (\<exists>k ms l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk \<up> l))"
  then show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k ms l.   tap = (Bk \<up> k, <ms::nat list> @ Bk \<up> l)\<rbrace>"
    by (metis (mono_tags, lifting) Hoare_halt_def holds_for.simps)
qed

(* for clarification
lemma TMC_has_num_list_res_iff': "TMC_has_num_list_res p ns \<equiv>
        (\<exists>stp k ms l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk \<up> l))"
  by (smt TMC_has_num_list_res_iff is_finalI steps_0 steps_add)
*)

subsubsection \<open>Relation between TMC\_has\_num\_res and TMC\_has\_num\_list\_res\<close>

text \<open>A computation of a Turing machine, which started on a list of numerals and halts in a
 standard configuration with a single numeral result is a special case of a halt in a standard configuration that
halts with a list of numerals.\<close>

(* FABR: this is an important lemma, since it motivates and validates our extension
 * of various concepts to lists of natural numbers or numerals
 *)

theorem TMC_has_num_res_imp_TMC_has_num_list_res:
  "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>
   \<Longrightarrow>
   \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr ms lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
proof -
  assume A: "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"

  then have "\<exists>stp. is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and>
                 (\<exists>n kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <n::nat> @ Bk \<up> lr))"
    by (smt Hoare_halt_def holds_for.elims(2) is_final.elims(2) is_final_eq)
  then obtain stp where
    w_stp: "is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and>
                 (\<exists>n kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <n::nat> @ Bk \<up> lr))"
    by blast

  then have "(\<exists>n kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <n::nat> @ Bk \<up> lr))"
    by auto

  then obtain n kr lr where "steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <n::nat> @ Bk \<up> lr)"
    by blast
  then have "steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <[n::nat]> @ Bk \<up> lr)"
    by (simp add: tape_of_list_def)
  then have "is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and> (\<exists>kr lr. (steps0 (1, ([], <ns::nat list>)) p stp) = (0, Bk \<up> kr, <[n::nat]> @ Bk \<up> lr))"
    by (simp add: is_final_eq)

  then have "is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and> (\<exists>ms kr lr. (steps0 (1, ([], <ns::nat list>)) p stp) = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr))"
    by blast

  then show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr ms lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
    by (metis (mono_tags, lifting) Hoare_halt_def  holds_for.simps)
qed

corollary TMC_has_num_res_imp_TMC_has_num_list_res': "TMC_has_num_res p ns \<Longrightarrow> TMC_has_num_list_res p ns"
  unfolding TMC_has_num_res_def TMC_has_num_list_res_def
  using TMC_has_num_res_imp_TMC_has_num_list_res
  by auto

subsubsection \<open>Convenience Lemmas for Halting Problems \<close>

lemma Hoare_halt_with_Oc_imp_std_tap:
  assumes "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
  shows "TMC_has_num_res p ns"
  unfolding TMC_has_num_res_def
proof -
  from assms have F0: "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>"
    by (auto simp add: tape_of_nat_def)
  show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
  by (smt F0 Hoare_halt_E0 Hoare_halt_I0)
qed

lemma Hoare_halt_with_OcOc_imp_std_tap:
  assumes "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
  shows "TMC_has_num_res p ns"
  unfolding TMC_has_num_res_def
proof -
  from assms have "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>"
    by (auto simp add: tape_of_nat_def)
  then show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
 by (smt Hoare_haltE Hoare_haltI holds_for.elims(2) holds_for.simps)
qed

subsubsection \<open>Hoare\_halt on numeral lists with single numeral result\<close>
(* For automation we use Hoare triples directly instead of the concept TMC_has_num_res.
 * Reason: reduce number of theorems used by the simplifier.
 *)

lemma Hoare_halt_on_numeral_imp_result: (* special case of Hoare_halt_D *)
  assumes "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)))\<rbrace>"
  shows "\<exists>stp k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk\<up> l)"
  using TMC_has_num_res_def TMC_has_num_res_iff assms by blast

lemma Hoare_halt_on_numeral_imp_result_rev: (* special case of Hoare_halt_I2 *)
  assumes "\<exists>stp k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk\<up> l)"
  shows "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)))\<rbrace>"
  using TMC_has_num_res_def TMC_has_num_res_iff assms is_final_eq by force

lemma Hoare_halt_on_numeral_imp_result_iff: (* special case of Hoare_halt2_iff *)
"\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)))\<rbrace>
 \<longleftrightarrow>
 (\<exists>stp k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk\<up> l))"
  using Hoare_halt_on_numeral_imp_result Hoare_halt_on_numeral_imp_result_rev by blast

subsubsection \<open>Hoare\_halt on numeral lists with numeral list result\<close>
(* For automation we use Hoare triples directly instead of the concept TMC_has_num_list_res.
 * Reason: reduce number of theorems used by the simplifier.
 *)

lemma Hoare_halt_on_numeral_imp_list_result: (* special case of Hoare_halt_D *)
  assumes "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k ms l. tap = (Bk \<up> k, <ms::nat list> @ Bk \<up> l)))\<rbrace>"
  shows "\<exists>stp k ms l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk\<up> l)"
  using TMC_has_num_list_res_def TMC_has_num_list_res_iff assms by blast

lemma Hoare_halt_on_numeral_imp_list_result_rev: (* special case of Hoare_halt_I2 *)
  assumes "\<exists>stp k ms l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk\<up> l)"
  shows "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k ms l. tap = (Bk \<up> k, <ms::nat list> @ Bk \<up> l)))\<rbrace>"
  by (metis (mono_tags, lifting) Hoare_haltI assms holds_for.simps is_finalI)

lemma Hoare_halt_on_numeral_imp_list_result_iff: (* special case of Hoare_halt2_iff *)
  "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k ms l. tap = (Bk \<up> k, <ms::nat list> @ Bk \<up> l)))\<rbrace>
   \<longleftrightarrow>
   (\<exists>stp k ms l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk\<up> l))"
  using Hoare_halt_on_numeral_imp_list_result Hoare_halt_on_numeral_imp_list_result_rev by blast

subsection \<open>Trailing left blanks do not matter for computations with result\<close>

(* adding trailing blanks on the initial left tape needs tough lemmas (see BlanksDoNotMatter)  *)

lemma TMC_has_num_res_NIL_impl_TMC_has_num_res_with_left_BKs:
  "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>
   \<Longrightarrow>
   \<lbrace>(\<lambda>tap. \<exists>z. tap = (Bk\<up>z, <ns>))\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
proof -
  assume   "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
  then have "\<exists>stp k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk\<up> l)"
    by (rule Hoare_halt_on_numeral_imp_result)

  then obtain n where "\<exists>stp k l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk\<up> l)" by blast

  then have "\<forall>z. \<exists>stp k l. (steps0 (1, (Bk\<up>z, <ns::nat list>)) p stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
    by (rule ex_steps_left_tape_Nil_imp_All)

  then have "\<lbrace>(\<lambda>tap. \<exists>z. tap = (Bk\<up>z, <ns::nat list>))\<rbrace> p \<lbrace> (\<lambda>tap. (\<exists>k l. tap = (Bk \<up> k,  <n::nat> @ Bk \<up> l))) \<rbrace>"
    by (rule Hoare_halt_add_Bks_left_tape_L2)

  then show "\<lbrace>\<lambda>tap. \<exists>z. tap = (Bk \<up> z, <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
    using Hoare_halt_iff \<open>\<forall>z. \<exists>stp k l. steps0 (1, Bk \<up> z, <ns>) p stp = (0, Bk \<up> k, <n> @ Bk \<up> l)\<close> by fastforce
qed

(* removing trailing blanks on the initial left tape (is easy) *)

corollary TMC_has_num_res_NIL_iff_TMC_has_num_res_with_left_BKs:
  " \<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>
    \<longleftrightarrow>
    \<lbrace>(\<lambda>tap. \<exists>z. tap = (Bk\<up>z, <ns>))\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
proof
  assume "\<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
  then show "\<lbrace>\<lambda>tap. \<exists>z. tap = (Bk \<up> z, <ns>)\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
    using TMC_has_num_res_NIL_impl_TMC_has_num_res_with_left_BKs by blast
next
  assume "\<lbrace>\<lambda>tap. \<exists>z. tap = (Bk \<up> z, <ns>)\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
  then show "\<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
    by (simp add: Hoare_halt_def assert_imp_def)
qed

subsection \<open>About Turing Computations and the result they yield\<close>

definition TMC_yields_num_res :: "tprog0 \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool"
  where "TMC_yields_num_res tm ns n \<equiv> (\<exists>stp k l. (steps0 (1, ([], <ns::nat list>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"

definition TMC_yields_num_list_res :: "tprog0 \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> bool"
  where "TMC_yields_num_list_res tm ns ms \<equiv> (\<exists>stp k l. (steps0 (1, ([], <ns::nat list>)) tm stp) = (0, Bk \<up> k, <ms::nat list> @ Bk \<up> l))"

(* This is for documentation and explanation: TMC_yields_num_res_unfolded_into_Hoare_halt *)
lemma TMC_yields_num_res_unfolded_into_Hoare_halt:
  "TMC_yields_num_res tm ns n \<equiv> \<lbrace>(\<lambda>tap. tap = ([], <ns>))\<rbrace> tm \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk\<up> l))\<rbrace>"
  by (smt Hoare_halt_iff TMC_yields_num_res_def)

(* This is for documentation and explanation: TMC_yields_num_list_res_unfolded_into_Hoare_halt *)
lemma TMC_yields_num_list_res_unfolded_into_Hoare_halt:
  "TMC_yields_num_list_res tm ns ms \<equiv> \<lbrace>(\<lambda>tap. tap = ([], <ns>))\<rbrace> tm \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <ms::nat list> @ Bk\<up> l))\<rbrace>"
  by (smt Hoare_halt_iff TMC_yields_num_list_res_def)

(* A variant of rule Hoare_plus_halt using TMC_yields_num_list_res and TMC_yields_num_res *)
lemma TMC_yields_num_res_Hoare_plus_halt:
  assumes "TMC_yields_num_list_res tm1 nl r1"
    and "TMC_yields_num_res tm2 r1 r2"
    and "composable_tm0 tm1"
  shows "TMC_yields_num_res (tm1 |+| tm2) nl r2"
proof -
  from assms
  have "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace> tm1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <r1::nat list> @ Bk \<up> l)\<rbrace>"
    using TMC_yields_num_list_res_unfolded_into_Hoare_halt
    by auto
  moreover from assms
  have "\<lbrace>\<lambda>tap. tap = ([], <r1>)\<rbrace> tm2 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <r2> @ Bk \<up> l)\<rbrace>"
    using TMC_yields_num_res_unfolded_into_Hoare_halt
      Hoare_halt_def Hoare_halt_iff TMC_yields_num_res_def by blast
  ultimately
  have "\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> (tm1 |+| tm2) \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <r2> @ Bk \<up> l)\<rbrace>"
    using \<open>composable_tm0 tm1\<close>
    using Hoare_halt_left_tape_Nil_imp_All_left_and_right Hoare_plus_halt
    by (simp add: tape_of_list_def)
  then show ?thesis
    using TMC_yields_num_res_unfolded_into_Hoare_halt by auto
qed

(*

 TODO test mixfix notation for TMC_yields_num_res:  \<llangle>tm: ns \<mapsto> n\<rrangle>
 TODO test mixfix notation for TMC_has_num_res:     \<llangle>tm: ns\<down>\<rrangle>

    Trial for notation of TMC_yields_num_res tm ns n:

      "TMC_yields_num_res tm ns n \<equiv> (\<exists>stp k l. (steps0 (1, ([], <ns::nat list>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"

         ns \<midarrow><tm>\<rightarrow> n

         \<llangle>tm: ns \<leadsto> n\<rrangle>   that's good

         \<llangle>tm: ns \<mapsto> n\<rrangle>   that's good as well

     TMC_has_num_res

      "TMC_has_num_res p ns \<equiv> \<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"

         \<llangle>tm: ns\<down>\<rrangle>

 *)

end


(*  Title:      FOL/FOL.thy
    Author:     Lawrence C Paulson and Markus Wenzel
*)

section \<open>Classical first-order logic\<close>

theory FOL
imports IFOL
keywords "print_claset" "print_induct_rules" :: diag
begin

ML_file "~~/src/Provers/classical.ML"
ML_file "~~/src/Provers/blast.ML"
ML_file "~~/src/Provers/clasimp.ML"

subsection \<open>The classical axiom\<close>

axiomatization where
  classical: "(\<not> P \<Longrightarrow> P) \<Longrightarrow> P"

subsection \<open>Lemmas and proof tools\<close>

lemma ccontr: "(\<not> P \<Longrightarrow> False) \<Longrightarrow> P"
  by (erule FalseE [THEN classical])

subsubsection \<open>Classical introduction rules for \<open>\<or>\<close> and \<open>\<exists>\<close>\<close>

lemma disjCI: "(\<not> Q \<Longrightarrow> P) \<Longrightarrow> P \<or> Q"
  apply (rule classical)
  apply (assumption | erule meta_mp | rule disjI1 notI)+
  apply (erule notE disjI2)+
  done

text \<open>Introduction rule involving only \<open>\<exists>\<close>\<close>
lemma ex_classical:
  assumes r: "\<not> (\<exists>x. P(x)) \<Longrightarrow> P(a)"
  shows "\<exists>x. P(x)"
  apply (rule classical)
  apply (rule exI, erule r)
  done

text \<open>Version of above, simplifying \<open>\<not>\<exists>\<close> to \<open>\<forall>\<not>\<close>.\<close>
lemma exCI:
  assumes r: "\<forall>x. \<not> P(x) \<Longrightarrow> P(a)"
  shows "\<exists>x. P(x)"
  apply (rule ex_classical)
  apply (rule notI [THEN allI, THEN r])
  apply (erule notE)
  apply (erule exI)
  done

lemma excluded_middle: "\<not> P \<or> P"
  apply (rule disjCI)
  apply assumption
  done

lemma case_split [case_names True False]:
  assumes r1: "P \<Longrightarrow> Q"
    and r2: "\<not> P \<Longrightarrow> Q"
  shows Q
  apply (rule excluded_middle [THEN disjE])
  apply (erule r2)
  apply (erule r1)
  done

ML \<open>
  fun case_tac ctxt a fixes =
    Rule_Insts.res_inst_tac ctxt [((("P", 0), Position.none), a)] fixes @{thm case_split};
\<close>

method_setup case_tac = \<open>
  Args.goal_spec -- Scan.lift (Args.embedded_inner_syntax -- Parse.for_fixes) >>
    (fn (quant, (s, fixes)) => fn ctxt => SIMPLE_METHOD'' quant (case_tac ctxt s fixes))
\<close> "case_tac emulation (dynamic instantiation!)"

subsection \<open>Special elimination rules\<close>

text \<open>Classical implies (\<open>\<longrightarrow>\<close>) elimination.\<close>
lemma impCE:
  assumes major: "P \<longrightarrow> Q"
    and r1: "\<not> P \<Longrightarrow> R"
    and r2: "Q \<Longrightarrow> R"
  shows R
  apply (rule excluded_middle [THEN disjE])
   apply (erule r1)
  apply (rule r2)
  apply (erule major [THEN mp])
  done

text \<open>
  This version of \<open>\<longrightarrow>\<close> elimination works on \<open>Q\<close> before \<open>P\<close>. It works best for those cases in which P holds ``almost everywhere''.
  Can't install as default: would break old proofs.
\<close>
lemma impCE':
  assumes major: "P \<longrightarrow> Q"
    and r1: "Q \<Longrightarrow> R"
    and r2: "\<not> P \<Longrightarrow> R"
  shows R
  apply (rule excluded_middle [THEN disjE])
   apply (erule r2)
  apply (rule r1)
  apply (erule major [THEN mp])
  done

text \<open>Double negation law.\<close>
lemma notnotD: "\<not> \<not> P \<Longrightarrow> P"
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma contrapos2:  "\<lbrakk>Q; \<not> P \<Longrightarrow> \<not> Q\<rbrakk> \<Longrightarrow> P"
  apply (rule classical)
  apply (drule (1) meta_mp)
  apply (erule (1) notE)
  done

subsubsection \<open>Tactics for implication and contradiction\<close>

text \<open>
  Classical \<open>\<longleftrightarrow>\<close> elimination. Proof substitutes \<open>P = Q\<close> in
  \<open>\<not> P \<Longrightarrow> \<not> Q\<close> and \<open>P \<Longrightarrow> Q\<close>.
\<close>
lemma iffCE:
  assumes major: "P \<longleftrightarrow> Q"
    and r1: "\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R"
    and r2: "\<lbrakk>\<not> P; \<not> Q\<rbrakk> \<Longrightarrow> R"
  shows R
  apply (rule major [unfolded iff_def, THEN conjE])
  apply (elim impCE)
     apply (erule (1) r2)
    apply (erule (1) notE)+
  apply (erule (1) r1)
  done

(*Better for fast_tac: needs no quantifier duplication!*)
lemma alt_ex1E:
  assumes major: "\<exists>! x. P(x)"
    and r: "\<And>x. \<lbrakk>P(x);  \<forall>y y'. P(y) \<and> P(y') \<longrightarrow> y = y'\<rbrakk> \<Longrightarrow> R"
  shows R
  using major
proof (rule ex1E)
  fix x
  assume * : "\<forall>y. P(y) \<longrightarrow> y = x"
  assume "P(x)"
  then show R
  proof (rule r)
    {
      fix y y'
      assume "P(y)" and "P(y')"
      with * have "x = y" and "x = y'"
        by - (tactic "IntPr.fast_tac @{context} 1")+
      then have "y = y'" by (rule subst)
    } note r' = this
    show "\<forall>y y'. P(y) \<and> P(y') \<longrightarrow> y = y'"
      by (intro strip, elim conjE) (rule r')
  qed
qed

lemma imp_elim: "P \<longrightarrow> Q \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R"
  by (rule classical) iprover

lemma swap: "\<not> P \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> R"
  by (rule classical) iprover

section \<open>Classical Reasoner\<close>

ML \<open>
structure Cla = Classical
(
  val imp_elim = @{thm imp_elim}
  val not_elim = @{thm notE}
  val swap = @{thm swap}
  val classical = @{thm classical}
  val sizef = size_of_thm
  val hyp_subst_tacs = [hyp_subst_tac]
);

structure Basic_Classical: BASIC_CLASSICAL = Cla;
open Basic_Classical;
\<close>

(*Propositional rules*)
lemmas [intro!] = refl TrueI conjI disjCI impI notI iffI
  and [elim!] = conjE disjE impCE FalseE iffCE
ML \<open>val prop_cs = claset_of @{context}\<close>

(*Quantifier rules*)
lemmas [intro!] = allI ex_ex1I
  and [intro] = exI
  and [elim!] = exE alt_ex1E
  and [elim] = allE
ML \<open>val FOL_cs = claset_of @{context}\<close>

ML \<open>
  structure Blast = Blast
  (
    structure Classical = Cla
    val Trueprop_const = dest_Const @{const Trueprop}
    val equality_name = @{const_name eq}
    val not_name = @{const_name Not}
    val notE = @{thm notE}
    val ccontr = @{thm ccontr}
    val hyp_subst_tac = Hypsubst.blast_hyp_subst_tac
  );
  val blast_tac = Blast.blast_tac;
\<close>

lemma ex1_functional: "\<lbrakk>\<exists>! z. P(a,z); P(a,b); P(a,c)\<rbrakk> \<Longrightarrow> b = c"
  by blast

text \<open>Elimination of \<open>True\<close> from assumptions:\<close>
lemma True_implies_equals: "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
proof
  assume "True \<Longrightarrow> PROP P"
  from this and TrueI show "PROP P" .
next
  assume "PROP P"
  then show "PROP P" .
qed

lemma uncurry: "P \<longrightarrow> Q \<longrightarrow> R \<Longrightarrow> P \<and> Q \<longrightarrow> R"
  by blast

lemma iff_allI: "(\<And>x. P(x) \<longleftrightarrow> Q(x)) \<Longrightarrow> (\<forall>x. P(x)) \<longleftrightarrow> (\<forall>x. Q(x))"
  by blast

lemma iff_exI: "(\<And>x. P(x) \<longleftrightarrow> Q(x)) \<Longrightarrow> (\<exists>x. P(x)) \<longleftrightarrow> (\<exists>x. Q(x))"
  by blast

lemma all_comm: "(\<forall>x y. P(x,y)) \<longleftrightarrow> (\<forall>y x. P(x,y))"
  by blast

lemma ex_comm: "(\<exists>x y. P(x,y)) \<longleftrightarrow> (\<exists>y x. P(x,y))"
  by blast

subsection \<open>Classical simplification rules\<close>

text \<open>
  Avoids duplication of subgoals after \<open>expand_if\<close>, when the true and
  false cases boil down to the same thing.
\<close>

lemma cases_simp: "(P \<longrightarrow> Q) \<and> (\<not> P \<longrightarrow> Q) \<longleftrightarrow> Q"
  by blast

subsubsection \<open>Miniscoping: pushing quantifiers in\<close>

text \<open>
  We do NOT distribute of \<open>\<forall>\<close> over \<open>\<and>\<close>, or dually that of
  \<open>\<exists>\<close> over \<open>\<or>\<close>.

  Baaz and Leitsch, On Skolemization and Proof Complexity (1994) show that
  this step can increase proof length!
\<close>

text \<open>Existential miniscoping.\<close>
lemma int_ex_simps:
  "\<And>P Q. (\<exists>x. P(x) \<and> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<and> Q"
  "\<And>P Q. (\<exists>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<exists>x. Q(x))"
  "\<And>P Q. (\<exists>x. P(x) \<or> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<or> Q"
  "\<And>P Q. (\<exists>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<exists>x. Q(x))"
  by iprover+

text \<open>Classical rules.\<close>
lemma cla_ex_simps:
  "\<And>P Q. (\<exists>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<longrightarrow> Q"
  "\<And>P Q. (\<exists>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> P \<longrightarrow> (\<exists>x. Q(x))"
  by blast+

lemmas ex_simps = int_ex_simps cla_ex_simps

text \<open>Universal miniscoping.\<close>
lemma int_all_simps:
  "\<And>P Q. (\<forall>x. P(x) \<and> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<and> Q"
  "\<And>P Q. (\<forall>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<forall>x. Q(x))"
  "\<And>P Q. (\<forall>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<exists> x. P(x)) \<longrightarrow> Q"
  "\<And>P Q. (\<forall>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> P \<longrightarrow> (\<forall>x. Q(x))"
  by iprover+

text \<open>Classical rules.\<close>
lemma cla_all_simps:
  "\<And>P Q. (\<forall>x. P(x) \<or> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<or> Q"
  "\<And>P Q. (\<forall>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<forall>x. Q(x))"
  by blast+

lemmas all_simps = int_all_simps cla_all_simps

subsubsection \<open>Named rewrite rules proved for IFOL\<close>

lemma imp_disj1: "(P \<longrightarrow> Q) \<or> R \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)" by blast
lemma imp_disj2: "Q \<or> (P \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)" by blast

lemma de_Morgan_conj: "(\<not> (P \<and> Q)) \<longleftrightarrow> (\<not> P \<or> \<not> Q)" by blast

lemma not_imp: "\<not> (P \<longrightarrow> Q) \<longleftrightarrow> (P \<and> \<not> Q)" by blast
lemma not_iff: "\<not> (P \<longleftrightarrow> Q) \<longleftrightarrow> (P \<longleftrightarrow> \<not> Q)" by blast

lemma not_all: "(\<not> (\<forall>x. P(x))) \<longleftrightarrow> (\<exists>x. \<not> P(x))" by blast
lemma imp_all: "((\<forall>x. P(x)) \<longrightarrow> Q) \<longleftrightarrow> (\<exists>x. P(x) \<longrightarrow> Q)" by blast

lemmas meta_simps =
  triv_forall_equality  \<comment> \<open>prunes params\<close>
  True_implies_equals  \<comment> \<open>prune asms \<open>True\<close>\<close>

lemmas IFOL_simps =
  refl [THEN P_iff_T] conj_simps disj_simps not_simps
  imp_simps iff_simps quant_simps

lemma notFalseI: "\<not> False" by iprover

lemma cla_simps_misc:
  "\<not> (P \<and> Q) \<longleftrightarrow> \<not> P \<or> \<not> Q"
  "P \<or> \<not> P"
  "\<not> P \<or> P"
  "\<not> \<not> P \<longleftrightarrow> P"
  "(\<not> P \<longrightarrow> P) \<longleftrightarrow> P"
  "(\<not> P \<longleftrightarrow> \<not> Q) \<longleftrightarrow> (P \<longleftrightarrow> Q)" by blast+

lemmas cla_simps =
  de_Morgan_conj de_Morgan_disj imp_disj1 imp_disj2
  not_imp not_all not_ex cases_simp cla_simps_misc

ML_file "simpdata.ML"

simproc_setup defined_Ex ("\<exists>x. P(x)") = \<open>fn _ => Quantifier1.rearrange_ex\<close>
simproc_setup defined_All ("\<forall>x. P(x)") = \<open>fn _ => Quantifier1.rearrange_all\<close>

ML \<open>
(*intuitionistic simprules only*)
val IFOL_ss =
  put_simpset FOL_basic_ss @{context}
  addsimps @{thms meta_simps IFOL_simps int_ex_simps int_all_simps}
  addsimprocs [@{simproc defined_All}, @{simproc defined_Ex}]
  |> Simplifier.add_cong @{thm imp_cong}
  |> simpset_of;

(*classical simprules too*)
val FOL_ss =
  put_simpset IFOL_ss @{context}
  addsimps @{thms cla_simps cla_ex_simps cla_all_simps}
  |> simpset_of;
\<close>

setup \<open>
  map_theory_simpset (put_simpset FOL_ss) #>
  Simplifier.method_setup Splitter.split_modifiers
\<close>

ML_file "~~/src/Tools/eqsubst.ML"

subsection \<open>Other simple lemmas\<close>

lemma [simp]: "((P \<longrightarrow> Q) \<longleftrightarrow> (P \<longrightarrow> R)) \<longleftrightarrow> (P \<longrightarrow> (Q \<longleftrightarrow> R))"
  by blast

lemma not_disj_iff_imp: "\<not> P \<or> Q \<longleftrightarrow> (P \<longrightarrow> Q)"
  by blast

subsubsection \<open>Monotonicity of implications\<close>

lemma conj_mono: "\<lbrakk>P1 \<longrightarrow> Q1; P2 \<longrightarrow> Q2\<rbrakk> \<Longrightarrow> (P1 \<and> P2) \<longrightarrow> (Q1 \<and> Q2)"
  by fast (*or (IntPr.fast_tac 1)*)

lemma disj_mono: "\<lbrakk>P1 \<longrightarrow> Q1; P2 \<longrightarrow> Q2\<rbrakk> \<Longrightarrow> (P1 \<or> P2) \<longrightarrow> (Q1 \<or> Q2)"
  by fast (*or (IntPr.fast_tac 1)*)

lemma imp_mono: "\<lbrakk>Q1 \<longrightarrow> P1; P2 \<longrightarrow> Q2\<rbrakk> \<Longrightarrow> (P1 \<longrightarrow> P2) \<longrightarrow> (Q1 \<longrightarrow> Q2)"
  by fast (*or (IntPr.fast_tac 1)*)

lemma imp_refl: "P \<longrightarrow> P"
  by (rule impI)

text \<open>The quantifier monotonicity rules are also intuitionistically valid.\<close>
lemma ex_mono: "(\<And>x. P(x) \<longrightarrow> Q(x)) \<Longrightarrow> (\<exists>x. P(x)) \<longrightarrow> (\<exists>x. Q(x))"
  by blast

lemma all_mono: "(\<And>x. P(x) \<longrightarrow> Q(x)) \<Longrightarrow> (\<forall>x. P(x)) \<longrightarrow> (\<forall>x. Q(x))"
  by blast

subsection \<open>Proof by cases and induction\<close>

text \<open>Proper handling of non-atomic rule statements.\<close>

context
begin

qualified definition "induct_forall(P) \<equiv> \<forall>x. P(x)"
qualified definition "induct_implies(A, B) \<equiv> A \<longrightarrow> B"
qualified definition "induct_equal(x, y) \<equiv> x = y"
qualified definition "induct_conj(A, B) \<equiv> A \<and> B"

lemma induct_forall_eq: "(\<And>x. P(x)) \<equiv> Trueprop(induct_forall(\<lambda>x. P(x)))"
  unfolding atomize_all induct_forall_def .

lemma induct_implies_eq: "(A \<Longrightarrow> B) \<equiv> Trueprop(induct_implies(A, B))"
  unfolding atomize_imp induct_implies_def .

lemma induct_equal_eq: "(x \<equiv> y) \<equiv> Trueprop(induct_equal(x, y))"
  unfolding atomize_eq induct_equal_def .

lemma induct_conj_eq: "(A &&& B) \<equiv> Trueprop(induct_conj(A, B))"
  unfolding atomize_conj induct_conj_def .

lemmas induct_atomize = induct_forall_eq induct_implies_eq induct_equal_eq induct_conj_eq
lemmas induct_rulify [symmetric] = induct_atomize
lemmas induct_rulify_fallback =
  induct_forall_def induct_implies_def induct_equal_def induct_conj_def

text \<open>Method setup.\<close>

ML_file "~~/src/Tools/induct.ML"
ML \<open>
  structure Induct = Induct
  (
    val cases_default = @{thm case_split}
    val atomize = @{thms induct_atomize}
    val rulify = @{thms induct_rulify}
    val rulify_fallback = @{thms induct_rulify_fallback}
    val equal_def = @{thm induct_equal_def}
    fun dest_def _ = NONE
    fun trivial_tac _ _ = no_tac
  );
\<close>

declare case_split [cases type: o]

end

ML_file "~~/src/Tools/case_product.ML"

hide_const (open) eq

end