section \<open> Laws related to @{text "infsum"} \<close>

theory infsum_laws
  imports
    "HOL-Analysis.Infinite_Sum"
    "UTP2.utp" (* This is not necessary for this theory. The only reason for importing it here is
      because there is a syntax error without unbundle UTP_Syntax. For example, (0::\<nat>) cannot be
      correctly parsed. Please comment this line to see effect. This should be fixed. *)
    (* "utp_distribution" *)
begin
unbundle UTP_Syntax
(*
print_bundles
declare [[show_types]]
*)
subsection \<open> Useful lemmas \<close>
lemma finite_image_set2':
  assumes "finite A" "finite B"
  shows "finite {(a, b). a \<in> A \<and> b \<in> B}"
  apply (rule finite_subset [where B = "\<Union>x \<in> A. \<Union>y \<in> B. {(x,y)}"])
  apply auto
  using assms(1) assms(2) by blast

lemma finite_image_set2'':
  assumes "finite B" "\<forall>x. finite (A x)"
  shows "finite {(a, b). b \<in> B \<and> a \<in> A b}"
  apply (rule finite_subset [where B = "\<Union>y \<in> B. \<Union>x \<in> A y. {(x,y)}"])
  apply auto
  using assms(1) assms(2) by blast

lemma card_1_singleton:
  assumes "\<exists>!x. P x"
  shows "card {x. P x} = Suc (0::\<nat>)"
  using assms card_1_singleton_iff by fastforce

lemma card_0_singleton:
  assumes "\<not>(\<exists>x. P x)"
  shows "card {x. P x} = (0::\<nat>)"
  using assms by auto

lemma card_0_false:
  shows "card {x. False} = (0::\<real>)"
  by simp

lemma conditional_conds_conj:
  "\<forall>s. (if b\<^sub>1 s then (1::\<real>) else (0::\<real>)) * (if b\<^sub>2 s then (1::\<real>) else (0::\<real>)) =
    (if b\<^sub>1 s \<and> b\<^sub>2 s then 1 else 0)"
  apply (rule allI)
  by force

lemma conditional_conds_conj':
  "\<forall>s. (if b\<^sub>1 s then (m::\<real>) else (0::\<real>)) * (if b\<^sub>2 s then (p::\<real>) else (0::\<real>)) =
    (if b\<^sub>1 s \<and> b\<^sub>2 s then m * p else 0)"
  apply (rule allI)
  by simp

lemma conditional_cmult: "\<forall>s. (if b\<^sub>1 s then (m::\<real>) else (0::\<real>)) * c =
    ((if b\<^sub>1 s then (m::\<real>) * c else (0::\<real>)))"
  apply (rule allI)
  by force

lemma conditional_cmult_1: "\<forall>s. (if b\<^sub>1 s then (1::\<real>) else (0::\<real>)) * c =
    ((if b\<^sub>1 s then c else (0::\<real>)))"
  apply (rule allI)
  by force

subsection \<open> Laws of @{term infsum} \<close>
lemma infset_0_not_summable_or_sum_to_zero:
  assumes "infsum f A = 0"
  shows "(f summable_on A \<and> has_sum f A 0) \<or> \<not> f summable_on A"
  by (simp add: assms summable_iff_has_sum_infsum)

lemma infset_0_not_summable_or_zero:
  assumes "\<forall>s. f s \<ge> (0::\<real>)"
  assumes "infsum f A = 0"
  shows "(\<forall>s \<in> A. f s = 0) \<or> \<not> f summable_on A"
proof (rule ccontr)
  assume a1: "\<not> ((\<forall>s\<in>A. f s = (0)) \<or> \<not> f summable_on A)"
  then have f1: "(\<not> (\<forall>s\<in>A. f s = (0))) \<and> f summable_on A"
    by linarith
  then have "\<exists>x \<in> A. f x > 0"
    apply (simp add: Bex_def)
    apply (auto)
    apply (rule_tac x = "x" in exI)
    apply (simp)
    using assms(1) by (metis order_le_less)

  have ind_ge_0: "infsum f {(SOME x. x \<in>A \<and> f x > 0)} > 0"
    using a1 assms(1) assms(2) nonneg_infsum_le_0D by force

  have "infsum f {(SOME x. x \<in>A \<and> f x > 0)} \<le> infsum f A"
    apply (rule infsum_mono2)
    apply simp
    using f1 apply blast
    using a1 assms(1) assms(2) nonneg_infsum_le_0D apply force
    using assms(1) by blast
  then have "infsum f A > 0"
    using ind_ge_0 by linarith
  then show "False"
    using assms(2) by simp
qed

lemma has_sum_cdiv_left:
  fixes f :: "'a \<Rightarrow> \<real>"
  assumes \<open>has_sum f A a\<close>
  shows "has_sum (\<lambda>x. f x / c) A (a / c)"
  apply (simp only : divide_inverse)
  using assms has_sum_cmult_left by blast

lemma infsum_cdiv_left:
  fixes f :: "'a \<Rightarrow> \<real>"
  assumes \<open>c \<noteq> 0 \<Longrightarrow> f summable_on A\<close>
  shows "infsum (\<lambda>x. f x / c) A = infsum f A / c"
  apply (simp only : divide_inverse)
  using infsum_cmult_left' by blast

lemma summable_on_cdiv_left:
  fixes f :: "'a \<Rightarrow> \<real>"
  assumes \<open>f summable_on A\<close>
  shows "(\<lambda>x. f x / c) summable_on A"
  using assms summable_on_def has_sum_cdiv_left by blast

lemma summable_on_cdiv_left':
  fixes f :: "'a \<Rightarrow> \<real>"
  assumes \<open>c \<noteq> 0\<close>
  shows "(\<lambda>x. f x / c) summable_on A \<longleftrightarrow> f summable_on A"
  apply (simp only : divide_inverse)
  by (simp add: assms summable_on_cmult_left')

lemma not_summable_on_cdiv_left':
  fixes f :: "'a \<Rightarrow> \<real>"
  assumes \<open>c \<noteq> 0\<close>
  shows "\<not>(\<lambda>x. f x / c) summable_on A \<longleftrightarrow> \<not>f summable_on A"
  apply (simp only : divide_inverse)
  by (simp add: assms summable_on_cmult_left')

lemma summable_on_minus:
  fixes f g :: "'a \<Rightarrow> \<real>"
  assumes \<open>f summable_on A\<close>
  assumes \<open>g summable_on A\<close>
  shows \<open>(\<lambda>x. f x - g x) summable_on A\<close>
  apply (subst add_uminus_conv_diff[symmetric])
  apply (subst summable_on_add)
  using assms(1) apply blast
  by (simp add: assms(2) summable_on_uminus)+

lemma infsum_geq_element:
  fixes f :: "'a \<Rightarrow> \<real>"
  assumes "\<forall>s. f s \<ge> 0"
  assumes "f summable_on A"
  assumes "s \<in> A"
  shows "f s \<le> infsum f A"
proof -
  have f0: "infsum f (A - {s}) \<ge> 0"
    by (simp add: assms(1) infsum_nonneg)
  have f1: "infsum f A = infsum f ({s} \<union> (A - {s}))"
    using assms(3) insert_Diff by force
  also have f2: "... = infsum f {s} + infsum f (A - {s})"
    apply (subst infsum_Un_disjoint)
    apply (simp_all)
    by (simp add: assms(2) summable_on_cofin_subset)
  show ?thesis
    using f0 f1 f2 by auto
qed

lemma infsum_geq_element':
  fixes f :: "'a \<Rightarrow> \<real>"
  assumes "\<forall>s. f s \<ge> 0"
  assumes "f summable_on A"
  assumes "s \<in> A"
  assumes "infsum f A = x"
  shows "f s \<le> x"
  by (metis assms(1) assms(2) assms(3) assms(4) infsum_geq_element)

lemma infsum_on_singleton:
  "(\<Sum>\<^sub>\<infinity>s \<in> {x}. f s) = f x"
  apply (rule infsumI)
  apply (simp add: has_sum_def)
  apply (subst topological_tendstoI)
  apply (auto)
  apply (simp add: eventually_finite_subsets_at_top)
  apply (rule_tac x = "{x}" in exI)
  by (metis add.right_neutral finite.emptyI finite_insert insert_absorb insert_not_empty
      subset_antisym subset_singleton_iff sum.empty sum.insert)

lemma infsum_singleton:
  "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. (if c = v\<^sub>0 then (m::\<real>) else 0)) = m"
  apply (rule infsumI)
  apply (simp add: has_sum_def)
  apply (subst topological_tendstoI)
  apply (auto)
  apply (simp add: eventually_finite_subsets_at_top)
  apply (rule_tac x = "{c}" in exI)
  by (auto)

lemma infsum_singleton_summable:
  assumes "m \<noteq> 0"
  shows "(\<lambda>v\<^sub>0. (if c = v\<^sub>0 then (m::\<real>) else 0)) summable_on UNIV"
proof (rule ccontr)
  assume a1: "\<not> (\<lambda>v\<^sub>0::'a. if c = v\<^sub>0 then m else (0::\<real>)) summable_on UNIV"
  from a1 have "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. (if c = v\<^sub>0 then (m::\<real>) else 0)) = (0::\<real>)"
    by (simp add: infsum_def)
  then show "False"
    by (simp add: infsum_singleton assms)
qed

lemma infsum_singleton_1:
  "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. (if v\<^sub>0 = c then (m::\<real>) else 0)) = m"
  by (smt (verit, del_insts) infsum_cong infsum_singleton)

lemma infsum_cond_finite_states:
  assumes "finite {s. b s}"
  shows "(\<Sum>\<^sub>\<infinity>v\<^sub>0. (if b v\<^sub>0 then f v\<^sub>0 else (0::\<real>))) = (\<Sum>v\<^sub>0 \<in> {s. b s}. f v\<^sub>0)"
proof -
  have "(\<Sum>\<^sub>\<infinity>v\<^sub>0. (if b v\<^sub>0 then f v\<^sub>0 else 0)) = (\<Sum>\<^sub>\<infinity>v\<^sub>0 \<in> {s. b s} \<union> (-{s. b s}). (if b v\<^sub>0 then f v\<^sub>0 else 0))"
    by auto
  moreover have "... = (\<Sum>\<^sub>\<infinity>v\<^sub>0 \<in> {s. b s}. (if b v\<^sub>0 then f v\<^sub>0 else 0))"
    apply (subst infsum_Un_disjoint)
    apply (simp add: assms)
    apply (smt (verit, ccfv_threshold) ComplD mem_Collect_eq summable_on_0)
    apply simp
    by (smt (verit, best) ComplD infsum_0 mem_Collect_eq)
  moreover have "... = (\<Sum>v\<^sub>0 \<in> {s. b s}. f v\<^sub>0)"
    using assms by force
  ultimately show ?thesis
    by presburger
qed

lemma infsum_cond_finite_states_summable:
  assumes "finite {s. b s}"
  shows "(\<lambda>v\<^sub>0. (if b v\<^sub>0 then f v\<^sub>0 else (0::\<real>))) summable_on UNIV"
proof -
  have "((\<lambda>v\<^sub>0. (if b v\<^sub>0 then f v\<^sub>0 else (0::\<real>))) summable_on UNIV) =
      ((\<lambda>v\<^sub>0. (if b v\<^sub>0 then f v\<^sub>0 else (0::\<real>))) summable_on ({s. b s} \<union> -{s. b s}))"
    by auto
  moreover have "..."
    apply (rule summable_on_Un_disjoint)
    apply (simp add: assms)
    apply (smt (verit, ccfv_threshold) ComplD mem_Collect_eq summable_on_0)
    by simp
  ultimately show ?thesis
    by presburger
qed

lemma infsum_constant_finite_states:
  assumes "finite {s. b s}"
  shows "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. (if b v\<^sub>0 then (m::\<real>) else 0)) = m * card {s. b s}"
  apply (rule infsumI)
  apply (simp add: has_sum_def)
  apply (subst topological_tendstoI)
  apply (auto)
  apply (simp add: eventually_finite_subsets_at_top)
  apply (rule_tac x = "{v. b v}" in exI)
  apply (auto)
  using assms apply force
proof -
  fix S::"\<bbbP> \<real>" and Y::"\<bbbP> 'a"
  assume a1: "m * real (card (Collect b)) \<in> S"
  assume a2: "finite Y"
  assume a3: " {v::'a. b v} \<subseteq> Y"
  have "(\<Sum>v\<^sub>0::'a\<in>Y. if b v\<^sub>0 then m else (0::\<real>)) = (\<Sum>v\<^sub>0::'a\<in>{v::'a. b v}. if b v\<^sub>0 then m else (0::\<real>))"
    by (smt (verit, best) DiffD2 a2 a3 mem_Collect_eq sum.mono_neutral_cong_right)
  moreover have "... = m * card {s. b s}"
    by auto
  ultimately show "(\<Sum>v\<^sub>0::'a\<in>Y. if b v\<^sub>0 then m else (0::\<real>)) \<in> S"
    using a1 by presburger
qed

lemma infsum_constant_finite_states_summable:
  assumes "finite {s. b s}"
  shows "(\<lambda>v\<^sub>0::'a. (if b v\<^sub>0 then (m::\<real>) else 0)) summable_on UNIV"
  apply (simp add: summable_on_def)
  apply (rule_tac x = "m * card {s. b s}" in exI)
  apply (simp add: has_sum_def)
  apply (subst topological_tendstoI)
  apply (auto)
  apply (simp add: eventually_finite_subsets_at_top)
  apply (rule_tac x = "{v. b v}" in exI)
  apply (auto)
  using assms apply force
proof -
  fix S::"\<bbbP> \<real>" and Y::"\<bbbP> 'a"
  assume a1: "m * real (card (Collect b)) \<in> S"
  assume a2: "finite Y"
  assume a3: " {v::'a. b v} \<subseteq> Y"
  have "(\<Sum>v\<^sub>0::'a\<in>Y. if b v\<^sub>0 then m else (0::\<real>)) = (\<Sum>v\<^sub>0::'a\<in>{v::'a. b v}. if b v\<^sub>0 then m else (0::\<real>))"
    by (smt (verit, best) DiffD2 a2 a3 mem_Collect_eq sum.mono_neutral_cong_right)
  moreover have "... = m * card {s. b s}"
    by auto
  ultimately show "(\<Sum>v\<^sub>0::'a\<in>Y. if b v\<^sub>0 then m else (0::\<real>)) \<in> S"
    using a1 by presburger
qed

lemma infsum_constant_finite_states_subset:
  assumes "finite {s. b s \<and> s \<in> A}"
  shows "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a \<in> A. (if b v\<^sub>0 then (m::\<real>) else 0)) = m * card ({s. b s \<and> s \<in> A})"
proof -
  have "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a \<in> A. (if b v\<^sub>0 then (m::\<real>) else 0)) = (\<Sum>\<^sub>\<infinity>v\<^sub>0::'a \<in> {s. b s \<and> s \<in> A}. (m::\<real>))"
    apply (rule infsum_cong_neutral)
    apply simp
    apply auto[1]
    by simp
  then show ?thesis
    by simp
qed

lemma infsum_constant_finite_states_subset':
  assumes "finite {s. b s}"
  shows "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a \<in> A. (if b v\<^sub>0 then (m::\<real>) else 0)) = m * card ({s. b s \<and> s \<in> A})"
  apply (rule infsum_constant_finite_states_subset)
  using assms by force

lemma infsum_constant_finite_states_summable_2:
  assumes "finite {s. b\<^sub>1 s}" "finite {s. b\<^sub>2 s}"
  shows "(\<lambda>v\<^sub>0::'a. (if b\<^sub>1 v\<^sub>0 then (m::\<real>) else 0) +
          (if b\<^sub>2 v\<^sub>0 then (n::\<real>) else 0)) summable_on UNIV"
  apply (subst summable_on_add)
  apply (simp add: assms(1) infsum_constant_finite_states_summable)
  by (simp add: assms(2) infsum_constant_finite_states_summable)+

lemma infsum_constant_finite_states_summable_3:
  assumes "finite {s. b\<^sub>1 s}" "finite {s. b\<^sub>2 s}" "finite {s. b\<^sub>3 s}"
  shows "(\<lambda>v\<^sub>0::'a. (if b\<^sub>1 v\<^sub>0 then (m::\<real>) else 0) +
          (if b\<^sub>2 v\<^sub>0 then (n::\<real>) else 0) +
          (if b\<^sub>3 v\<^sub>0 then (p::\<real>) else 0)) summable_on UNIV"
  apply (subst summable_on_add)+
  apply (simp add: assms(1) infsum_constant_finite_states_summable)
  apply (simp add: assms(2) infsum_constant_finite_states_summable)+
  by (simp add: assms(3) infsum_constant_finite_states_summable)+

lemma infsum_constant_finite_states_summable_cmult_1:
  assumes "finite {s. b\<^sub>1 s}"
  shows "(\<lambda>v\<^sub>0::'a. (if b\<^sub>1 v\<^sub>0 then (m::\<real>) else 0) * c\<^sub>1) summable_on UNIV"
  apply (rule summable_on_cmult_left)
  by (simp add: assms(1) infsum_constant_finite_states_summable)

lemma infsum_constant_finite_states_cmult_1:
  assumes "finite {s. b\<^sub>1 s}"
  shows "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. (if b\<^sub>1 v\<^sub>0 then (m::\<real>) else 0) * c\<^sub>1) = m * card {s. b\<^sub>1 s} * c\<^sub>1"
  apply (subst infsum_cmult_left)
  using assms infsum_constant_finite_states_summable apply blast
  apply (subst infsum_constant_finite_states)
  using assms apply blast
  by auto

lemma infsum_constant_finite_states_summable_cmult_2:
  assumes "finite {s. b\<^sub>1 s}" "finite {s. b\<^sub>2 s}"
  shows "(\<lambda>v\<^sub>0::'a. (if b\<^sub>1 v\<^sub>0 then (m::\<real>) else 0) * c\<^sub>1 +
          (if b\<^sub>2 v\<^sub>0 then (n::\<real>) else 0) * c\<^sub>2
    ) summable_on UNIV"
  apply (subst summable_on_add)
  apply (rule summable_on_cmult_left)
  apply (simp add: assms(1) infsum_constant_finite_states_summable)
  apply (rule summable_on_cmult_left)
  by (simp add: assms(2) infsum_constant_finite_states_summable)+

lemma infsum_constant_finite_states_cmult_2:
  assumes "finite {s. b\<^sub>1 s}" "finite {s. b\<^sub>2 s}"
  shows "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a.
          (if b\<^sub>1 v\<^sub>0 then (m::\<real>) else 0) * c\<^sub>1 +
          (if b\<^sub>2 v\<^sub>0 then (n::\<real>) else 0) * c\<^sub>2)
    = m * card {s. b\<^sub>1 s} * c\<^sub>1 + n * card {s. b\<^sub>2 s} * c\<^sub>2"
  apply (subst infsum_add)
  using assms(1) infsum_constant_finite_states_summable_cmult_1 apply blast
  using assms(2) infsum_constant_finite_states_summable_cmult_1 apply blast
  apply (subst infsum_constant_finite_states_cmult_1)
  using assms(1) apply blast
  apply (subst infsum_constant_finite_states_cmult_1)
  using assms(2) apply blast
  by blast

lemma infsum_constant_finite_states_summable_cmult_3:
  assumes "finite {s. b\<^sub>1 s}" "finite {s. b\<^sub>2 s}" "finite {s. b\<^sub>3 s}"
  shows "(\<lambda>v\<^sub>0::'a. (if b\<^sub>1 v\<^sub>0 then (m::\<real>) else 0) * c\<^sub>1 +
          (if b\<^sub>2 v\<^sub>0 then (n::\<real>) else 0) * c\<^sub>2 +
          (if b\<^sub>3 v\<^sub>0 then (p::\<real>) else 0) * c\<^sub>3
    ) summable_on UNIV"
  apply (subst summable_on_add)+
  apply (rule summable_on_cmult_left)
  apply (simp add: assms(1) infsum_constant_finite_states_summable)
  apply (rule summable_on_cmult_left)
  apply (simp add: assms(2) infsum_constant_finite_states_summable)+
  apply (rule summable_on_cmult_left)
  by (simp add: assms(3) infsum_constant_finite_states_summable)+

lemma infsum_constant_finite_states_cmult_3:
  assumes "finite {s. b\<^sub>1 s}" "finite {s. b\<^sub>2 s}" "finite {s. b\<^sub>3 s}"
  shows "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a.
          (if b\<^sub>1 v\<^sub>0 then (m::\<real>) else 0) * c\<^sub>1 +
          (if b\<^sub>2 v\<^sub>0 then (n::\<real>) else 0) * c\<^sub>2 +
          (if b\<^sub>3 v\<^sub>0 then (p::\<real>) else 0) * c\<^sub>3)
    = m * card {s. b\<^sub>1 s} * c\<^sub>1 + n * card {s. b\<^sub>2 s} * c\<^sub>2 + p * card {s. b\<^sub>3 s} * c\<^sub>3"
  apply (subst infsum_add)
  using assms(1) assms(2) apply (rule infsum_constant_finite_states_summable_cmult_2)
  using assms(3) apply (rule infsum_constant_finite_states_summable_cmult_1)
  apply (subst infsum_constant_finite_states_cmult_1)
  using assms(3) apply blast
  apply (subst infsum_constant_finite_states_cmult_2)
  using assms(1) assms(2) by blast+

lemma infsum_constant_finite_states_summable_cmult_4:
  assumes "finite {s. b\<^sub>1 s}" "finite {s. b\<^sub>2 s}" "finite {s. b\<^sub>3 s}" "finite {s. b\<^sub>4 s}"
  shows "(\<lambda>v\<^sub>0::'a. (if b\<^sub>1 v\<^sub>0 then (m::\<real>) else 0) * c\<^sub>1 +
          (if b\<^sub>2 v\<^sub>0 then (n::\<real>) else 0) * c\<^sub>2 +
          (if b\<^sub>3 v\<^sub>0 then (p::\<real>) else 0) * c\<^sub>3 +
          (if b\<^sub>4 v\<^sub>0 then (q::\<real>) else 0) * c\<^sub>4
    ) summable_on UNIV"
  apply (subst summable_on_add)+
  apply (rule summable_on_cmult_left)
  apply (simp add: assms(1) infsum_constant_finite_states_summable)
  apply (rule summable_on_cmult_left)
  apply (simp add: assms(2) infsum_constant_finite_states_summable)+
  apply (rule summable_on_cmult_left)
  apply (simp add: assms(3) infsum_constant_finite_states_summable)+
  apply (rule summable_on_cmult_left)
  by (simp add: assms(4) infsum_constant_finite_states_summable)+

lemma infsum_constant_finite_states_4:
  assumes "finite {s. b\<^sub>1 s}" "finite {s. b\<^sub>2 s}" "finite {s. b\<^sub>3 s}" "finite {s. b\<^sub>4 s}"
  shows "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a.
          (if b\<^sub>1 v\<^sub>0 then (m::\<real>) else 0) * c\<^sub>1 +
          (if b\<^sub>2 v\<^sub>0 then (n::\<real>) else 0) * c\<^sub>2 +
          (if b\<^sub>3 v\<^sub>0 then (p::\<real>) else 0) * c\<^sub>3+
          (if b\<^sub>4 v\<^sub>0 then (q::\<real>) else 0) * c\<^sub>4)
    = m * card {s. b\<^sub>1 s} * c\<^sub>1 + n * card {s. b\<^sub>2 s} * c\<^sub>2 + p * card {s. b\<^sub>3 s} * c\<^sub>3 + q * card {s. b\<^sub>4 s} * c\<^sub>4"
  apply (subst infsum_add)
  using assms(1) assms(2) assms(3) apply (rule infsum_constant_finite_states_summable_cmult_3)
  using assms(4) apply (rule infsum_constant_finite_states_summable_cmult_1)
  apply (subst infsum_constant_finite_states_cmult_1)
  using assms(4) apply blast
  apply (subst infsum_constant_finite_states_cmult_3)
  using assms(1) assms(2) assms(3) by blast+

lemma infsum_singleton_cond_unique:
  assumes "\<exists>! v. b v"
  shows "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. (if b v\<^sub>0 then (m::\<real>) else 0)) = m"
  apply (rule infsumI)
  apply (simp add: has_sum_def)
  apply (subst topological_tendstoI)
  apply (auto)
  apply (simp add: eventually_finite_subsets_at_top)
  apply (rule_tac x = "{THE v. b v}" in exI)
  apply (auto)
  by (smt (verit, ccfv_SIG) assms finite_insert mk_disjoint_insert sum.insert sum_nonneg
      sum_nonpos theI)

lemma infsum_mult_singleton_left:
  "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. ((if v\<^sub>0 = c then (1::\<real>) else 0) * (P v\<^sub>0))) = P c"
  apply (rule infsumI)
  apply (simp add: has_sum_def)
  apply (subst topological_tendstoI)
  apply (auto)
  apply (simp add: eventually_finite_subsets_at_top)
  apply (rule_tac x = "{c}" in exI)
  apply (auto)
  by (simp add: sum.remove)

lemma infsum_mult_singleton_right:
  "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. ((P v\<^sub>0) * (if v\<^sub>0 = c then (1::\<real>) else 0))) = P c"
  using infsum_mult_singleton_left
  by (metis (no_types, lifting) infsum_cong mult.commute)

lemma infsum_mult_singleton_left_1:
  "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. ((if c = v\<^sub>0 then (1::\<real>) else 0) * (P v\<^sub>0))) = P c"
  using infsum_mult_singleton_left
  by (smt (verit) infsum_cong)

lemma infsum_mult_singleton_right_1:
  "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. ((P v\<^sub>0) * (if c = v\<^sub>0 then (1::\<real>) else 0))) = P c"
  using infsum_mult_singleton_right
  by (smt (verit) infsum_cong)

lemma infsum_mult_singleton_1:
  "(\<Sum>\<^sub>\<infinity>s::'a.
      (\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. (if c = v\<^sub>0 then 1::\<real> else (0::\<real>))
                * (if f v\<^sub>0 = s then 1::\<real> else (0::\<real>)))
   ) = (1::\<real>)"
  apply (rule infsumI)
  apply (simp add: has_sum_def)
  apply (subst topological_tendstoI)
  apply (auto)
  apply (simp add: eventually_finite_subsets_at_top)
  apply (rule_tac x="{f c}" in exI)
  apply (auto)
  apply (subgoal_tac "(\<Sum>s::'a\<in>Y. \<Sum>\<^sub>\<infinity>v\<^sub>0::'a. (if c = v\<^sub>0 then 1::\<real> else (0::\<real>)) *
    (if f v\<^sub>0 = s then 1::\<real> else (0::\<real>)))
    = 1")
  apply presburger
  apply (simp add: sum.remove)
  apply (subgoal_tac "(\<Sum>s::'a\<in>Y - {f c}. \<Sum>\<^sub>\<infinity>v\<^sub>0::'a. (if c = v\<^sub>0 then 1::\<real> else (0::\<real>)) *
    (if f v\<^sub>0 = s then 1::\<real> else (0::\<real>)))
    = 0")
  prefer 2
  apply (subst sum_nonneg_eq_0_iff)
  apply (simp)+
  apply (simp add: infsum_nonneg)
  apply (smt (verit, best) Diff_iff infsum_0 insert_iff mult_not_zero)
  apply (simp)
  apply (rule infsumI)
  apply (simp add: has_sum_def)
  apply (subst topological_tendstoI)
  apply (auto)
  apply (simp add: eventually_finite_subsets_at_top)
  apply (rule_tac x = "{c}" in exI)
  apply (auto)
  apply (subgoal_tac "(\<Sum>v\<^sub>0::'a\<in>Ya.
        (if c = v\<^sub>0 then 1::\<real> else (0::\<real>)) *
        (if f v\<^sub>0 = f c then 1::\<real> else (0::\<real>)))
    = 1")
  apply simp
  apply (simp add: sum.remove)
  by (smt (verit, ccfv_SIG) Diff_insert_absorb mk_disjoint_insert mult_cancel_left1
      sum.not_neutral_contains_not_neutral)

lemma infsum_mult_subset_left:
  "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. ((if b v\<^sub>0 then (1::\<real>) else 0) * (P v\<^sub>0))) = (\<Sum>\<^sub>\<infinity>v\<^sub>0::'a \<in> {v\<^sub>0. b v\<^sub>0}. (P v\<^sub>0))"
  apply (rule infsum_cong_neutral)
  by simp+

lemma infsum_mult_subset_left_summable:
  "((\<lambda>v\<^sub>0::'a. (if b v\<^sub>0 then (1::\<real>) else 0) * (P v\<^sub>0)) summable_on UNIV) =
   ((\<lambda>v\<^sub>0::'a. (P v\<^sub>0)) summable_on {v\<^sub>0. b v\<^sub>0})"
  apply (rule summable_on_cong_neutral)
  apply simp
  by simp+

lemma infsum_mult_subset_right:
  "(\<Sum>\<^sub>\<infinity>v\<^sub>0::'a. ((P v\<^sub>0) * (if b v\<^sub>0 then (1::\<real>) else 0))) = (\<Sum>\<^sub>\<infinity>v\<^sub>0::'a \<in> {v\<^sub>0. b v\<^sub>0}. (P v\<^sub>0))"
  apply (rule infsum_cong_neutral)
  by simp+

lemma infsum_not_zero_summable:
  assumes "infsum f A = x"
  assumes "x \<noteq> 0"
  shows "f summable_on A"
  using assms(1) assms(2) infsum_not_exists by blast

lemma infsum_not_zero_is_summable:
  assumes "infsum f A \<noteq> 0"
  shows "f summable_on A"
  using assms infsum_not_exists by blast

lemma infsum_mult_subset_left_summable':
  assumes "P summable_on UNIV"
  shows "(\<lambda>v\<^sub>0::'a. ((if b v\<^sub>0 then (m::\<real>) else 0) * (P v\<^sub>0))) summable_on UNIV"
  apply (subgoal_tac "(\<lambda>v\<^sub>0. (if b v\<^sub>0 then (m::\<real>) else 0) * (P v\<^sub>0)) summable_on UNIV
    \<longleftrightarrow> (\<lambda>x::'a. m * P x) summable_on {x. b x}")
  apply (metis assms subset_UNIV summable_on_cmult_right summable_on_subset_banach)
  apply (rule summable_on_cong_neutral)
  apply blast
  apply simp
  by auto

lemma infsum_mono_strict:
  fixes f :: "'a \<Rightarrow> \<real>"
  assumes "f summable_on A" and "g summable_on A"
  assumes \<open>\<And>x. x \<in> A \<Longrightarrow> f x < g x\<close>
  assumes "A \<noteq> {}"
  shows "infsum f A < infsum g A"
proof -
  have f0: \<open>\<And>x. x \<in> A \<Longrightarrow> f x \<le> g x\<close>
    using assms(3) nless_le by blast
  then have f1: "infsum f A \<le> infsum g A"
    by (simp add: assms(1) assms(2) infsum_mono)
  have f2: "infsum g A = infsum (\<lambda>x. (g x - f x) + f x) A"
    by auto
  also have f3: "... = infsum (\<lambda>x. (g x - f x)) A + infsum f A"
    apply (subst infsum_add)
    using summable_on_minus assms(1) assms(2) apply blast
    apply (simp add: assms(1))
    by simp
  obtain x where P_x: "x \<in> A"
    using assms(4) by blast
  have f4: "\<And>x. x \<in> A \<Longrightarrow> (g x - f x) > 0"
    using assms(3) by auto
  have f5: "infsum (\<lambda>x. (g x - f x)) ((A - {x}) \<union> {x}) = infsum (\<lambda>x. (g x - f x)) (A - {x}) + infsum (\<lambda>x. (g x - f x)) {x}"
    apply (subst infsum_Un_disjoint)
    apply (simp add: P_x assms(1) assms(2) summable_on_Diff summable_on_minus)
    apply simp
    apply blast
    by (simp)
  have f6: "... \<ge> infsum (\<lambda>x. (g x - f x)) {x}"
    by (smt (verit) DiffD1 f0 infsum_nonneg)
  have f7: "... > 0"
    using f4 P_x f6 by fastforce
  have f8: "infsum (\<lambda>x. (g x - f x)) A > 0"
    by (metis P_x Un_commute f5 f7 insert_Diff insert_is_Un)
  then have "infsum f A \<noteq> infsum g A"
    using f2 f3 by linarith
  then show "infsum f A < infsum g A"
    using f1 nless_le by blast
qed

subsection \<open> Series \<close>

lemma summable_n_2_power_n:
  "summable (\<lambda>n::\<nat>. (n / (2::\<real>)^n))" (is "summable ?f")
  (* n:           0, 1,   2,   3,   4 *)
  (*              0, 1/2, 2/4, 3/8, 4/16 *)
  (* (n+1)/(2*n): x, 1,   3/4, 4/6, 5/8, ... *)
  apply (subst summable_ratio_test[where c="3/4" and N="3"])
  apply auto
proof -
  fix n::\<nat>
  assume a1: "3 \<le> n"
  have f1: "((1::\<real>) + real n) / ((2::\<real>) * (2::\<real>) ^ n) = ((n+1) / (2* n)) * (?f n)"
    using a1 by auto
  have f2: "((1::\<real>) + real n) / 1 \<le> (3::\<real>) * real n / ((2::\<real>))"
    using a1 by force
  have f3: "((1::\<real>) + real n) / ((2::\<real>) * (2::\<real>) ^ n) \<le> (3::\<real>) * real n / (2) / ((2::\<real>) * (2::\<real>) ^ n)"
    apply (subst divide_right_mono[where c="((2::\<real>) * (2::\<real>) ^ n)"])
    using f2 apply force
    apply force
    by simp
  show "((1::\<real>) + real n) / ((2::\<real>) * (2::\<real>) ^ n) \<le> (3::\<real>) * real n / ((4::\<real>) * (2::\<real>) ^ n)"
    apply (simp only: f1)
    apply (auto)
    using f3 by force
qed

lemma summable_2_power_n: "summable (\<lambda>n::\<nat>. ((1::\<real>) / (2::\<real>)) ^ n / (2::\<real>))"
  apply (rule summable_divide)
  apply (rule summable_geometric)
  by simp

(*
lemma summable_n_a_power_n:
  assumes "a \<ge> 2"
  shows "summable (\<lambda>n::\<nat>. (n / (a::\<real>)^n))" (is "summable ?f")
  (* n:           0, 1,   2,      3,    4 *)
  (*              0, 1/a, 2/a^2, 3/a^3, 4/a^4 *)
  (* (n+1)/(a*n): x, 2/a, 3/a*2, 4/a*3, 5/a*4, ... *)
  apply (subst summable_ratio_test[where c="3/4" and N="3"])
  apply auto
proof -
  fix n::\<nat>
  assume a1: "3 \<le> n"
  have f0: "\<bar>a * a ^ n\<bar> = a * a ^ n"
    using assms by auto
  have f1: "\<bar>a ^ n\<bar> = a ^ n"
    using assms by auto
  have f1: "((1::\<real>) + real n) / ((a::\<real>) * (a::\<real>) ^ n) = ((n+1) / (a* n)) * (?f n)"
    using a1 by auto
  have f2: "((1::\<real>) + real n) / 1 \<le> (3::\<real>) * real n / (4/a)"
    apply auto
  have f3: "((1::\<real>) + real n) / ((2::\<real>) * (2::\<real>) ^ n) \<le> (3::\<real>) * real n / (2) / ((2::\<real>) * (2::\<real>) ^ n)"
    apply (subst divide_right_mono[where c="((2::\<real>) * (2::\<real>) ^ n)"])
    using f2 apply force
    apply force
    by simp
  show "((1::\<real>) + real n) / \<bar>a * a ^ n\<bar> \<le> (3::\<real>) * real n / ((4::\<real>) * \<bar>a ^ n\<bar>)"
    apply (simp only: f0)
    apply (simp only: f1)
    apply (auto)
    using f3 by force
qed
*)

lemma summable_1_2_power_n_t_n:
  "summable (\<lambda>n::\<nat>. ((1::\<real>) / (2::\<real>)) ^ (n) * ((real (t::\<nat>) + real n)))" (is "summable ?f")
proof -
  have f1: "(\<lambda>n::\<nat>. ((1::\<real>) / (2::\<real>)) ^ n * ((real t + real n))) =
        (\<lambda>n::\<nat>. ((1::\<real>) / (2::\<real>)) ^ n * (real t)  + ((1::\<real>) / (2::\<real>)) ^ n * (real n))"
    by (metis (mono_tags, opaque_lifting) mult_of_nat_commute of_nat_add ring_class.ring_distribs(2))

  have f2: "(\<lambda>n::\<nat>. ((1::\<real>) / (2::\<real>)) ^ n * real n) = (\<lambda>n::\<nat>. ((1::\<real>) / (2::\<real>)) ^ n * n)"
    by simp
  show "summable ?f"
    apply (simp add: f1)
     apply (subst summable_add)
    apply (rule summable_mult2)
    apply (rule summable_geometric)
    apply simp
    apply (subst summable_cong[where g = "(\<lambda>n::\<nat>. (n / (2::\<real>)^n))"])
    apply (simp add: power_divide)
    using summable_n_2_power_n apply blast
    by simp
qed

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

header "Deterministic automata"

theory DA
imports AutoProj
begin

type_synonym ('a,'s)da = "'s * ('a => 's => 's) * ('s => bool)"

definition
 foldl2 :: "('a => 'b => 'b) => 'a list => 'b => 'b" where
"foldl2 f xs a = foldl (%a b. f b a) a xs"

definition
 delta :: "('a,'s)da => 'a list => 's => 's" where
"delta A = foldl2 (next A)"

definition
 accepts :: "('a,'s)da => 'a list => bool" where
"accepts A = (%w. fin A (delta A w (start A)))"

lemma delta_Nil[simp]: "delta A [] s = s"
by(simp add:delta_def)

lemma delta_Cons[simp]: "delta A (a#w) s = delta A w (next A a s)"
by(simp add:delta_def)

lemma delta_append[simp]:
 "!!q ys. delta A (xs@ys) q = delta A ys (delta A xs q)"
by(induct xs) simp_all

end


theory Cantor  imports Main

begin

declare [[show_types]]

typedecl i

consts
  a::"i"     (* constant symbol of type i - denoting an object in the domain for type i*)
  f::"i\<Rightarrow>i"  (* constant symbol of function type i\<rightarrow>i - denoting an function in the domain
                for type i\<rightarrow>i*)
  p::"i\<Rightarrow>bool"  (* constant symbol of predicate type i\<rightarrow>bool - denoting an predicate/set in
                   the domain for type i\<rightarrow>bool*)

lemma "(\<lambda>g. \<lambda>y. g (g y)) f a = (f (f a))" by simp

lemma "(\<lambda>x. p x) a = (p a)" by simp

lemma "(\<lambda>x. p x)  = p" by simp

lemma "(\<lambda>y. ((\<lambda>x. p x) y)) a = ((\<lambda>x. p x) a)" by simp

lemma "(\<lambda>y. ((\<lambda>x. p x) y)) a = (p a)" by simp

consts d::bool c::bool

lemma "(d \<or> \<not>d) \<longrightarrow> d" sledgehammer nitpick[show_all] oops

lemma "(d \<and> c) \<longrightarrow> (c \<longrightarrow> d)" by simp

lemma "(d \<and> c) \<longrightarrow> (c \<longrightarrow> d)"
proof
  assume 1: "d \<and> c"
  have 2: "d" by (simp add: "1")
  have 3: "\<not>c \<or> d" by (simp add: "2")
  show "c \<longrightarrow> d" sledgehammer (3)
    using "3" by fastforce
qed

lemma "(\<forall>x. p x) \<longrightarrow> (\<exists>y. p y)" sledgehammer nitpick[show_all]  oops

lemma "(\<forall>x. p x) \<longrightarrow> (\<exists>y. p y)"
proof
 assume "(\<forall>x. p x)"
 fix a::i
 have "p a" by (simp add: \<open>\<forall>x. p x\<close>)
 show "\<exists>y. p y" using \<open>p a\<close> by auto
qed

lemma "(\<forall>x. p x) \<longrightarrow> (\<exists>y. p y)"
  sledgehammer
  unfolding All_def Ex_def
  sledgehammer
  oops

lemma "(\<exists>y. p y) \<longrightarrow> (\<forall>x. p x)" sledgehammer nitpick[show_all,card=2] oops

(* Simple Example (Exercise 2)*)
definition imp ::"bool\<Rightarrow>bool\<Rightarrow>bool" ("\<^bold>\<Rightarrow>") where "\<^bold>\<Rightarrow> \<equiv> \<lambda>x. \<lambda>y.((\<not>x) \<or> y)"
definition leq ::"i\<Rightarrow>i\<Rightarrow>bool" ("\<doteq>") where "\<doteq> \<equiv> \<lambda>x.\<lambda>y.(\<forall>P. (\<^bold>\<Rightarrow> (P x) (P y)))"

lemma "\<forall>x. ((\<doteq> x) x)"  unfolding leq_def imp_def by simp

lemma "\<forall>x. ((\<lambda>x.\<lambda>y.(\<forall>P. ((\<lambda>x.\<lambda>y.((\<not>x) \<or> y)) (P x) (P y)))) x x)"   by simp

lemma "\<forall>x. \<forall>P. \<not> P x \<or> P x" by simp

lemma "All (\<lambda> x. ((\<lambda>x.\<lambda>y.(\<forall>P. ((\<lambda>x.\<lambda>y.((\<not>x) \<or> y)) (P x) (P y)))) x x))" by simp

(*Church Numerals (Exercise 1)*)
type_synonym num = "(i \<Rightarrow> i) \<Rightarrow> i \<Rightarrow> i"

definition one ::num   ("1") where "1 \<equiv> (\<lambda>f. \<lambda>x. f x)"
definition two ::num   ("2") where "2 \<equiv> (\<lambda>f. \<lambda>x. f (f x))"
definition three ::num ("3") where "3 \<equiv> (\<lambda>f. \<lambda>x. f (f (f x)))"
definition four ::num  ("4") where "4 \<equiv> (\<lambda>f. \<lambda>x. f ( f (f (f x))))"
definition five ::num  ("5") where "5 \<equiv> (\<lambda>f. \<lambda>x. f (f ( f (f (f x)))))"

definition plus ::"num\<Rightarrow>num\<Rightarrow>num"   ("+") where "+ \<equiv> \<lambda>u.\<lambda>v.(\<lambda>f.\<lambda>y.((u f) ((v f) y)))"
definition mult ::"num\<Rightarrow>num\<Rightarrow>num"   ("*") where "* \<equiv> \<lambda>u.\<lambda>v.(\<lambda>f.\<lambda>y.(u (v f)) y)"

named_theorems Defs declare one_def two_def three_def four_def five_def plus_def mult_def

lemma Homework1: "t = (+ 2 3)" unfolding two_def three_def plus_def oops

(* Some first tests *)
theorem Test1: "(\<exists>x::i. \<forall>y::i. x = y) \<longrightarrow> (\<forall>x::i. \<exists>y::i. x = y) "
  nitpick
  sledgehammer
  sledgehammer [remote_leo2]
  by auto

theorem Test2: "(\<forall>x::i. \<exists>y::i. x = y) \<longrightarrow> (\<exists>x::i. \<forall>y::i. x = y) "
  nitpick [card=2]
  sledgehammer
  sledgehammer [remote_leo2]
  oops

theorem Test3: "\<exists>g::i\<Rightarrow>bool. \<forall>x::i. g(x)"
  nitpick
  sledgehammer
  sledgehammer[remote_leo2]
  by auto

(* The surjective Cantor theorem *)

theorem Cantor: "\<not>(\<exists>f::i\<Rightarrow>(i\<Rightarrow>bool). \<forall>g::i\<Rightarrow>bool. \<exists>x::i. f x = g)"
  nitpick
  sledgehammer
  sledgehammer[remote_leo2 remote_leo3, overlord]
  oops

(* The Traditonal Proof *)
lemma CantorSurjective: "\<not>(\<exists>f::i\<Rightarrow>i\<Rightarrow>bool.\<forall>p.\<exists>x. f x = p)"
proof
  assume "\<exists>f::i\<Rightarrow>i\<Rightarrow>bool.\<forall>p.\<exists>x. f x = p"
  then obtain f :: "i\<Rightarrow>i\<Rightarrow>bool"
    where 1: "\<forall>p.\<exists>x. f x = p" by blast
  let ?P = "\<lambda>x.\<not>f x x"
  have "\<exists>x. ?P = f x" using 1 by metis
  then obtain a::i
    where "?P = f a" by blast
  then have "?P a \<longleftrightarrow> f a a"  by metis
  then have "\<not>f a a \<longleftrightarrow> f a a" by blast
  then show False by blast
qed

(* Proof D. Fuenmayor and C. Benzmüller: avoids refutation  argument *)

lemma CantorSurjective': "\<not>(\<exists>f::i\<Rightarrow>i\<Rightarrow>bool.\<forall>p.\<exists>x. f x = p)"
proof -
  {fix F :: "i\<Rightarrow>i\<Rightarrow>bool"
    have "\<forall>w. \<exists>v. \<not>(F w v) \<longleftrightarrow> \<not>(F v v)" by auto  (*choose v=w*)
    hence "\<forall>w.\<exists>v.\<not>(F w v) \<longleftrightarrow> ((\<lambda>x. \<not>(F x x)) v)" by simp (* lambda-conversion and replacement *)
    hence "\<exists> p. \<forall> w. \<exists> v. \<not>(F w v) \<longleftrightarrow> (p v)" by auto (* exists-introduction *)
    hence "\<exists> p. \<forall> w. \<not>(\<forall> v. (F w v) \<longleftrightarrow> (p v))" by auto (* pull negation outwards *)
    hence "\<exists>p. \<forall>w. \<not>(F w = p)" by metis (* Boolean and functional extensionality *)
  }
  hence "\<forall> f ::i\<Rightarrow>i\<Rightarrow>bool. \<exists> p. \<forall> w. \<not>(f w = p)" by simp (* F was chosen arbitrary *)
  hence "\<not>(\<exists>f::i\<Rightarrow>i\<Rightarrow>bool.\<forall>p.\<exists>x. f x = p)" by simp (* pull negation outwards *)
  thus ?thesis . (* we are done *)
qed

end


(*  Title:      HOL/Semiring_Normalization.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Semiring normalization\<close>

theory Semiring_Normalization
imports Numeral_Simprocs
begin

text \<open>Prelude\<close>

class comm_semiring_1_cancel_crossproduct = comm_semiring_1_cancel +
  assumes crossproduct_eq: "w * y + x * z = w * z + x * y \<longleftrightarrow> w = x \<or> y = z"
begin

lemma crossproduct_noteq:
  "a \<noteq> b \<and> c \<noteq> d \<longleftrightarrow> a * c + b * d \<noteq> a * d + b * c"
  by (simp add: crossproduct_eq)

lemma add_scale_eq_noteq:
  "r \<noteq> 0 \<Longrightarrow> a = b \<and> c \<noteq> d \<Longrightarrow> a + r * c \<noteq> b + r * d"
proof (rule notI)
  assume nz: "r\<noteq> 0" and cnd: "a = b \<and> c\<noteq>d"
    and eq: "a + (r * c) = b + (r * d)"
  have "(0 * d) + (r * c) = (0 * c) + (r * d)"
    using add_left_imp_eq eq mult_zero_left by (simp add: cnd)
  then show False using crossproduct_eq [of 0 d] nz cnd by simp
qed

lemma add_0_iff:
  "b = b + a \<longleftrightarrow> a = 0"
  using add_left_imp_eq [of b a 0] by auto

end

subclass (in idom) comm_semiring_1_cancel_crossproduct
proof
  fix w x y z
  show "w * y + x * z = w * z + x * y \<longleftrightarrow> w = x \<or> y = z"
  proof
    assume "w * y + x * z = w * z + x * y"
    then have "w * y + x * z - w * z - x * y = 0" by (simp add: algebra_simps)
    then have "w * (y - z) - x * (y - z) = 0" by (simp add: algebra_simps)
    then have "(y - z) * (w - x) = 0" by (simp add: algebra_simps)
    then have "y - z = 0 \<or> w - x = 0" by (rule divisors_zero)
    then show "w = x \<or> y = z" by auto
  qed (auto simp add: ac_simps)
qed

instance nat :: comm_semiring_1_cancel_crossproduct
proof
  fix w x y z :: nat
  have aux: "\<And>y z. y < z \<Longrightarrow> w * y + x * z = w * z + x * y \<Longrightarrow> w = x"
  proof -
    fix y z :: nat
    assume "y < z" then have "\<exists>k. z = y + k \<and> k \<noteq> 0" by (intro exI [of _ "z - y"]) auto
    then obtain k where "z = y + k" and "k \<noteq> 0" by blast
    assume "w * y + x * z = w * z + x * y"
    then have "(w * y + x * y) + x * k = (w * y + x * y) + w * k" by (simp add: \<open>z = y + k\<close> algebra_simps)
    then have "x * k = w * k" by simp
    then show "w = x" using \<open>k \<noteq> 0\<close> by simp
  qed
  show "w * y + x * z = w * z + x * y \<longleftrightarrow> w = x \<or> y = z"
    by (auto simp add: neq_iff dest!: aux)
qed

text \<open>Semiring normalization proper\<close>

ML_file \<open>Tools/semiring_normalizer.ML\<close>

context comm_semiring_1
begin

lemma semiring_normalization_rules [no_atp]:
  "(a * m) + (b * m) = (a + b) * m"
  "(a * m) + m = (a + 1) * m"
  "m + (a * m) = (a + 1) * m"
  "m + m = (1 + 1) * m"
  "0 + a = a"
  "a + 0 = a"
  "a * b = b * a"
  "(a + b) * c = (a * c) + (b * c)"
  "0 * a = 0"
  "a * 0 = 0"
  "1 * a = a"
  "a * 1 = a"
  "(lx * ly) * (rx * ry) = (lx * rx) * (ly * ry)"
  "(lx * ly) * (rx * ry) = lx * (ly * (rx * ry))"
  "(lx * ly) * (rx * ry) = rx * ((lx * ly) * ry)"
  "(lx * ly) * rx = (lx * rx) * ly"
  "(lx * ly) * rx = lx * (ly * rx)"
  "lx * (rx * ry) = (lx * rx) * ry"
  "lx * (rx * ry) = rx * (lx * ry)"
  "(a + b) + (c + d) = (a + c) + (b + d)"
  "(a + b) + c = a + (b + c)"
  "a + (c + d) = c + (a + d)"
  "(a + b) + c = (a + c) + b"
  "a + c = c + a"
  "a + (c + d) = (a + c) + d"
  "(x ^ p) * (x ^ q) = x ^ (p + q)"
  "x * (x ^ q) = x ^ (Suc q)"
  "(x ^ q) * x = x ^ (Suc q)"
  "x * x = x\<^sup>2"
  "(x * y) ^ q = (x ^ q) * (y ^ q)"
  "(x ^ p) ^ q = x ^ (p * q)"
  "x ^ 0 = 1"
  "x ^ 1 = x"
  "x * (y + z) = (x * y) + (x * z)"
  "x ^ (Suc q) = x * (x ^ q)"
  "x ^ (2*n) = (x ^ n) * (x ^ n)"
  by (simp_all add: algebra_simps power_add power2_eq_square
    power_mult_distrib power_mult del: one_add_one)

local_setup \<open>
  Semiring_Normalizer.declare @{thm comm_semiring_1_axioms}
    {semiring = ([\<^term>\<open>x + y\<close>, \<^term>\<open>x * y\<close>, \<^term>\<open>x ^ n\<close>, \<^term>\<open>0\<close>, \<^term>\<open>1\<close>],
      @{thms semiring_normalization_rules}),
     ring = ([], []),
     field = ([], []),
     idom = [],
     ideal = []}
\<close>

end

context comm_ring_1
begin

lemma ring_normalization_rules [no_atp]:
  "- x = (- 1) * x"
  "x - y = x + (- y)"
  by simp_all

local_setup \<open>
  Semiring_Normalizer.declare @{thm comm_ring_1_axioms}
    {semiring = ([\<^term>\<open>x + y\<close>, \<^term>\<open>x * y\<close>, \<^term>\<open>x ^ n\<close>, \<^term>\<open>0\<close>, \<^term>\<open>1\<close>],
      @{thms semiring_normalization_rules}),
      ring = ([\<^term>\<open>x - y\<close>, \<^term>\<open>- x\<close>], @{thms ring_normalization_rules}),
      field = ([], []),
      idom = [],
      ideal = []}
\<close>

end

context comm_semiring_1_cancel_crossproduct
begin

local_setup \<open>
  Semiring_Normalizer.declare @{thm comm_semiring_1_cancel_crossproduct_axioms}
    {semiring = ([\<^term>\<open>x + y\<close>, \<^term>\<open>x * y\<close>, \<^term>\<open>x ^ n\<close>, \<^term>\<open>0\<close>, \<^term>\<open>1\<close>],
      @{thms semiring_normalization_rules}),
     ring = ([], []),
     field = ([], []),
     idom = @{thms crossproduct_noteq add_scale_eq_noteq},
     ideal = []}
\<close>

end

context idom
begin

local_setup \<open>
  Semiring_Normalizer.declare @{thm idom_axioms}
   {semiring = ([\<^term>\<open>x + y\<close>, \<^term>\<open>x * y\<close>, \<^term>\<open>x ^ n\<close>, \<^term>\<open>0\<close>, \<^term>\<open>1\<close>],
      @{thms semiring_normalization_rules}),
    ring = ([\<^term>\<open>x - y\<close>, \<^term>\<open>- x\<close>], @{thms ring_normalization_rules}),
    field = ([], []),
    idom = @{thms crossproduct_noteq add_scale_eq_noteq},
    ideal = @{thms right_minus_eq add_0_iff}}
\<close>

end

context field
begin

local_setup \<open>
  Semiring_Normalizer.declare @{thm field_axioms}
   {semiring = ([\<^term>\<open>x + y\<close>, \<^term>\<open>x * y\<close>, \<^term>\<open>x ^ n\<close>, \<^term>\<open>0\<close>, \<^term>\<open>1\<close>],
      @{thms semiring_normalization_rules}),
    ring = ([\<^term>\<open>x - y\<close>, \<^term>\<open>- x\<close>], @{thms ring_normalization_rules}),
    field = ([\<^term>\<open>x / y\<close>, \<^term>\<open>inverse x\<close>], @{thms divide_inverse inverse_eq_divide}),
    idom = @{thms crossproduct_noteq add_scale_eq_noteq},
    ideal = @{thms right_minus_eq add_0_iff}}
\<close>

end

code_identifier
  code_module Semiring_Normalization \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


theory Chapter9_2
imports "HOL-IMP.Sec_Typing"
begin

text \<open>
\exercise
Reformulate the inductive predicate @{const sec_type}
as a recursive function and prove the equivalence of the two formulations:
\<close>

fun ok :: "level \<Rightarrow> com \<Rightarrow> bool" where
  "ok l SKIP = True" |
  "ok l (x ::= a) \<longleftrightarrow> sec x \<ge> sec a \<and> sec x \<ge> l" |
  "ok l (c\<^sub>1;; c\<^sub>2) \<longleftrightarrow> ok l c\<^sub>1 \<and> ok l c\<^sub>2" |
  "ok l (IF b THEN c\<^sub>1 ELSE c\<^sub>2) \<longleftrightarrow> ok (max (sec b) l) c\<^sub>1 \<and> ok (max (sec b) l) c\<^sub>2" |
  "ok l (WHILE b DO c) = ok (max (sec b) l) c"

thm sec_type.intros
theorem "(l \<turnstile> c) = ok l c"
proof
  assume "l \<turnstile> c"
  then show "ok l c" by (induct rule: sec_type.induct) auto
next
  assume "ok l c"
  then show "l \<turnstile> c" by (induct l c rule: ok.induct) (auto intro: sec_type.intros)
qed

text\<open>
Try to reformulate the bottom-up system @{prop "\<turnstile> c : l"}
as a function that computes @{text l} from @{text c}. What difficulty do you face?
\endexercise
\<close>

(* "Problem": need to use quantifiers *)

text\<open>
\exercise
Define a bottom-up termination insensitive security type system
@{text"\<turnstile>' c : l"} with subsumption rule:
\<close>

inductive sec_type2' :: "com \<Rightarrow> level \<Rightarrow> bool" ("(\<turnstile>' _ : _)" [0,0] 50) where
Skip2': "\<turnstile>' SKIP : l" |
Assign2': "sec x \<ge> sec a \<Longrightarrow> \<turnstile>' x ::= a : sec x" |
Seq2': "\<lbrakk>\<turnstile>' c\<^sub>1 : l;  \<turnstile>' c\<^sub>2 : l\<rbrakk> \<Longrightarrow> \<turnstile>' c\<^sub>1;;c\<^sub>2 : l" |
If2': "\<lbrakk>sec b \<le> l;  \<turnstile>' c\<^sub>1 : l;  \<turnstile>' c\<^sub>2 : l\<rbrakk>
  \<Longrightarrow> \<turnstile>' IF b THEN c\<^sub>1 ELSE c\<^sub>2 : l" |
While2': "\<lbrakk>sec b \<le> l;  \<turnstile>' c : l\<rbrakk> \<Longrightarrow> \<turnstile>' WHILE b DO c : l" |
anti_mono2': "\<lbrakk>\<turnstile>' c : l; l' \<le> l\<rbrakk> \<Longrightarrow> \<turnstile>' c : l'"

text\<open>
Prove equivalence with the bottom-up system @{prop "\<turnstile> c : l"}
without subsumption rule:
\<close>

lemma "\<turnstile> c : l \<Longrightarrow> \<turnstile>' c : l"
proof (induct rule: sec_type2.induct)
  case (Seq2 c\<^sub>1 l\<^sub>1 c\<^sub>2 l\<^sub>2)
  from Seq2(2, 4) have "\<turnstile>' c\<^sub>1 : min l\<^sub>1 l\<^sub>2" and "\<turnstile>' c\<^sub>2 : min l\<^sub>1 l\<^sub>2" by (auto intro: sec_type2'.intros)
  then show ?case by (auto intro: sec_type2'.intros)
next
  case (If2 b l\<^sub>1 l\<^sub>2 c\<^sub>1 c\<^sub>2)
  from If2(3, 5) have "\<turnstile>' c\<^sub>1 : min l\<^sub>1 l\<^sub>2" and "\<turnstile>' c\<^sub>2 : min l\<^sub>1 l\<^sub>2" by (auto intro: sec_type2'.intros)
  with If2(1) show ?case by (auto intro: sec_type2'.intros)
qed (auto intro: sec_type2'.intros)

lemma "\<turnstile>' c : l \<Longrightarrow> \<exists>l' \<ge> l. \<turnstile> c : l'"
proof (induct rule: sec_type2'.induct)
  case (Seq2' c\<^sub>1 l c\<^sub>2)
  then show ?case by (auto intro: sec_type2.intros min.boundedI)
next
  case (If2' b l c\<^sub>1 c\<^sub>2)
  then show ?case by (auto dest: le_trans intro: sec_type2.intros min.boundedI)
next
  case (While2' b l c)
  then show ?case by (auto dest: le_trans intro: sec_type2.intros)
next
  case (anti_mono2' c l l')
  then show ?case by (auto dest: le_trans)
qed (auto intro: sec_type2.intros)

text\<open>
\endexercise

\exercise
Define a function that erases those parts of a command that
contain variables above some security level: \<close>

fun erase :: "level \<Rightarrow> com \<Rightarrow> com" where
  "erase l SKIP = SKIP" |
  "erase l (x ::= a) = (if sec x < l then (x ::= a) else SKIP)" |
  "erase l (c\<^sub>1;; c\<^sub>2) = erase l c\<^sub>1;; erase l c\<^sub>2" |
  "erase l (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (if sec b < l then IF b THEN erase l c\<^sub>1 ELSE erase l c\<^sub>2 else SKIP)" |
  "erase l (WHILE b DO c) = (if sec b < l then WHILE b DO erase l c else SKIP)"

text\<open>
Function @{term "erase l"} should replace all assignments to variables with
security level @{text"\<ge> l"} by @{const SKIP}.
It should also erase certain @{text IF}s and @{text WHILE}s,
depending on the security level of the boolean condition. Now show
that @{text c} and @{term "erase l c"} behave the same on the variables up
to level @{text l}: \<close>

lemma aval_eq_if_eq_less: "\<lbrakk> s\<^sub>1 = s\<^sub>2 (< l);  sec a < l \<rbrakk> \<Longrightarrow> aval a s\<^sub>1 = aval a s\<^sub>2"
  by (induct a) auto

lemma bval_eq_if_eq_less: "\<lbrakk> s\<^sub>1 = s\<^sub>2 (< l);  sec b < l \<rbrakk> \<Longrightarrow> bval b s\<^sub>1 = bval b s\<^sub>2"
  by (induct b) (auto simp add: aval_eq_if_eq_less)

theorem erase_correct: "\<lbrakk>(c,s) \<Rightarrow> s'; (erase l c, t) \<Rightarrow> t'; 0 \<turnstile> c; s = t (< l)\<rbrakk>
   \<Longrightarrow> s' = t' (< l)"
proof (induct arbitrary: t t' rule: big_step_induct)
  case (Skip s)
  then show ?case by auto
next
  case (Assign x a s)
  then show ?case by (cases "sec x < l") (auto intro!: aval_eq_if_eq_less)
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by fastforce
next
  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
  from IfTrue(5) have Hsec: "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" by auto
  show ?case
  proof (cases "sec b < l")
    case True
    from True IfTrue(6) have "s = t (< sec b)" by simp
    moreover from True IfTrue(1, 6) have "bval b t" by (auto simp add: bval_eq_if_eq_less)
    ultimately show ?thesis using True IfTrue(4, 6) Hsec(1)
      by (intro IfTrue(3)) (auto dest: anti_mono)
  next
    case False
    with IfTrue(4) have Htt': "t = t'" by auto
    thm anti_mono [of "sec b" _ l]
    with False Hsec have "l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
      by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
    with IfTrue(1, 2) have "s = s' (< l)" by (auto dest: confinement)
    with IfTrue(4, 6) Htt' show ?thesis by auto
  qed
next
  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
  from IfFalse(5) have Hsecc: "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" by auto
  show ?case
  proof (cases "sec b < l")
    case True
    from True IfFalse(6) have "s = t (< sec b)" by simp
    moreover from True IfFalse(1, 6) have "\<not> bval b t" by (auto simp add: bval_eq_if_eq_less)
    ultimately show ?thesis using True IfFalse(4, 6) Hsecc(2)
      by (intro IfFalse(3)) (auto dest: anti_mono)
  next
    case False
    with IfFalse(4) have Htt': "t = t'" by auto
    thm anti_mono [of "sec b" _ l]
    with False Hsecc have "l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
      by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
    with IfFalse(1, 2) have "s = s' (< l)" by (auto dest: confinement)
    with IfFalse(4, 6) Htt' show ?thesis by auto
  qed
next
  case (WhileFalse b s c)
  then show ?case by (cases "sec b < l") (auto simp add: bval_eq_if_eq_less)
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  from WhileTrue(7) have Hsecc: "sec b \<turnstile> c" by auto
  then show ?case
  proof (cases "sec b < l")
    case True
    with WhileTrue(1, 8) have "bval b t" by (auto simp add: bval_eq_if_eq_less)
    with True WhileTrue(6) obtain ti where H: "(erase l c, t) \<Rightarrow> ti" "(WHILE b DO erase l c, ti) \<Rightarrow> t'" by auto
    from this(1) Hsecc WhileTrue(8) have "s\<^sub>2 = ti (< l)" by (intro WhileTrue(3)) (auto intro: anti_mono)
    with True H(2) WhileTrue(7) show ?thesis by (intro WhileTrue(5)) auto
  next
    case False
    with WhileTrue(2) Hsecc have H1: "s\<^sub>1 = s\<^sub>2 (< l)" by (auto dest: confinement)
    from False Hsecc have "l \<turnstile> WHILE b DO c" by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
    with WhileTrue(4) have H2: "s\<^sub>2 = s\<^sub>3 (< l)" by (simp add: confinement)
    from False WhileTrue(6) have "t = t'" by auto
    with WhileTrue(8) H1 H2 show ?thesis by simp
  qed
qed

text\<open> This theorem looks remarkably like the noninterference lemma from
theory \mbox{@{theory "HOL-IMP.Sec_Typing"}} (although @{text"\<le>"} has been replaced by @{text"<"}).
You may want to start with that proof and modify it.
The structure should remain the same. You may also need one or
two simple additional lemmas.

In the theorem above we assume that both @{term"(c,s)"}
and @{term "(erase l c,t)"} terminate. How about the following two properties: \<close>

(* Idea: only problem is with loops whose conditional decides on confidential
  data. But these loops get erased so that the erased program always terminates
  once the original program terminates
*)
lemma "\<lbrakk> (c,s) \<Rightarrow> s';  0 \<turnstile> c;  s = t (< l) \<rbrakk>
  \<Longrightarrow> \<exists>t'. (erase l c, t) \<Rightarrow> t' \<and> s' = t' (< l)"
proof (induct arbitrary: t rule: big_step_induct)
  case (Skip s)
  then show ?case by auto
next
  case (Assign x a s)
  then show ?case
  proof (cases "sec x < l")
    case True
    then have H1: "(erase l (x ::= a), t) \<Rightarrow> t(x := aval a t)" by auto
    moreover have H2: "(x ::= a, s) \<Rightarrow> s(x := aval a s)" by auto
    ultimately show ?thesis using Assign by (meson erase_correct)
  qed auto
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by fastforce
next
  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
  from IfTrue(4) have Hsecc: "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" by auto
  show ?case
  proof (cases "sec b < l")
    case True
    with IfTrue(1, 5) have H1: "bval b t" by (auto simp add: bval_eq_if_eq_less)
    from IfTrue(3, 5) Hsecc(1) obtain t' where H2: "(erase l c\<^sub>1, t) \<Rightarrow> t'" "s' = t' (< l)" by (meson zero_le anti_mono)
    from H1 H2(1) have "((IF b THEN erase l c\<^sub>1 ELSE erase l c\<^sub>2), t) \<Rightarrow> t'" by auto
    with True H2(2) show ?thesis by auto
  next
    case False
    then have "(erase l (IF b THEN c\<^sub>1 ELSE c\<^sub>2), t) \<Rightarrow> t" by auto
    moreover
    from False Hsecc have "l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
      by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
    with IfTrue(1, 2) have "s = s' (< l)" by (auto dest: confinement)
    with IfTrue(5) have "s' = t (< l)" by auto
    ultimately show ?thesis by blast
  qed
next
  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
  from IfFalse(4) have Hsecc: "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" by auto
  show ?case
  proof (cases "sec b < l")
    case True
    with IfFalse(1, 5) have H1: "\<not>bval b t" by (auto simp add: bval_eq_if_eq_less)
    from IfFalse(3, 5) Hsecc(2) obtain t' where H2: "(erase l c\<^sub>2, t) \<Rightarrow> t'" "s' = t' (< l)" by (meson zero_le anti_mono)
    from H1 H2(1) have "((IF b THEN erase l c\<^sub>1 ELSE erase l c\<^sub>2), t) \<Rightarrow> t'" by auto
    with True H2(2) show ?thesis by auto
  next
    case False
    then have "(erase l (IF b THEN c\<^sub>1 ELSE c\<^sub>2), t) \<Rightarrow> t" by auto
    moreover
    from False Hsecc have "l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
      by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
    with IfFalse(1, 2) have "s = s' (< l)" by (auto dest: confinement)
    with IfFalse(5) have "s' = t (< l)" by auto
    ultimately show ?thesis by blast
  qed
next
  case (WhileFalse b s c)
  then show ?case by (cases "sec b < l") (auto simp add: bval_eq_if_eq_less)
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  from WhileTrue(6) have Hsecc: "sec b \<turnstile> c" by auto
  then show ?case
  proof (cases "sec b < l")
    case True
    with WhileTrue(1, 7) have Hb: "bval b t" by (auto simp add: bval_eq_if_eq_less)
    from Hsecc WhileTrue(3, 7) obtain ti where H1: "(erase l c, t) \<Rightarrow> ti" "s\<^sub>2 = ti (< l)" by (force intro: anti_mono)
    from WhileTrue(5, 6) H1(2) obtain t' where H2: "(erase l (WHILE b DO c), ti) \<Rightarrow> t'" "s\<^sub>3 = t' (< l)" by meson
    with True Hb H1(1) show ?thesis by auto
  next
    case False
    with WhileTrue(2) Hsecc have H1: "s\<^sub>1 = s\<^sub>2 (< l)" by (auto dest: confinement)
    from False Hsecc have "l \<turnstile> WHILE b DO c" by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
    with WhileTrue(4) have H2: "s\<^sub>2 = s\<^sub>3 (< l)" by (simp add: confinement)
    from False have "(erase l (WHILE b DO c), t) \<Rightarrow> t" by auto
    with WhileTrue(7) H1 H2 show ?thesis by auto
  qed
qed

lemma "\<not>(\<forall> l c s s' t. (erase l c, s) \<Rightarrow> s' \<longrightarrow> 0 \<turnstile> c \<longrightarrow> s = t (< l) \<longrightarrow> (\<exists>t'. (c,t) \<Rightarrow> t' \<and> s' = t' (< l)))"
proof
  let ?l = "2 :: nat"
  let ?b = "Less (N 0) (V ''ab'')"
  let ?w = "WHILE ?b DO SKIP"
  let ?a = "''a'' ::= (N 0)"
  let ?c = "?w;; ?a"
  let ?s = "(\<lambda> _. 1) :: state"
  let ?s' = "?s (''a'' := 0)"
  have [simp]: "sec ''ab'' = 2" using sec_list_def [of "''ab''"] by simp
  have [simp]: "sec ''a'' = 1" using sec_list_def [of "''a''"] by simp
  have "(erase ?l ?w, ?s) \<Rightarrow> ?s" by auto
  moreover have "(?a, ?s) \<Rightarrow> ?s (''a'' := aval (N 0) ?s)" by blast
  then have "(erase ?l ?a, ?s) \<Rightarrow> ?s'" by auto
  ultimately have "(erase ?l ?w;; erase ?l ?a, ?s) \<Rightarrow> ?s'" by blast
  then have H1: "(erase ?l ?c, ?s) \<Rightarrow> ?s'" by simp
  have "?l \<turnstile> ?w" by (auto intro: sec_type.intros)
  then have "0 \<turnstile> ?w" by (intro anti_mono [of 2 _ 0]) auto
  moreover have "1 \<turnstile> ?a" by (auto intro: sec_type.intros)
  then have "0 \<turnstile> ?a" by (intro anti_mono [of 1 _ 0]) auto
  ultimately have H2: "0 \<turnstile> ?c" by (auto intro: sec_type.intros)
  have H3: "?s = ?s (< ?l)" by auto
  assume "\<forall>l c s s' t. (erase l c, s) \<Rightarrow> s' \<longrightarrow> 0 \<turnstile> c \<longrightarrow> s = t (< l) \<longrightarrow> (\<exists>t'. (c, t) \<Rightarrow> t' \<and> s' = t' (< l))"
  then obtain HC: "\<And>l c s s' t. \<lbrakk>(erase l c, s) \<Rightarrow> s'; 0 \<turnstile> c; s = t (< l)\<rbrakk> \<Longrightarrow> (\<exists>t'. (c, t) \<Rightarrow> t' \<and> s' = t' (< l))" by blast
  from HC [OF H1 H2 H3] obtain t' where "(?c, ?s) \<Rightarrow> t'" by blast
  then obtain ti where "(?w, ?s) \<Rightarrow> ti" by blast
  then show False
  by (induct ?w ?s ti rule: big_step_induct) auto
qed

text\<open> Give proofs or counterexamples.
\endexercise
\<close>

end