(* Title:      Residuated Boolean Algebras
   Author:     Victor Gomes <vborgesferreiragomes1 at sheffield.ac.uk>
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Residuated Boolean Algebras\<close>

theory Residuated_Boolean_Algebras
  imports Residuated_Lattices
begin

subsection \<open>Conjugation on Boolean Algebras\<close>

text \<open>
  Similarly, as in the previous section, we define the conjugation for
  arbitrary residuated functions on boolean algebras.
\<close>

context boolean_algebra
begin

lemma inf_bot_iff_le: "x \<sqinter> y = \<bottom> \<longleftrightarrow> x \<le> -y"
  by (metis le_iff_inf inf_sup_distrib1 inf_top_right sup_bot.left_neutral sup_compl_top compl_inf_bot inf.assoc inf_bot_right)

lemma le_iff_inf_bot: "x \<le> y \<longleftrightarrow> x \<sqinter> -y = \<bottom>"
  by (metis inf_bot_iff_le compl_le_compl_iff inf_commute)

lemma indirect_eq: "(\<And>z. x \<le> z \<longleftrightarrow> y \<le> z) \<Longrightarrow> x = y"
  by (metis eq_iff)

text \<open>
  Let $B$ be a boolean algebra. The maps $f$ and $g$ on $B$ are
  a pair of conjugates if and only if for all $x, y \in B$,
  $f(x) \sqcap y = \bot \Leftrightarrow x \sqcap g(t) = \bot$.
\<close>

definition conjugation_pair :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "conjugation_pair f g \<equiv> \<forall>x y. f(x) \<sqinter> y = \<bottom> \<longleftrightarrow> x \<sqinter> g(y) = \<bottom>"

lemma conjugation_pair_commute: "conjugation_pair f g \<Longrightarrow> conjugation_pair g f"
  by (auto simp: conjugation_pair_def inf_commute)

lemma conjugate_iff_residuated: "conjugation_pair f g = residuated_pair f (\<lambda>x. -g(-x))"
  apply (clarsimp simp: conjugation_pair_def residuated_pair_def inf_bot_iff_le)
  by (metis double_compl)

lemma conjugate_residuated: "conjugation_pair f g \<Longrightarrow> residuated_pair f (\<lambda>x. -g(-x))"
  by (metis conjugate_iff_residuated)

lemma residuated_iff_conjugate: "residuated_pair f g = conjugation_pair f (\<lambda>x. -g(-x))"
  apply (clarsimp simp: conjugation_pair_def residuated_pair_def inf_bot_iff_le)
  by (metis double_compl)

text \<open>
  A map $f$ has a conjugate pair if and only if it is residuated.
\<close>

lemma conj_residuatedI1: "\<exists>g. conjugation_pair f g \<Longrightarrow> residuated f"
  by (metis conjugate_iff_residuated residuated_def)

lemma conj_residuatedI2: "\<exists>g. conjugation_pair g f \<Longrightarrow> residuated f"
  by (metis conj_residuatedI1 conjugation_pair_commute)

lemma exist_conjugateI[intro]: "residuated f \<Longrightarrow> \<exists>g. conjugation_pair f g"
  by (metis residuated_def residuated_iff_conjugate)

lemma exist_conjugateI2[intro]: "residuated f \<Longrightarrow> \<exists>g. conjugation_pair g f"
  by (metis exist_conjugateI conjugation_pair_commute)

text \<open>
  The conjugate of a residuated function $f$ is unique.
\<close>

lemma unique_conjugate[intro]: "residuated f \<Longrightarrow> \<exists>!g. conjugation_pair f g"
proof -
  {
    fix g h x assume "conjugation_pair f g" and "conjugation_pair f h"
    hence "g = h"
      apply (unfold conjugation_pair_def)
      apply (rule ext)
      apply (rule antisym)
      by (metis le_iff_inf_bot inf_commute inf_compl_bot)+
  }
  moreover assume "residuated f"
  ultimately show ?thesis by force
qed

lemma unique_conjugate2[intro]: "residuated f \<Longrightarrow> \<exists>!g. conjugation_pair g f"
  by (metis unique_conjugate conjugation_pair_commute)

text \<open>
  Since the conjugate of a residuated map is unique, we define a
  conjugate operation.
\<close>

definition conjugate :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "conjugate f \<equiv> THE g. conjugation_pair g f"

lemma conjugate_iff_def: "residuated f \<Longrightarrow> f(x) \<sqinter> y = \<bottom> \<longleftrightarrow> x \<sqinter> conjugate f y = \<bottom>"
  apply (clarsimp simp: conjugate_def dest!: unique_conjugate)
  apply (subgoal_tac "(THE g. conjugation_pair g f) = g")
  apply (clarsimp simp add: conjugation_pair_def)
  apply (rule the1_equality)
  by (auto intro: conjugation_pair_commute)

lemma conjugateI1: "residuated f \<Longrightarrow> f(x) \<sqinter> y = \<bottom> \<Longrightarrow> x \<sqinter> conjugate f y = \<bottom>"
  by (metis conjugate_iff_def)

lemma conjugateI2: "residuated f \<Longrightarrow> x \<sqinter> conjugate f y = \<bottom> \<Longrightarrow> f(x) \<sqinter> y = \<bottom>"
  by (metis conjugate_iff_def)

text \<open>
  Few more lemmas about conjugation follow.
\<close>

lemma residuated_conj1: "residuated f \<Longrightarrow> conjugation_pair f (conjugate f)"
  using conjugateI1 conjugateI2 conjugation_pair_def by auto

lemma residuated_conj2: "residuated f \<Longrightarrow> conjugation_pair (conjugate f) f"
  using conjugateI1 conjugateI2 conjugation_pair_def inf_commute by auto

lemma conj_residuated: "residuated f \<Longrightarrow> residuated (conjugate f)"
  by (force dest!: residuated_conj2 intro: conj_residuatedI1)

lemma conj_involution: "residuated f \<Longrightarrow> conjugate (conjugate f) = f"
  by (metis conj_residuated residuated_conj1 residuated_conj2 unique_conjugate)

lemma residual_conj_eq: "residuated f \<Longrightarrow> residual (conjugate f) = (\<lambda>x. -f(-x))"
  apply (unfold residual_def)
  apply (rule the1_equality)
  apply (rule residual_unique)
  apply (auto intro: conj_residuated conjugate_residuated residuated_conj2)
done

lemma residual_conj_eq_ext: "residuated f \<Longrightarrow> residual (conjugate f) x = -f(-x)"
  by (metis residual_conj_eq)

lemma conj_iso: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> conjugate f x \<le> conjugate f y"
  by (metis conj_residuated res_iso)

lemma conjugate_strict: "residuated f \<Longrightarrow> conjugate f \<bottom> = \<bottom>"
  by (metis conj_residuated residuated_strict)

lemma conjugate_sup: "residuated f \<Longrightarrow> conjugate f (x \<squnion> y) = conjugate f x \<squnion> conjugate f y"
  by (metis conj_residuated residuated_sup)

lemma conjugate_subinf: "residuated f \<Longrightarrow> conjugate f (x \<sqinter> y) \<le> conjugate f x \<sqinter> conjugate f y"
  by (auto simp: conj_iso)

text \<open>
  Next we prove some lemmas from Maddux's article. Similar lemmas have been proved in AFP entry
  for relation algebras. They should be consolidated in the future.
\<close>

lemma maddux1: "residuated f \<Longrightarrow> f(x \<sqinter> - conjugate f(y)) \<le> f(x) \<sqinter> -y"
proof -
  assume assm: "residuated f"
  hence "f(x \<sqinter> - conjugate f(y)) \<le> f x"
    by (metis inf_le1 res_iso)
  moreover have "f(x \<sqinter> - conjugate f (y)) \<sqinter> y = \<bottom>"
    by (metis assm conjugateI2 inf_bot_iff_le inf_le2)
  ultimately show ?thesis
    by (metis inf_bot_iff_le le_inf_iff)
qed

lemma maddux1': "residuated f \<Longrightarrow> conjugate f(x \<sqinter> -f(y)) \<le> conjugate f(x) \<sqinter> -y"
  by (metis conj_involution conj_residuated maddux1)

lemma maddux2: "residuated f \<Longrightarrow> f(x) \<sqinter> y \<le> f(x \<sqinter> conjugate f y)"
proof -
  assume resf: "residuated f"
  obtain z where z_def: "z = f(x \<sqinter> conjugate f y)" by auto
  hence "f(x \<sqinter> conjugate f y) \<sqinter> -z = \<bottom>"
    by (metis inf_compl_bot)
  hence "x \<sqinter> conjugate f y \<sqinter> conjugate f (-z) = \<bottom>"
    by (metis conjugate_iff_def resf)
  hence "x \<sqinter> conjugate f (y \<sqinter> -z) = \<bottom>"
    apply (subgoal_tac "conjugate f (y \<sqinter> -z) \<le> conjugate f y \<sqinter> conjugate f (-z)")
    apply (metis (no_types, hide_lams) dual_order.trans inf.commute inf_bot_iff_le inf_left_commute)
    by (metis conj_iso inf_le2 inf_top.left_neutral le_inf_iff resf)
  hence "f(x) \<sqinter> y \<sqinter> -z = \<bottom>"
    by (metis conjugateI2 inf.assoc resf)
  thus ?thesis
    by (metis double_compl inf_bot_iff_le z_def)
qed

lemma maddux2': "residuated f \<Longrightarrow> conjugate f(x) \<sqinter> y \<le> conjugate f(x \<sqinter> f y)"
  by (metis conj_involution conj_residuated maddux2)

lemma residuated_conjugate_ineq: "residuated f \<Longrightarrow> conjugate f x \<le> y \<longleftrightarrow> x \<le> -f(-y)"
  by (metis conj_residuated residual_galois residual_conj_eq)

lemma residuated_comp_closed: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> residuated (f o g)"
  by (auto simp add: residuated_def residuated_pair_def)

lemma conjugate_comp: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> conjugate (f o g) = conjugate g o conjugate f"
proof (rule ext, rule indirect_eq)
  fix x y
  assume assms: "residuated f" "residuated g"
  have "conjugate (f o g) x \<le> y \<longleftrightarrow> x \<le> -f(g(-y))"
    apply (subst residuated_conjugate_ineq)
    using assms by (auto intro!: residuated_comp_closed)
  also have "... \<longleftrightarrow> conjugate g (conjugate f x) \<le> y"
    using assms by (simp add: residuated_conjugate_ineq)
  finally show "(conjugate (f \<circ> g) x \<le> y) = ((conjugate g \<circ> conjugate f) x \<le> y)"
    by auto
qed

lemma conjugate_comp_ext: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> conjugate (\<lambda>x. f (g x)) x = conjugate g (conjugate f x)"
  using conjugate_comp by (simp add: comp_def)

end (* boolean_algebra *)

context complete_boolean_algebra begin

text \<open>
  On a complete boolean algebra, it is possible to give an explicit
  definition of conjugation.
\<close>

lemma conjugate_eq: "residuated f \<Longrightarrow> conjugate f y = \<Sqinter>{x. y \<le> -f(-x)}"
proof -
  assume assm: "residuated f" obtain g where g_def: "g = conjugate f" by auto
  have "g y = \<Sqinter>{x. x \<ge> g y}"
    by (auto intro!: antisym Inf_lower Inf_greatest)
  also have "... = \<Sqinter>{x. -x \<sqinter> g y = \<bottom>}"
    by (simp add: inf_bot_iff_le)
  also have "... = \<Sqinter>{x. f(-x) \<sqinter> y = \<bottom>}"
    by (metis conjugate_iff_def assm g_def)
  finally show ?thesis
    by (simp add: g_def le_iff_inf_bot inf_commute)
qed

end (* complete_boolean_algebra *)

subsection \<open>Residuated Boolean Structures\<close>

text \<open>
  In this section, we present various residuated structures based on
  boolean algebras.
  The left and right conjugation of the multiplicative operation is
  defined, and a number of facts is derived.
\<close>

class residuated_boolean_algebra = boolean_algebra + residuated_pogroupoid
begin

subclass residuated_lgroupoid ..

definition conjugate_l :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<lhd>" 60) where
  "x \<lhd> y \<equiv> -(-x \<leftarrow> y)"

definition conjugate_r :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<rhd>" 60) where
  "x \<rhd> y \<equiv> -(x \<rightarrow> -y)"

lemma residual_conjugate_r: "x \<rightarrow> y = -(x \<rhd> -y)"
  by (metis conjugate_r_def double_compl)

lemma residual_conjugate_l: "x \<leftarrow> y = -(-x \<lhd> y)"
  by (metis conjugate_l_def double_compl)

lemma conjugation_multl: "x\<cdot>y \<sqinter> z = \<bottom> \<longleftrightarrow> x \<sqinter> (z \<lhd> y) = \<bottom>"
  by (metis conjugate_l_def double_compl le_iff_inf_bot resl_galois)

lemma conjugation_multr: "x\<cdot>y \<sqinter> z = \<bottom> \<longleftrightarrow> y \<sqinter> (x \<rhd> z) = \<bottom>"
  by (metis conjugate_r_def inf_bot_iff_le le_iff_inf_bot resr_galois)

lemma conjugation_conj: "(x \<lhd> y) \<sqinter> z = \<bottom> \<longleftrightarrow> y \<sqinter> (z \<rhd> x) = \<bottom>"
  by (metis inf_commute conjugation_multr conjugation_multl)

lemma conjugation_pair_multl [simp]: "conjugation_pair (\<lambda>x. x\<cdot>y) (\<lambda>x. x \<lhd> y)"
  by (simp add: conjugation_pair_def conjugation_multl)

lemma conjugation_pair_multr [simp]: "conjugation_pair (\<lambda>x. y\<cdot>x) (\<lambda>x. y \<rhd> x)"
  by (simp add: conjugation_pair_def conjugation_multr)

lemma conjugation_pair_conj [simp]: "conjugation_pair (\<lambda>x. y \<lhd> x) (\<lambda>x. x \<rhd> y)"
  by (simp add: conjugation_pair_def conjugation_conj)

lemma residuated_conjl1 [simp]: "residuated (\<lambda>x. x \<lhd> y)"
  by (metis conj_residuatedI2 conjugation_pair_multl)

lemma residuated_conjl2 [simp]: "residuated (\<lambda>x. y \<lhd> x)"
  by (metis conj_residuatedI1 conjugation_pair_conj)

lemma residuated_conjr1 [simp]: "residuated (\<lambda>x. y \<rhd> x)"
  by (metis conj_residuatedI2 conjugation_pair_multr)

lemma residuated_conjr2 [simp]: "residuated (\<lambda>x. x \<rhd> y)"
  by (metis conj_residuatedI2 conjugation_pair_conj)

lemma conjugate_multr [simp]: "conjugate (\<lambda>x. y\<cdot>x) = (\<lambda>x. y \<rhd> x)"
  by (metis conjugation_pair_multr residuated_conj1 residuated_multr unique_conjugate)

lemma conjugate_conjr1 [simp]: "conjugate (\<lambda>x. y \<rhd> x) = (\<lambda>x. y\<cdot>x)"
  by (metis conjugate_multr conj_involution residuated_multr)

lemma conjugate_multl [simp]: "conjugate (\<lambda>x. x\<cdot>y) = (\<lambda>x. x \<lhd> y)"
  by (metis conjugation_pair_multl residuated_conj1 residuated_multl unique_conjugate)

lemma conjugate_conjl1 [simp]: "conjugate (\<lambda>x. x \<lhd> y) = (\<lambda>x. x\<cdot>y)"
proof -
  have "conjugate (conjugate (\<lambda>x. x\<cdot>y)) = conjugate (\<lambda>x. x \<lhd> y)" by simp
  thus ?thesis
    by (metis conj_involution[OF residuated_multl])
qed

lemma conjugate_conjl2[simp]: "conjugate (\<lambda>x. y \<lhd> x) = (\<lambda>x. x \<rhd> y)"
  by (metis conjugation_pair_conj unique_conjugate residuated_conj1 residuated_conjl2)

lemma conjugate_conjr2[simp]: "conjugate (\<lambda>x. x \<rhd> y) = (\<lambda>x. y \<lhd> x)"
proof -
  have "conjugate (conjugate (\<lambda>x. y \<lhd> x)) = conjugate (\<lambda>x. x \<rhd> y)" by simp
  thus ?thesis
    by (metis conj_involution[OF residuated_conjl2])
qed

lemma conjl1_iso: "x \<le> y \<Longrightarrow> x \<lhd> z \<le> y \<lhd> z"
  by (metis conjugate_l_def compl_mono resl_iso)

lemma conjl2_iso: "x \<le> y \<Longrightarrow> z \<lhd> x \<le> z \<lhd> y"
  by (metis res_iso residuated_conjl2)

lemma conjr1_iso: "x \<le> y \<Longrightarrow> z \<rhd> x \<le> z \<rhd> y"
  by (metis res_iso residuated_conjr1)

lemma conjr2_iso: "x \<le> y \<Longrightarrow> x \<rhd> z \<le> y \<rhd> z"
  by (metis conjugate_r_def compl_mono resr_antitonel)

lemma conjl1_sup: "z \<lhd> (x \<squnion> y) = (z \<lhd> x) \<squnion> (z \<lhd> y)"
  by (metis conjugate_l_def compl_inf resl_distr)

lemma conjl2_sup: "(x \<squnion> y) \<lhd> z = (x \<lhd> z) \<squnion> (y \<lhd> z)"
  by (metis (poly_guards_query) residuated_sup residuated_conjl1)

lemma conjr1_sup: "z \<rhd> (x \<squnion> y) = (z \<rhd> x) \<squnion> (z \<rhd> y)"
  by (metis residuated_sup residuated_conjr1)

lemma conjr2_sup: "(x \<squnion> y) \<rhd> z = (x \<rhd> z) \<squnion> (y \<rhd> z)"
  by (metis conjugate_r_def compl_inf resr_distl)

lemma conjl1_strict: "\<bottom> \<lhd> x = \<bottom>"
  by (metis residuated_strict residuated_conjl1)

lemma conjl2_strict: "x \<lhd> \<bottom> = \<bottom>"
  by (metis residuated_strict residuated_conjl2)

lemma conjr1_strict: "\<bottom> \<rhd> x = \<bottom>"
  by (metis residuated_strict residuated_conjr2)

lemma conjr2_strict: "x \<rhd> \<bottom> = \<bottom>"
  by (metis residuated_strict residuated_conjr1)

lemma conjl1_iff: "x \<lhd> y \<le> z \<longleftrightarrow> x \<le> -(-z\<cdot>y)"
  by (metis conjugate_l_def compl_le_swap1 compl_le_swap2 resl_galois)

lemma conjl2_iff: "x \<lhd> y \<le> z \<longleftrightarrow> y \<le> -(-z \<rhd> x)"
  by (metis conjl1_iff conjugate_r_def compl_le_swap2 double_compl resr_galois)

lemma conjr1_iff: "x \<rhd> y \<le> z \<longleftrightarrow> y \<le> -(x\<cdot>-z)"
  by (metis conjugate_r_def compl_le_swap1 double_compl resr_galois)

lemma conjr2_iff: "x \<rhd> y \<le> z \<longleftrightarrow> x \<le> -(y \<lhd> -z)"
  by (metis conjugation_conj double_compl inf.commute le_iff_inf_bot)

text \<open>
  We apply Maddux's lemmas regarding conjugation of an arbitrary residuated function
  for each of the 6 functions.
\<close>

lemma maddux1a: "a\<cdot>(x \<sqinter> -(a \<rhd> y)) \<le> a\<cdot>x"
  by (insert maddux1 [of "\<lambda>x. a\<cdot>x"]) simp

lemma maddux1a': "a\<cdot>(x \<sqinter> -(a \<rhd> y)) \<le> -y"
  by (insert maddux1 [of "\<lambda>x. a\<cdot>x"]) simp

lemma maddux1b: "(x \<sqinter> -(y \<lhd> a))\<cdot>a \<le> x\<cdot>a"
  by (insert maddux1 [of "\<lambda>x. x\<cdot>a"]) simp

lemma maddux1b': "(x \<sqinter> -(y \<lhd> a))\<cdot>a \<le> -y"
  by (insert maddux1 [of "\<lambda>x. x\<cdot>a"]) simp

lemma maddux1c: " a \<lhd> x \<sqinter> -(y \<rhd> a) \<le> a \<lhd> x"
  by (insert maddux1 [of "\<lambda>x. a \<lhd> x"]) simp

lemma maddux1c': "a \<lhd> x \<sqinter> -(y \<rhd> a) \<le> -y"
  by (insert maddux1 [of "\<lambda>x. a \<lhd> x"]) simp

lemma maddux1d: "a \<rhd> x \<sqinter> -(a\<cdot>y) \<le> a \<rhd> x"
  by (insert maddux1 [of "\<lambda>x. a \<rhd> x"]) simp

lemma maddux1d': "a \<rhd> x \<sqinter> -(a\<cdot>y) \<le> -y"
  by (insert maddux1 [of "\<lambda>x. a \<rhd> x"]) simp

lemma maddux1e: "x \<sqinter> -(y\<cdot>a) \<lhd> a \<le> x \<lhd> a"
  by (insert maddux1 [of "\<lambda>x. x \<lhd> a"]) simp

lemma maddux1e': "x \<sqinter> -(y\<cdot>a) \<lhd> a \<le> -y"
  by (insert maddux1 [of "\<lambda>x. x \<lhd> a"]) simp

lemma maddux1f: "x \<sqinter> -(a \<lhd> y) \<rhd> a \<le> x \<rhd> a"
  by (insert maddux1 [of "\<lambda>x. x \<rhd> a"]) simp

lemma maddux1f': "x \<sqinter> -(a \<lhd> y) \<rhd> a \<le> -y"
  by (insert maddux1 [of "\<lambda>x. x \<rhd> a"]) simp

lemma maddux2a: "a\<cdot>x \<sqinter> y \<le> a\<cdot>(x \<sqinter> (a \<rhd> y))"
  by (insert maddux2 [of "\<lambda>x. a\<cdot>x"]) simp

lemma maddux2b: "x\<cdot>a \<sqinter> y \<le> (x \<sqinter> (y \<lhd> a))\<cdot>a"
  by (insert maddux2 [of "\<lambda>x. x\<cdot>a"]) simp

lemma maddux2c: "(a \<lhd> x) \<sqinter> y \<le> a \<lhd> (x \<sqinter> (y \<rhd> a))"
  by (insert maddux2 [of "\<lambda>x. a \<lhd> x"]) simp

lemma maddux2d: "(a \<rhd> x) \<sqinter> y \<le> a \<rhd> (x \<sqinter> a\<cdot>y)"
  by (insert maddux2 [of "\<lambda>x. a \<rhd> x"]) simp

lemma maddux2e: "(x \<lhd> a) \<sqinter> y \<le> (x \<sqinter> y\<cdot>a) \<lhd> a"
  by (insert maddux2 [of "\<lambda>x. x \<lhd> a"]) simp

lemma maddux2f: "(x \<rhd> a) \<sqinter> y \<le> (x \<sqinter> (a \<lhd> y)) \<rhd> a"
  by (insert maddux2 [of "\<lambda>x. x \<rhd> a"]) simp

text \<open>
  The multiplicative operation $\cdot$ on a residuated boolean algebra is generally not
  associative. We prove some equivalences related to associativity.
\<close>

lemma res_assoc_iff1: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z)"
proof safe
  fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
  thus "x \<rhd> (y \<rhd> z) = y \<cdot> x \<rhd> z"
    using conjugate_comp_ext[of "\<lambda>z. y\<cdot>z" "\<lambda>z. x\<cdot>z"] by auto
next
  fix x y z assume "\<forall>x y z. x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z"
  thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
    using conjugate_comp_ext[of "\<lambda>z. y \<rhd> z" "\<lambda>z. x \<rhd> z"] by auto
qed

lemma res_assoc_iff2: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y)"
proof safe
  fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
  hence "\<forall>x y z. (x\<cdot>y)\<cdot>z = x\<cdot>(y\<cdot>z)" by simp
  thus "x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
    using conjugate_comp_ext[of "\<lambda>x. x\<cdot>z" "\<lambda>x. x\<cdot>y"] by auto
next
  fix x y z assume "\<forall>x y z. x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
  hence "\<forall>x y z. (x \<lhd> z) \<lhd> y = x \<lhd> (y \<cdot> z)" by simp
  thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
    using conjugate_comp_ext[of "\<lambda>z. z \<lhd> y" "\<lambda>x. x \<lhd> z"] by auto
qed

lemma res_assoc_iff3: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. (x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z))"
proof safe
  fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
  thus "(x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
    using conjugate_comp_ext[of "\<lambda>u. x\<cdot>u" "\<lambda>u. u\<cdot>z"] and
    conjugate_comp_ext[of "\<lambda>u. u\<cdot>z" "\<lambda>u. x\<cdot>u", symmetric]
    by auto
next
  fix x y z assume "\<forall>x y z. (x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
  thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
    using conjugate_comp_ext[of "\<lambda>u. x \<rhd> u" "\<lambda>u. u \<lhd> z"] and
    conjugate_comp_ext[of "\<lambda>u. u \<lhd> z" "\<lambda>u. x \<rhd> u", symmetric]
    by auto
qed

end (* residuated_boolean_algebra *)

class unital_residuated_boolean = residuated_boolean_algebra + one +
  assumes mult_onel [simp]: "x\<cdot>1 = x"
  and mult_oner [simp]: "1\<cdot>x = x"
begin

text \<open>
  The following equivalences are taken from J{\'o}sson and Tsinakis.
\<close>

lemma jonsson1a: "(\<exists>f. \<forall>x y. x \<rhd> y = f(x)\<cdot>y) \<longleftrightarrow> (\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y)"
  apply standard
  apply force
  apply (rule_tac x="\<lambda>x. x \<rhd> 1" in exI)
  apply force
  done

lemma jonsson1b: "(\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y) \<longleftrightarrow> (\<forall>x y. x\<cdot>y = (x \<rhd> 1) \<rhd> y)"
proof safe
  fix x y
  assume "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
  hence "conjugate (\<lambda>y. x \<rhd> y) = conjugate (\<lambda>y. (x \<rhd> 1)\<cdot>y)" by metis
  thus "x\<cdot>y = (x \<rhd> 1) \<rhd> y" by simp
next
  fix x y
  assume "\<forall>x y. x \<cdot> y = x \<rhd> 1 \<rhd> y"
  thus "x \<rhd> y = (x \<rhd> 1) \<cdot> y"
    by (metis mult_onel)
qed

lemma jonsson1c: "(\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y) \<longleftrightarrow> (\<forall>x y. y \<lhd> x = 1 \<lhd> (x \<lhd> y))"
proof safe
  fix x y
  assume "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
  hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. (x \<rhd> 1)\<cdot>y)" by metis
  hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. x\<cdot>y) o (\<lambda>x. x \<rhd> 1)" by force
  hence "conjugate (\<lambda>x. y \<lhd> x) = (\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x)" by simp
  hence "conjugate (conjugate (\<lambda>x. y \<lhd> x)) = conjugate ((\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x))" by simp
  hence "(\<lambda>x. y \<lhd> x) = conjugate ((\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x))" by simp
  also have "... = conjugate (conjugate (\<lambda>x. 1 \<lhd> x)) o conjugate (\<lambda>x. x\<cdot>y)"
    by (subst conjugate_comp[symmetric]) simp_all
  finally show "y \<lhd> x = 1 \<lhd> (x \<lhd> y)" by simp
next
  fix x y
  assume "\<forall>x y. y \<lhd> x = 1 \<lhd> (x \<lhd> y)"
  hence "(\<lambda>x. y \<lhd> x) = (\<lambda>x. 1 \<lhd> (x \<lhd> y))" by metis
  hence "(\<lambda>x. y \<lhd> x) = (\<lambda>x. 1 \<lhd> x) o conjugate (\<lambda>x. x\<cdot>y)" by force
  hence "conjugate (\<lambda>x. y \<lhd> x) = conjugate ((\<lambda>x. 1 \<lhd> x) o conjugate (\<lambda>x. x\<cdot>y))" by metis
  also have "... = conjugate (conjugate (\<lambda>x. x\<cdot>y)) o conjugate (\<lambda>x. 1 \<lhd> x)"
    by (subst conjugate_comp[symmetric]) simp_all
  finally have "(\<lambda>x. x \<rhd> y) = (\<lambda>x. x\<cdot>y) o (\<lambda>x. x \<rhd> 1)" by simp
  hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. (x \<rhd> 1) \<cdot> y)" by (simp add: comp_def)
  thus "x \<rhd> y = (x \<rhd> 1) \<cdot> y" by metis
qed

lemma jonsson2a: "(\<exists>g. \<forall>x y. x \<lhd> y = x\<cdot>g(y)) \<longleftrightarrow> (\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y))"
  apply standard
  apply force
  apply (rule_tac x="\<lambda>x. 1 \<lhd> x" in exI)
  apply force
  done

lemma jonsson2b: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. x\<cdot>y = x \<lhd> (1 \<lhd> y))"
proof safe
  fix x y
  assume "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
  hence "conjugate (\<lambda>x. x \<lhd> y) = conjugate (\<lambda>x. x\<cdot>(1 \<lhd> y))" by metis
  thus "x\<cdot>y = x \<lhd> (1 \<lhd> y)" by simp metis
next
  fix x y
  assume "\<forall>x y. x\<cdot>y = x \<lhd> (1 \<lhd> y)"
  hence "(\<lambda>x. x\<cdot>y) = (\<lambda>x. x \<lhd> (1 \<lhd> y))" by metis
  hence "conjugate (\<lambda>x. x\<cdot>y) = conjugate (\<lambda>x. x \<lhd> (1 \<lhd> y))" by metis
  thus "x \<lhd> y = x \<cdot> (1 \<lhd> y)" by simp metis
qed

lemma jonsson2c: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. y \<rhd> x = (x \<rhd> y) \<rhd> 1)"
proof safe
  fix x y
  assume "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
  hence "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>(1 \<lhd> y))" by metis
  hence "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>y) o (\<lambda>y. 1 \<lhd> y)" by force
  hence "conjugate (\<lambda>y. y \<rhd> x) = (\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1)" by force
  hence "conjugate (conjugate (\<lambda>y. y \<rhd> x)) = conjugate ((\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1))" by metis
  hence "(\<lambda>y. y \<rhd> x) = conjugate ((\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1))" by simp
  also have "... = conjugate (conjugate (\<lambda>y. y \<rhd> 1)) o conjugate (\<lambda>y. x\<cdot>y)"
    by (subst conjugate_comp[symmetric]) simp_all
  finally have "(\<lambda>y. y \<rhd> x) = (\<lambda>y. x \<rhd> y \<rhd> 1)" by (simp add: comp_def)
  thus "y \<rhd> x = x \<rhd> y \<rhd> 1" by metis
next
  fix x y
  assume "\<forall>x y. y \<rhd> x = x \<rhd> y \<rhd> 1"
  hence "(\<lambda>y. y \<rhd> x) = (\<lambda>y. x \<rhd> y \<rhd> 1)" by force
  hence "(\<lambda>y. y \<rhd> x) = (\<lambda>y. y \<rhd> 1) o conjugate (\<lambda>y. x\<cdot>y)" by force
  hence "conjugate (\<lambda>y. y \<rhd> x) = conjugate ((\<lambda>y. y \<rhd> 1) o conjugate (\<lambda>y. x\<cdot>y))" by metis
  also have "... = conjugate (conjugate (\<lambda>y. x\<cdot>y)) o conjugate (\<lambda>y. y \<rhd> 1)"
    by (subst conjugate_comp[symmetric]) simp_all
  finally have "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>y) o (\<lambda>y. 1 \<lhd> y)"
    by (metis conjugate_conjr1 conjugate_conjr2 conjugate_multr)
  thus "x \<lhd> y = x \<cdot> (1 \<lhd> y)" by (simp add: comp_def)
qed

lemma jonsson3a: "(\<forall>x. (x \<rhd> 1) \<rhd> 1 = x) \<longleftrightarrow> (\<forall>x. 1 \<lhd> (1 \<lhd> x) = x)"
proof safe
  fix x assume "\<forall>x. x \<rhd> 1 \<rhd> 1 = x"
  thus "1 \<lhd> (1 \<lhd> x) = x"
    by (metis compl_le_swap1 compl_le_swap2 conjr2_iff eq_iff)
next
  fix x assume "\<forall>x. 1 \<lhd> (1 \<lhd> x) = x"
  thus "x \<rhd> 1 \<rhd> 1 = x"
    by (metis conjugate_l_def conjugate_r_def double_compl jipsen2r)
qed

lemma jonsson3b: "(\<forall>x. (x \<rhd> 1) \<rhd> 1 = x) \<Longrightarrow> (x \<sqinter> y) \<rhd> 1 = (x \<rhd> 1) \<sqinter> (y \<rhd> 1)"
proof (rule antisym, auto simp: conjr2_iso)
  assume assm: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x"
  hence "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1 = x \<sqinter> (((x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1) \<sqinter> y)"
    by (metis (no_types) conjr2_iso inf.cobounded2 inf.commute inf.orderE)
  hence "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1 \<le> x \<sqinter> y"
    using inf.orderI inf_left_commute by presburger
  thus "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<le> x \<sqinter> y \<rhd> 1"
    using assm by (metis (no_types) conjr2_iso)
qed

lemma jonsson3c: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x \<Longrightarrow> x \<rhd> 1 = 1 \<lhd> x"
proof (rule indirect_eq)
  fix z
  assume assms: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x"
  hence "(x \<rhd> 1) \<sqinter> -z = \<bottom> \<longleftrightarrow> ((x \<rhd> 1) \<sqinter> -z) \<rhd> 1 = \<bottom>"
    by (metis compl_sup conjugation_conj double_compl inf_bot_right sup_bot.left_neutral)
  also have "... \<longleftrightarrow> -z\<cdot>x \<sqinter> 1 = \<bottom>"
    by (metis assms jonsson3b conjugation_multr)
  finally have "(x \<rhd> 1) \<sqinter> -z = \<bottom> \<longleftrightarrow> (1 \<lhd> x) \<sqinter> -z = \<bottom>"
    by (metis conjugation_multl inf.commute)
  thus "(x \<rhd> 1 \<le> z) \<longleftrightarrow> (1 \<lhd> x \<le> z)"
    by (metis le_iff_inf_bot)
qed

end (* unital_residuated_boolean *)

class residuated_boolean_semigroup = residuated_boolean_algebra + semigroup_mult
begin

subclass residuated_boolean_algebra ..

text \<open>
  The following lemmas hold trivially, since they are equivalent to associativity.
\<close>

lemma res_assoc1: "x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z"
  by (metis res_assoc_iff1 mult_assoc)

lemma res_assoc2: "x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
  by (metis res_assoc_iff2 mult_assoc)

lemma res_assoc3: "(x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
  by (metis res_assoc_iff3 mult_assoc)

end (*residuated_boolean_semigroup *)

class residuated_boolean_monoid = residuated_boolean_algebra + monoid_mult
begin

subclass unital_residuated_boolean
  by standard auto

subclass residuated_lmonoid ..

lemma jonsson4: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y)"
proof safe
  fix x y assume assms: "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
  have "x \<rhd> y = (y \<rhd> x) \<rhd> 1"
    by (metis assms jonsson2c)
  also have "... = (y \<rhd> ((x \<rhd> 1) \<rhd> 1)) \<rhd> 1"
    by (metis assms jonsson2b jonsson3a mult_oner)
  also have "... = (((x \<rhd> 1)\<cdot>y) \<rhd> 1) \<rhd> 1"
    by (metis conjugate_r_def double_compl resr3)
  also have "... = (x \<rhd> 1)\<cdot>y"
    by (metis assms jonsson2b jonsson3a mult_oner)
  finally show "x \<rhd> y = (x \<rhd> 1)\<cdot>y" .
next
  fix x y assume assms: "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
  have "y \<lhd> x = 1 \<lhd> (x \<lhd> y)"
    by (metis assms jonsson1c)
  also have "... = 1 \<lhd> ((1 \<lhd> (1 \<lhd> x)) \<lhd> y)"
    by (metis assms conjugate_l_def double_compl jonsson1c mult_1_right resl3)
  also have "... = 1 \<lhd> (1 \<lhd> (y\<cdot>(1 \<lhd> x)))"
    by (metis conjugate_l_def double_compl resl3)
  also have "... = y\<cdot>(1 \<lhd> x)"
    by (metis assms jonsson1b jonsson1c jonsson3c mult_onel)
  finally show "y \<lhd> x = y\<cdot>(1 \<lhd> x)".
qed

end (* residuated_boolean_monoid *)

end


(*
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
                Tobias Nipkow, TUM
*)

theory Tilings imports Main begin

section\<open>Inductive Tiling\<close>

inductive_set
  tiling :: "'a set set \<Rightarrow> 'a set set"
  for A :: "'a set set" where
empty [simp, intro]: "{} \<in> tiling A" |
Un [simp, intro]:    "\<lbrakk> a \<in> A; t \<in> tiling A; a \<inter> t = {} \<rbrakk>
                         \<Longrightarrow> a \<union> t \<in> tiling A"

lemma tiling_UnI [intro]:
  "\<lbrakk> t \<in> tiling A; u \<in> tiling A; t \<inter> u = {} \<rbrakk> \<Longrightarrow>  t \<union> u \<in> tiling A"
apply (induct set: tiling)
apply (auto simp add: Un_assoc)
done

lemma tiling_Diff1E:
assumes "t-a \<in> tiling A" and "a \<in> A" and "a \<subseteq> t"
shows "t \<in> tiling A"
proof -
  from assms(2-3) have  "\<exists>r. t = r Un a & r Int a = {}"
    by (metis Diff_disjoint Int_commute Un_Diff_cancel Un_absorb1 Un_commute)
  thus ?thesis using assms(1,2)
    by (auto simp:Un_Diff)
       (metis Compl_Diff_eq Diff_Compl Diff_empty Int_commute Un_Diff_cancel
              Un_commute double_complement tiling.Un)
qed

lemma tiling_finite:
  assumes "\<And>a. a \<in> A \<Longrightarrow> finite a"
  shows "t \<in> tiling A \<Longrightarrow> finite t"
apply (induct set: tiling)
using assms apply auto
done

section\<open>The Mutilated Chess Board Cannot be Tiled by Dominoes\<close>

text \<open>The originator of this problem is Max Black, according to J A
Robinson. It was popularized as the \emph{Mutilated Checkerboard Problem} by
J McCarthy.\<close>

inductive_set domino :: "(nat \<times> nat) set set" where
horiz [simp]: "{(i, j), (i, Suc j)} \<in> domino" |
vertl [simp]: "{(i, j), (Suc i, j)} \<in> domino"

lemma domino_finite: "d \<in> domino \<Longrightarrow> finite d"
by (erule domino.cases, auto)

declare tiling_finite[OF domino_finite, simp]

text \<open>\medskip Sets of squares of the given colour\<close>

definition
  coloured :: "nat \<Rightarrow> (nat \<times> nat) set" where
  "coloured b = {(i, j). (i + j) mod 2 = b}"

abbreviation
  whites  :: "(nat \<times> nat) set" where
  "whites \<equiv> coloured 0"

abbreviation
  blacks  :: "(nat \<times> nat) set" where
  "blacks \<equiv> coloured (Suc 0)"

text \<open>\medskip Chess boards\<close>

lemma Sigma_Suc1 [simp]:
  "{0..< Suc n} \<times> B = ({n} \<times> B) \<union> ({0..<n} \<times> B)"
by auto

lemma Sigma_Suc2 [simp]:
  "A \<times> {0..< Suc n} = (A \<times> {n}) \<union> (A \<times> {0..<n})"
by auto

lemma dominoes_tile_row [intro!]: "{i} \<times> {0..< 2*n} \<in> tiling domino"
apply (induct n)
apply (simp_all del:Un_insert_left add: Un_assoc [symmetric])
done

lemma dominoes_tile_matrix: "{0..<m} \<times> {0..< 2*n} \<in> tiling domino"
by (induct m) auto

text \<open>\medskip @{term coloured} and Dominoes\<close>

lemma coloured_insert [simp]:
  "coloured b \<inter> (insert (i, j) t) =
   (if (i + j) mod 2 = b then insert (i, j) (coloured b \<inter> t)
    else coloured b \<inter> t)"
by (auto simp add: coloured_def)

lemma domino_singletons:
  "d \<in> domino \<Longrightarrow>
   (\<exists>i j. whites \<inter> d = {(i, j)}) \<and>
   (\<exists>m n. blacks \<inter> d = {(m, n)})"
apply (erule domino.cases)
 apply (auto simp add: mod_Suc)
done

text \<open>\medskip Tilings of dominoes\<close>

declare
  Int_Un_distrib [simp]
  Diff_Int_distrib [simp]

lemma tiling_domino_0_1:
  "t \<in> tiling domino ==> card(whites \<inter> t) = card(blacks \<inter> t)"
apply (induct set: tiling)
 apply (drule_tac [2] domino_singletons)
 apply (auto)
apply (subgoal_tac "\<forall>p C. C \<inter> a = {p} --> p \<notin> t")
  \<comment> \<open>this lemma tells us that both ``inserts'' are non-trivial\<close>
 apply (simp (no_asm_simp))
apply blast
done

text \<open>\medskip Final argument is surprisingly complex\<close>

theorem gen_mutil_not_tiling:
  "t \<in> tiling domino ==>
  (i + j) mod 2 = 0 ==> (m + n) mod 2 = 0 ==>
  {(i, j), (m, n)} \<subseteq> t
  ==> (t - {(i,j)} - {(m,n)}) \<notin> tiling domino"
apply (rule notI)
apply (subgoal_tac
  "card (whites \<inter> (t - {(i,j)} - {(m,n)})) <
   card (blacks \<inter> (t - {(i,j)} - {(m,n)}))")
 apply (force simp only: tiling_domino_0_1)
apply (simp add: tiling_domino_0_1 [symmetric])
apply (simp add: coloured_def card_Diff2_less)
done

text \<open>Apply the general theorem to the well-known case\<close>

theorem mutil_not_tiling:
  "t = {0..< 2 * Suc m} \<times> {0..< 2 * Suc n}
   ==> t - {(0,0)} - {(Suc(2 * m), Suc(2 * n))} \<notin> tiling domino"
apply (rule gen_mutil_not_tiling)
 apply (blast intro!: dominoes_tile_matrix)
apply auto
done

section\<open>The Mutilated Chess Board Can be Tiled by Ls\<close>

text\<open>Remove a arbitrary square from a chess board of size $2^n \times 2^n$.
The result can be tiled by L-shaped tiles:
\begin{picture}(8,8)
\put(0,0){\framebox(4,4){}}
\put(4,0){\framebox(4,4){}}
\put(0,4){\framebox(4,4){}}
\end{picture}.
The four possible L-shaped tiles are obtained by dropping
one of the four squares from $\{(x,y),(x+1,y),(x,y+1),(x+1,y+1)\}$:\<close>

definition "L2 (x::nat) (y::nat) = {(x,y), (x+1,y), (x, y+1)}"
definition "L3 (x::nat) (y::nat) = {(x,y), (x+1,y), (x+1, y+1)}"
definition "L0 (x::nat) (y::nat) = {(x+1,y), (x,y+1), (x+1, y+1)}"
definition "L1 (x::nat) (y::nat) = {(x,y), (x,y+1), (x+1, y+1)}"

text\<open>All tiles:\<close>

definition Ls :: "(nat * nat) set set" where
"Ls \<equiv> { L0 x y | x y. True} \<union> { L1 x y | x y. True} \<union>
      { L2 x y | x y. True} \<union> { L3 x y | x y. True}"

lemma LinLs: "L0 i j : Ls & L1 i j : Ls & L2 i j : Ls & L3 i j : Ls"
by(fastforce simp:Ls_def)

text\<open>Square $2^n \times 2^n$ grid, shifted by $i$ and $j$:\<close>

definition "square2 (n::nat) (i::nat) (j::nat) = {i..< 2^n+i} \<times> {j..< 2^n+j}"

lemma in_square2[simp]:
  "(a,b) : square2 n i j \<longleftrightarrow> i\<le>a \<and> a<2^n+i \<and> j\<le>b \<and> b<2^n+j"
by(simp add:square2_def)

lemma square2_Suc: "square2 (Suc n) i j =
  square2 n i j \<union> square2 n (2^n + i) j \<union> square2 n i (2^n + j) \<union>
  square2 n (2^n + i) (2^n + j)"
by(auto simp:square2_def)

lemma square2_disj: "square2 n i j \<inter> square2 n x y = {} \<longleftrightarrow>
  (2^n+i \<le> x \<or> 2^n+x \<le> i) \<or> (2^n+j \<le> y \<or> 2^n+y \<le> j)" (is "?A = ?B")
proof-
  { assume ?B hence ?A by(auto simp:square2_def) }
  moreover
  { assume "\<not> ?B"
    hence "(max i x, max j y) : square2 n i j \<inter> square2 n x y" by simp
    hence "\<not> ?A" by blast }
  ultimately show ?thesis by blast
qed

text\<open>Some specific lemmas:\<close>

lemma pos_pow2: "(0::nat) < 2^(n::nat)"
by simp

declare nat_zero_less_power_iff[simp del] zero_less_power[simp del]

lemma Diff_insert_if: shows
  "B \<noteq> {} \<Longrightarrow> a:A \<Longrightarrow> A - insert a B = (A-B - {a})" and
  "B \<noteq> {} \<Longrightarrow> a ~: A \<Longrightarrow> A - insert a B = A-B"
by auto

lemma DisjI1: "A Int B = {} \<Longrightarrow> (A-X) Int B = {}"
by blast
lemma DisjI2: "A Int B = {} \<Longrightarrow> A Int (B-X) = {}"
by blast

text\<open>The main theorem:\<close>

theorem Ls_can_tile: "i \<le> a \<Longrightarrow> a < 2^n + i \<Longrightarrow> j \<le> b \<Longrightarrow> b < 2^n + j
  \<Longrightarrow> square2 n i j - {(a,b)} : tiling Ls"
proof(induct n arbitrary: a b i j)
  case 0 thus ?case by (simp add:square2_def)
next
  case (Suc n) note IH = Suc(1) and a = Suc(2-3) and b = Suc(4-5)
  hence "a<2^n+i \<and> b<2^n+j \<or>
         2^n+i\<le>a \<and> a<2^(n+1)+i \<and> b<2^n+j \<or>
         a<2^n+i \<and> 2^n+j\<le>b \<and> b<2^(n+1)+j \<or>
         2^n+i\<le>a \<and> a<2^(n+1)+i \<and> 2^n+j\<le>b \<and> b<2^(n+1)+j" (is "?A|?B|?C|?D")
    by simp arith
  moreover
  { assume "?A"
    hence "square2 n i j - {(a,b)} : tiling Ls" using IH a b by auto
    moreover have "square2 n (2^n+i) j - {(2^n+i,2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n i (2^n+j) - {(2^n+i - 1, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n (2^n+i) (2^n+j) - {(2^n+i, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    ultimately
    have "square2 (n+1) i j - {(a,b)} - L0 (2^n+i - 1) (2^n+j - 1) \<in> tiling Ls"
      using  a b \<open>?A\<close>
      by (clarsimp simp: square2_Suc L0_def Un_Diff Diff_insert_if)
         (fastforce intro!: tiling_UnI DisjI1 DisjI2 square2_disj[THEN iffD2]
                   simp:Int_Un_distrib2)
  } moreover
  { assume "?B"
    hence "square2 n (2^n+i) j - {(a,b)} : tiling Ls" using IH a b by auto
    moreover have "square2 n i j - {(2^n+i - 1,2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n i (2^n+j) - {(2^n+i - 1, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n (2^n+i) (2^n+j) - {(2^n+i, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    ultimately
    have "square2 (n+1) i j - {(a,b)} - L1 (2^n+i - 1) (2^n+j - 1) \<in> tiling Ls"
      using  a b \<open>?B\<close>
      by (simp add: square2_Suc L1_def Un_Diff Diff_insert_if le_diff_conv2)
         (fastforce intro!: tiling_UnI DisjI1 DisjI2 square2_disj[THEN iffD2]
                   simp:Int_Un_distrib2)
  } moreover
  { assume "?C"
    hence "square2 n i (2^n+j) - {(a,b)} : tiling Ls" using IH a b by auto
    moreover have "square2 n i j - {(2^n+i - 1,2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n (2^n+i) j - {(2^n+i, 2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n (2^n+i) (2^n+j) - {(2^n+i, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    ultimately
    have "square2 (n+1) i j - {(a,b)} - L3 (2^n+i - 1) (2^n+j - 1) \<in> tiling Ls"
      using  a b \<open>?C\<close>
      by (simp add: square2_Suc L3_def Un_Diff Diff_insert_if le_diff_conv2)
         (fastforce intro!: tiling_UnI DisjI1 DisjI2 square2_disj[THEN iffD2]
                   simp:Int_Un_distrib2)
  } moreover
  { assume "?D"
    hence "square2 n (2^n+i) (2^n+j) -{(a,b)} : tiling Ls" using IH a b by auto
    moreover have "square2 n i j - {(2^n+i - 1,2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n (2^n+i) j - {(2^n+i, 2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n i (2^n+j) - {(2^n+i - 1, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    ultimately
    have "square2 (n+1) i j - {(a,b)} - L2 (2^n+i - 1) (2^n+j - 1) \<in> tiling Ls"
      using  a b \<open>?D\<close>
      by (simp add: square2_Suc L2_def Un_Diff Diff_insert_if le_diff_conv2)
         (fastforce intro!: tiling_UnI DisjI1 DisjI2 square2_disj[THEN iffD2]
                   simp:Int_Un_distrib2)
  } moreover
  have "?A \<Longrightarrow> L0 (2^n + i - 1) (2^n + j - 1) \<subseteq> square2 (n+1) i j - {(a, b)}"
    using a b by(simp add:L0_def) arith moreover
  have "?B \<Longrightarrow> L1 (2^n + i - 1) (2^n + j - 1) \<subseteq> square2 (n+1) i j - {(a, b)}"
    using a b by(simp add:L1_def) arith moreover
  have "?C \<Longrightarrow> L3 (2^n + i - 1) (2^n + j - 1) \<subseteq> square2 (n+1) i j - {(a, b)}"
    using a b by(simp add:L3_def) arith moreover
  have "?D \<Longrightarrow> L2 (2^n + i - 1) (2^n + j - 1) \<subseteq> square2 (n+1) i j - {(a, b)}"
    using a b by(simp add:L2_def) arith
  ultimately show ?case by simp (metis LinLs tiling_Diff1E)
qed

corollary Ls_can_tile00:
  "a < 2^n \<Longrightarrow> b < 2^n \<Longrightarrow> square2 n 0 0 - {(a, b)} \<in> tiling Ls"
by(rule Ls_can_tile) auto

end


theory hw05
  imports
    Complex_Main
    "HOL-Library.Tree"
begin

value "(0::nat) div 0"

lemma
  assumes "n\<ge>0"
  shows "\<exists>ys zs. length ys = length xs div n \<and> xs=ys@zs"
proof (intro exI)
  let ?n = "length xs div n"
  let ?ys = "take ?n xs"
  let ?zs = "drop ?n xs"
  show "length ?ys = length xs div n \<and> xs = ?ys @ ?zs"  by(simp add:min.absorb2)
qed

fun a :: "nat \<Rightarrow> int" where
  "a 0 = 0"
| "a (Suc n) = a n ^ 2 + 1"

thm power_mono[where n = 2]

find_theorems "(_-_)^2"
find_theorems "(_ + _) > _"

lemma "a n \<le> 2 ^ (2 ^ n) - 1"
proof(induction n)
  case 0 thus ?case by simp
next
  case (Suc n)
  assume IH: "a n \<le> 2 ^ 2 ^ n - 1"
    -- \<open>Refer to the induction hypothesis by name \<open>IH\<close> or \<open>Suc.IH\<close>\<close>
  show "a (Suc n) \<le> 2 ^ 2 ^ Suc n - 1"
  proof -
    from IH have azer:"0 \<le> a n" by (smt a.elims power2_less_eq_zero_iff zero_eq_power2)

    from IH  have "a (Suc n) = (a n)^2 +1" by simp
    also have "(a n)^2 \<le> (2 ^ 2 ^ n - 1) ^ 2" using power_mono[where n = 2] IH azer by blast
    also have "... \<le> (2 ^ 2 ^ (n + 1)) + 1 - 2*2^(2^(n))" by (simp add: power2_diff power_even_eq)
    also have "... \<le> 2 ^ 2 ^ Suc n - 2 " by (smt Suc.IH Suc_eq_plus1 a.elims power.simps(1) power2_less_eq_zero_iff power_one_right zero_eq_power2)
    finally show ?thesis by auto

  qed
qed

end


theory Chapter3
  imports Main
begin

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun set :: "'a tree \<Rightarrow> 'a set" where
  "set Tip = {}"
| "set (Node t1 a t2) = set t1 \<union> {a} \<union> set t2"

fun ord :: "int tree \<Rightarrow> bool" where
  "ord Tip = True"
| "ord (Node t1 a t2) = (ord t1 \<and> ord t2 \<and> (\<forall>x. x \<in> set t1 \<longrightarrow> x < a) \<and> (\<forall>x. x \<in> set t2 \<longrightarrow> a \<le> x))"
(* parentheses are necessary around (\<forall>x. ...)*)

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree" where
  "ins x Tip = Node Tip x Tip"
| "ins x (Node t1 a t2) = (if x < a then Node (ins x t1) a t2 else Node t1 a (ins x t2))"

theorem ins_correct_1 : "set (ins x t) = {x} \<union> set t"
  apply (induction t)
   apply (auto)
  done

theorem ins_correct_2 : "ord t \<Longrightarrow> ord (ins i t)"
  apply (induction t)
   apply (auto simp add:ins_correct_1)
  done

(*** 3.3 Proof Automation ***)
lemma "\<forall>x. \<exists>y. x = y" by auto
lemma "A \<subseteq> B \<inter> C \<Longrightarrow> A \<subseteq> B \<union> C" by auto

(* fastforce can handle quantifiers *)
lemma "\<lbrakk> \<forall>xs \<in> A. \<exists>ys. xs = ys @ ys; us \<in> A \<rbrakk> \<Longrightarrow> \<exists>n. length us = n + n" by fastforce

(* blast is strong in first-order logic, sets and relations, but weak in equality *)
lemma "\<lbrakk> \<forall> x y. T x y \<or> T y x;
         \<forall> x y. A x y \<and> A y x \<longrightarrow> x = y;
         \<forall> x y. T x y \<longrightarrow> A x y \<rbrakk> \<Longrightarrow> \<forall> x y. A x y \<longrightarrow> T x y" by blast

(* sledgehammer *)
lemma "\<lbrakk> xs @ ys = ys @ xs; length xs = length ys \<rbrakk> \<Longrightarrow> xs = ys"
  using append_eq_append_conv by blast

(* arith *)
lemma "\<lbrakk> (a :: nat) \<le> x + b; 2 * x < c \<rbrakk> \<Longrightarrow> 2 * a + 1 \<le> 2 * b + c"
  by arith

(* 3.4 Single Step Proofs *)
lemma "\<lbrakk> (a :: nat) \<le> b; b \<le> c; c \<le> d; d \<le> e \<rbrakk> \<Longrightarrow> a \<le> e"
  by (auto intro:le_trans)

thm conjI[OF refl[of "a"] refl[of "b"]] (* a = a \<and> b = b *)

lemma "Suc(Suc(Suc a)) \<le> b \<Longrightarrow> a \<le> b" by (auto dest:Suc_leD)

(* 3.5 Inductive Deifnitions *)
inductive ev :: "nat \<Rightarrow> bool" where
  ev0 : "ev 0"
| evSS : "ev n \<Longrightarrow> ev (Suc (Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
  "evn 0 = True"
| "evn (Suc 0) = False"
| "evn (Suc(Suc n)) = evn n"

lemma "ev(Suc(Suc(Suc(Suc 0))))"
  apply (rule evSS)
  apply (rule evSS)
  apply (rule ev0)
  done

lemma "ev m \<Longrightarrow> ev (m - 2)"
  apply (induction rule:ev.induct)
  by (simp_all add:ev0 evSS)

lemma "ev m \<Longrightarrow> evn m"
  apply (induction rule:ev.induct)
  by (simp_all)

lemma "evn n \<Longrightarrow> ev n"
  apply (induction n rule:evn.induct)
  by (simp_all add:ev0 evSS)

(* makes ev a simplification and introduction rule permanently *)
declare ev.intros[simp,intro]

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl: "star r x x"
| step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply (induction rule: star.induct) (* induction over star r x y (first matching assumption) *)
   apply (assumption)
  apply (metis step)
  done

(* Exercise 3.2 *)
inductive palindrome :: "'a list \<Rightarrow> bool" where
  pEmpty: "palindrome []"
| pSingle: "palindrome [x]"
| pStep: "palindrome xs \<Longrightarrow> palindrome (a # xs @ [a])"

theorem palindrome_spec : "palindrome xs \<Longrightarrow> rev xs = xs"
  apply (induction rule:palindrome.induct)
    apply (auto)
  done

(* Exercise 3.3 *)
inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl': "star' r x x"
| step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

theorem star'_is_star : "star' r x y \<Longrightarrow> star r x y"
  apply (induction rule:star'.induct)
   apply (auto simp add:refl step star_trans)
  done

lemma star'_trans' : "star' r y z \<Longrightarrow> star' r x y \<Longrightarrow> star' r x z"
  apply (induction rule:star'.induct)
   apply (assumption)
  apply (simp add:step')
  done

theorem star_is_star' : "star r x y \<Longrightarrow> star' r x y"
  apply (induction rule:star.induct)
   apply (simp add:refl' step')
  apply (blast intro:refl' step' star'_trans')
  done

(* Exercise 3.4 *)
inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  iter_zero: "iter r 0 x x"
| iter_succ: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

theorem star_iter : "star r x y \<Longrightarrow> \<exists>n. iter r n x y"
  apply (induction rule:star.induct)
  apply (rule exI[of _ 0])
   apply (auto simp add:iter_zero iter_succ)
  apply (rule_tac x="Suc n" in exI)
  apply (auto simp add:iter_zero iter_succ)
  done

(* Exercise 3.5 *)
datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
  S_0: "S []"
| S_1: "S w \<Longrightarrow> S (a # w @ [b])"
| S_2: "S w \<Longrightarrow> S w' \<Longrightarrow> S (w @ w')"

inductive T :: "alpha list \<Rightarrow> bool" where
  T_0: "T []"
| T_1: "T w \<Longrightarrow> T w' \<Longrightarrow> T (w @ a # w' @ [b])"

lemma S_includes_T : "T w \<Longrightarrow> S w"
  apply (induction rule:T.induct)
   apply (auto simp add:S_0 S_1 S_2)
  done

lemma append_Nil_r : "l = [] @ l"
  apply (induction l)
   apply (auto)
  done

(* I'm not happy with having to prepare these lemmas... *)
lemma T_complies_S_1' : "T w \<Longrightarrow> T ([] @ a # w @ [b])"
  apply (rule T_1)
   apply (auto simp add:T_0)
  done

lemma T_complies_S_1'' : "T ([] @ a # w @ [b]) \<Longrightarrow> T(a # w @ [b])"
  apply (auto)
  done

lemma T_complies_S_1 : "T w \<Longrightarrow> T (a # w @ [b])"
  apply (rule T_complies_S_1'')
  apply (rule T_complies_S_1')
  apply (auto)
  done

lemma T_complies_S_2 : "S w' \<Longrightarrow> T w' \<Longrightarrow> T w \<Longrightarrow> T (w @ w')"
  apply (induction rule:S.induct)
    apply (auto)

lemma T_includes_S : "S w \<Longrightarrow> T w"
  apply (induction rule:S.induct)
    apply (rule T_0)
   apply (auto simp add:T_complies_S_1)

end


(*  Title:      HOL/Parity.thy
    Author:     Jeremy Avigad
    Author:     Jacques D. Fleuriot
*)

section {* Parity in rings and semirings *}

theory Parity
imports Nat_Transfer
begin

subsection {* Ring structures with parity and @{text even}/@{text odd} predicates *}

class semiring_parity = semiring_dvd + semiring_numeral +
  assumes odd_one [simp]: "\<not> 2 dvd 1"
  assumes odd_even_add: "\<not> 2 dvd a \<Longrightarrow> \<not> 2 dvd b \<Longrightarrow> 2 dvd a + b"
  assumes even_multD: "2 dvd a * b \<Longrightarrow> 2 dvd a \<or> 2 dvd b"
  assumes odd_ex_decrement: "\<not> 2 dvd a \<Longrightarrow> \<exists>b. a = b + 1"
begin

abbreviation even :: "'a \<Rightarrow> bool"
where
  "even a \<equiv> 2 dvd a"

abbreviation odd :: "'a \<Rightarrow> bool"
where
  "odd a \<equiv> \<not> 2 dvd a"

lemma even_zero [simp]:
  "even 0"
  by (fact dvd_0_right)

lemma even_plus_one_iff [simp]:
  "even (a + 1) \<longleftrightarrow> odd a"
  by (auto simp add: dvd_add_right_iff intro: odd_even_add)

lemma evenE [elim?]:
  assumes "even a"
  obtains b where "a = 2 * b"
  using assms by (rule dvdE)

lemma oddE [elim?]:
  assumes "odd a"
  obtains b where "a = 2 * b + 1"
proof -
  from assms obtain b where *: "a = b + 1"
    by (blast dest: odd_ex_decrement)
  with assms have "even (b + 2)" by simp
  then have "even b" by simp
  then obtain c where "b = 2 * c" ..
  with * have "a = 2 * c + 1" by simp
  with that show thesis .
qed

lemma even_times_iff [simp]:
  "even (a * b) \<longleftrightarrow> even a \<or> even b"
  by (auto dest: even_multD)

lemma even_numeral [simp]:
  "even (numeral (Num.Bit0 n))"
proof -
  have "even (2 * numeral n)"
    unfolding even_times_iff by simp
  then have "even (numeral n + numeral n)"
    unfolding mult_2 .
  then show ?thesis
    unfolding numeral.simps .
qed

lemma odd_numeral [simp]:
  "odd (numeral (Num.Bit1 n))"
proof
  assume "even (numeral (num.Bit1 n))"
  then have "even (numeral n + numeral n + 1)"
    unfolding numeral.simps .
  then have "even (2 * numeral n + 1)"
    unfolding mult_2 .
  then have "2 dvd numeral n * 2 + 1"
    by (simp add: ac_simps)
  with dvd_add_times_triv_left_iff [of 2 "numeral n" 1]
    have "2 dvd 1"
    by simp
  then show False by simp
qed

lemma even_add [simp]:
  "even (a + b) \<longleftrightarrow> (even a \<longleftrightarrow> even b)"
  by (auto simp add: dvd_add_right_iff dvd_add_left_iff odd_even_add)

lemma odd_add [simp]:
  "odd (a + b) \<longleftrightarrow> (\<not> (odd a \<longleftrightarrow> odd b))"
  by simp

lemma even_power [simp]:
  "even (a ^ n) \<longleftrightarrow> even a \<and> n > 0"
  by (induct n) auto

end

class ring_parity = comm_ring_1 + semiring_parity
begin

lemma even_minus [simp]:
  "even (- a) \<longleftrightarrow> even a"
  by (fact dvd_minus_iff)

lemma even_diff [simp]:
  "even (a - b) \<longleftrightarrow> even (a + b)"
  using even_add [of a "- b"] by simp

end

subsection {* Instances for @{typ nat} and @{typ int} *}

lemma even_Suc_Suc_iff [simp]:
  "even (Suc (Suc n)) \<longleftrightarrow> even n"
  using dvd_add_triv_right_iff [of 2 n] by simp

lemma even_Suc [simp]:
  "even (Suc n) \<longleftrightarrow> odd n"
  by (induct n) auto

lemma even_diff_nat [simp]:
  fixes m n :: nat
  shows "even (m - n) \<longleftrightarrow> m < n \<or> even (m + n)"
proof (cases "n \<le> m")
  case True
  then have "m - n + n * 2 = m + n" by (simp add: mult_2_right)
  moreover have "even (m - n) \<longleftrightarrow> even (m - n + n * 2)" by simp
  ultimately have "even (m - n) \<longleftrightarrow> even (m + n)" by (simp only:)
  then show ?thesis by auto
next
  case False
  then show ?thesis by simp
qed

lemma even_diff_iff [simp]:
  fixes k l :: int
  shows "even (k - l) \<longleftrightarrow> even (k + l)"
  using dvd_add_times_triv_right_iff [of 2 "k - l" l] by (simp add: mult_2_right)

lemma even_abs_add_iff [simp]:
  fixes k l :: int
  shows "even (\<bar>k\<bar> + l) \<longleftrightarrow> even (k + l)"
  by (cases "k \<ge> 0") (simp_all add: ac_simps)

lemma even_add_abs_iff [simp]:
  fixes k l :: int
  shows "even (k + \<bar>l\<bar>) \<longleftrightarrow> even (k + l)"
  using even_abs_add_iff [of l k] by (simp add: ac_simps)

instance nat :: semiring_parity
proof
  show "odd (1 :: nat)"
    by (rule notI, erule dvdE) simp
next
  fix m n :: nat
  assume "odd m"
  moreover assume "odd n"
  ultimately have *: "even (Suc m) \<and> even (Suc n)"
    by simp
  then have "even (Suc m + Suc n)"
    by (blast intro: dvd_add)
  also have "Suc m + Suc n = m + n + 2"
    by simp
  finally show "even (m + n)"
    using dvd_add_triv_right_iff [of 2 "m + n"] by simp
next
  fix m n :: nat
  assume *: "even (m * n)"
  show "even m \<or> even n"
  proof (rule disjCI)
    assume "odd n"
    then have "even (Suc n)" by simp
    then obtain r where "Suc n = 2 * r" ..
    moreover from * obtain s where "m * n = 2 * s" ..
    then have "2 * s + m = m * Suc n" by simp
    ultimately have " 2 * s + m = 2 * (m * r)" by (simp add: algebra_simps)
    then have "m = 2 * (m * r - s)" by simp
    then show "even m" ..
  qed
next
  fix n :: nat
  assume "odd n"
  then show "\<exists>m. n = m + 1"
    by (cases n) simp_all
qed

lemma odd_pos:
  "odd (n :: nat) \<Longrightarrow> 0 < n"
  by (auto elim: oddE)

instance int :: ring_parity
proof
  show "odd (1 :: int)" by (simp add: dvd_int_unfold_dvd_nat)
  fix k l :: int
  assume "odd k"
  moreover assume "odd l"
  ultimately have "even (nat \<bar>k\<bar> + nat \<bar>l\<bar>)"
    by (auto simp add: dvd_int_unfold_dvd_nat intro: odd_even_add)
  then have "even (\<bar>k\<bar> + \<bar>l\<bar>)"
    by (simp add: dvd_int_unfold_dvd_nat nat_add_distrib)
  then show "even (k + l)"
    by simp
next
  fix k l :: int
  assume "even (k * l)"
  then show "even k \<or> even l"
    by (simp add: dvd_int_unfold_dvd_nat even_multD nat_abs_mult_distrib)
next
  fix k :: int
  have "k = (k - 1) + 1" by simp
  then show "\<exists>l. k = l + 1" ..
qed

lemma even_int_iff [simp]:
  "even (int n) \<longleftrightarrow> even n"
  by (simp add: dvd_int_iff)

lemma even_nat_iff:
  "0 \<le> k \<Longrightarrow> even (nat k) \<longleftrightarrow> even k"
  by (simp add: even_int_iff [symmetric])

subsection {* Parity and powers *}

context comm_ring_1
begin

lemma power_minus_even [simp]:
  "even n \<Longrightarrow> (- a) ^ n = a ^ n"
  by (auto elim: evenE)

lemma power_minus_odd [simp]:
  "odd n \<Longrightarrow> (- a) ^ n = - (a ^ n)"
  by (auto elim: oddE)

lemma neg_one_even_power [simp]:
  "even n \<Longrightarrow> (- 1) ^ n = 1"
  by simp

lemma neg_one_odd_power [simp]:
  "odd n \<Longrightarrow> (- 1) ^ n = - 1"
  by simp

end

context linordered_idom
begin

lemma zero_le_even_power:
  "even n \<Longrightarrow> 0 \<le> a ^ n"
  by (auto elim: evenE)

lemma zero_le_odd_power:
  "odd n \<Longrightarrow> 0 \<le> a ^ n \<longleftrightarrow> 0 \<le> a"
  by (auto simp add: power_even_eq zero_le_mult_iff elim: oddE)

lemma zero_le_power_eq:
  "0 \<le> a ^ n \<longleftrightarrow> even n \<or> odd n \<and> 0 \<le> a"
  by (auto simp add: zero_le_even_power zero_le_odd_power)

lemma zero_less_power_eq:
  "0 < a ^ n \<longleftrightarrow> n = 0 \<or> even n \<and> a \<noteq> 0 \<or> odd n \<and> 0 < a"
proof -
  have [simp]: "0 = a ^ n \<longleftrightarrow> a = 0 \<and> n > 0"
    unfolding power_eq_0_iff [of a n, symmetric] by blast
  show ?thesis
  unfolding less_le zero_le_power_eq by auto
qed

lemma power_less_zero_eq [simp]:
  "a ^ n < 0 \<longleftrightarrow> odd n \<and> a < 0"
  unfolding not_le [symmetric] zero_le_power_eq by auto

lemma power_le_zero_eq:
  "a ^ n \<le> 0 \<longleftrightarrow> n > 0 \<and> (odd n \<and> a \<le> 0 \<or> even n \<and> a = 0)"
  unfolding not_less [symmetric] zero_less_power_eq by auto

lemma power_even_abs:
  "even n \<Longrightarrow> \<bar>a\<bar> ^ n = a ^ n"
  using power_abs [of a n] by (simp add: zero_le_even_power)

lemma power_mono_even:
  assumes "even n" and "\<bar>a\<bar> \<le> \<bar>b\<bar>"
  shows "a ^ n \<le> b ^ n"
proof -
  have "0 \<le> \<bar>a\<bar>" by auto
  with `\<bar>a\<bar> \<le> \<bar>b\<bar>`
  have "\<bar>a\<bar> ^ n \<le> \<bar>b\<bar> ^ n" by (rule power_mono)
  with `even n` show ?thesis by (simp add: power_even_abs)
qed

lemma power_mono_odd:
  assumes "odd n" and "a \<le> b"
  shows "a ^ n \<le> b ^ n"
proof (cases "b < 0")
  case True with `a \<le> b` have "- b \<le> - a" and "0 \<le> - b" by auto
  hence "(- b) ^ n \<le> (- a) ^ n" by (rule power_mono)
  with `odd n` show ?thesis by simp
next
  case False then have "0 \<le> b" by auto
  show ?thesis
  proof (cases "a < 0")
    case True then have "n \<noteq> 0" and "a \<le> 0" using `odd n` [THEN odd_pos] by auto
    then have "a ^ n \<le> 0" unfolding power_le_zero_eq using `odd n` by auto
    moreover
    from `0 \<le> b` have "0 \<le> b ^ n" by auto
    ultimately show ?thesis by auto
  next
    case False then have "0 \<le> a" by auto
    with `a \<le> b` show ?thesis using power_mono by auto
  qed
qed

text {* Simplify, when the exponent is a numeral *}

lemma zero_le_power_eq_numeral [simp]:
  "0 \<le> a ^ numeral w \<longleftrightarrow> even (numeral w :: nat) \<or> odd (numeral w :: nat) \<and> 0 \<le> a"
  by (fact zero_le_power_eq)

lemma zero_less_power_eq_numeral [simp]:
  "0 < a ^ numeral w \<longleftrightarrow> numeral w = (0 :: nat)
    \<or> even (numeral w :: nat) \<and> a \<noteq> 0 \<or> odd (numeral w :: nat) \<and> 0 < a"
  by (fact zero_less_power_eq)

lemma power_le_zero_eq_numeral [simp]:
  "a ^ numeral w \<le> 0 \<longleftrightarrow> (0 :: nat) < numeral w
    \<and> (odd (numeral w :: nat) \<and> a \<le> 0 \<or> even (numeral w :: nat) \<and> a = 0)"
  by (fact power_le_zero_eq)

lemma power_less_zero_eq_numeral [simp]:
  "a ^ numeral w < 0 \<longleftrightarrow> odd (numeral w :: nat) \<and> a < 0"
  by (fact power_less_zero_eq)

lemma power_even_abs_numeral [simp]:
  "even (numeral w :: nat) \<Longrightarrow> \<bar>a\<bar> ^ numeral w = a ^ numeral w"
  by (fact power_even_abs)

end

subsubsection {* Tools setup *}

declare transfer_morphism_int_nat [transfer add return:
  even_int_iff
]

end


(*
  File:     More_Algebraic_Numbers_HLW.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>More facts about algebraic numbers\<close>
theory More_Algebraic_Numbers_HLW
  imports "Algebraic_Numbers.Algebraic_Numbers"
begin

subsection \<open>Miscellaneous\<close>

(* TODO: Move! All of this belongs in Algebraic_Numbers *)

lemma in_Ints_imp_algebraic [simp, intro]: "x \<in> \<int> \<Longrightarrow> algebraic x"
  by (intro algebraic_int_imp_algebraic int_imp_algebraic_int)

lemma in_Rats_imp_algebraic [simp, intro]: "x \<in> \<rat> \<Longrightarrow> algebraic x"
  by (auto elim!: Rats_cases' intro: algebraic_div)

lemma algebraic_uminus_iff [simp]: "algebraic (-x) \<longleftrightarrow> algebraic x"
  using algebraic_uminus[of x] algebraic_uminus[of "-x"] by auto

lemma algebraic_0 [simp]: "algebraic (0 :: 'a :: field_char_0)"
  and algebraic_1 [simp]: "algebraic (1 :: 'a :: field_char_0)"
  by auto

lemma algebraic_sum_mset [intro]:
  "(\<And>x. x \<in># A \<Longrightarrow> algebraic x) \<Longrightarrow> algebraic (sum_mset A)"
  by (induction A) (auto intro!: algebraic_plus)

lemma algebraic_prod_mset [intro]:
  "(\<And>x. x \<in># A \<Longrightarrow> algebraic x) \<Longrightarrow> algebraic (prod_mset A)"
  by (induction A) (auto intro!: algebraic_times)

lemma algebraic_power [intro]: "algebraic x \<Longrightarrow> algebraic (x ^ n)"
  by (induction n) (auto intro: algebraic_times)

lemma algebraic_csqrt [intro]: "algebraic x \<Longrightarrow> algebraic (csqrt x)"
  by (rule algebraic_nth_root[of 2 x]) auto

lemma algebraic_csqrt_iff [simp]: "algebraic (csqrt x) \<longleftrightarrow> algebraic x"
proof
  assume "algebraic (csqrt x)"
  hence "algebraic (csqrt x ^ 2)"
    by (rule algebraic_power)
  also have "csqrt x ^ 2 = x"
    by simp
  finally show "algebraic x" .
qed auto

lemmas [intro] = algebraic_plus algebraic_times algebraic_uminus algebraic_div

lemma algebraic_power_iff [simp]:
  assumes "n > 0"
  shows   "algebraic (x ^ n) \<longleftrightarrow> algebraic x"
  using algebraic_nth_root[of n "x ^ n" x] assms by auto

lemma algebraic_ii [simp]: "algebraic \<i>"
  by (intro algebraic_int_imp_algebraic) auto

lemma algebraic_int_fact [simp, intro]: "algebraic_int (fact n)"
  by (intro int_imp_algebraic_int fact_in_Ints)

lemma algebraic_minus [intro]: "algebraic x \<Longrightarrow> algebraic y \<Longrightarrow> algebraic (x - y)"
  using algebraic_plus[of x "-y"] by simp

lemma algebraic_add_cancel_left [simp]:
  assumes "algebraic x"
  shows   "algebraic (x + y) \<longleftrightarrow> algebraic y"
proof
  assume "algebraic (x + y)"
  hence "algebraic (x + y - x)"
    using assms by (intro algebraic_minus) auto
  thus "algebraic y" by simp
qed (auto intro: algebraic_plus assms)

lemma algebraic_add_cancel_right [simp]:
  assumes "algebraic y"
  shows   "algebraic (x + y) \<longleftrightarrow> algebraic x"
  using algebraic_add_cancel_left[of y x] assms
  by (simp add: add.commute del: algebraic_add_cancel_left)

lemma algebraic_diff_cancel_left [simp]:
  assumes "algebraic x"
  shows   "algebraic (x - y) \<longleftrightarrow> algebraic y"
  using algebraic_add_cancel_left[of x "-y"] assms by (simp del: algebraic_add_cancel_left)

lemma algebraic_diff_cancel_right [simp]:
  assumes "algebraic y"
  shows   "algebraic (x - y) \<longleftrightarrow> algebraic x"
  using algebraic_add_cancel_right[of "-y" x] assms by (simp del: algebraic_add_cancel_right)

lemma algebraic_mult_cancel_left [simp]:
  assumes "algebraic x" "x \<noteq> 0"
  shows   "algebraic (x * y) \<longleftrightarrow> algebraic y"
proof
  assume "algebraic (x * y)"
  hence "algebraic (x * y / x)"
    using assms by (intro algebraic_div) auto
  also have "x * y / x = y"
    using assms by auto
  finally show "algebraic y" .
qed (auto intro: algebraic_times assms)

lemma algebraic_mult_cancel_right [simp]:
  assumes "algebraic y" "y \<noteq> 0"
  shows   "algebraic (x * y) \<longleftrightarrow> algebraic x"
  using algebraic_mult_cancel_left[of y x] assms
  by (simp add: mult.commute del: algebraic_mult_cancel_left)

lemma algebraic_inverse_iff [simp]: "algebraic (inverse y) \<longleftrightarrow> algebraic y"
proof
  assume "algebraic (inverse y)"
  hence "algebraic (inverse (inverse y))"
    by (rule algebraic_inverse)
  thus "algebraic y" by simp
qed (auto intro: algebraic_inverse)

lemma algebraic_divide_cancel_left [simp]:
  assumes "algebraic x" "x \<noteq> 0"
  shows   "algebraic (x / y) \<longleftrightarrow> algebraic y"
proof -
  have "algebraic (x * inverse y) \<longleftrightarrow> algebraic (inverse y)"
    by (intro algebraic_mult_cancel_left assms)
  also have "\<dots> \<longleftrightarrow> algebraic y"
    by (intro algebraic_inverse_iff)
  finally show ?thesis by (simp add: field_simps)
qed

lemma algebraic_divide_cancel_right [simp]:
  assumes "algebraic y" "y \<noteq> 0"
  shows   "algebraic (x / y) \<longleftrightarrow> algebraic x"
proof -
  have "algebraic (x * inverse y) \<longleftrightarrow> algebraic x"
    using assms by (intro algebraic_mult_cancel_right) auto
  thus ?thesis by (simp add: field_simps)
qed

subsection \<open>Turning an algebraic number into an algebraic integer\<close>

subsection \<open>
  Multiplying an algebraic number with a suitable integer turns it into an algebraic integer.
\<close>

lemma algebraic_imp_algebraic_int:
  fixes x :: "'a :: field_char_0"
  assumes "ipoly p x = 0" "p \<noteq> 0"
  defines "c \<equiv> Polynomial.lead_coeff p"
  shows   "algebraic_int (of_int c * x)"
proof -
  define n where "n = Polynomial.degree p"
  define p' where "p' = Abs_poly (\<lambda>i. if i = n then 1 else c ^ (n - i - 1) * poly.coeff p i)"
  have "n > 0"
    using assms unfolding n_def by (intro Nat.gr0I) (auto elim!: degree_eq_zeroE)

  have coeff_p': "poly.coeff p' i =
                    (if i = n then 1 else c ^ (n - i - 1) * poly.coeff p i)"
    (is "_ = ?f i") for i unfolding p'_def
  proof (subst poly.Abs_poly_inverse)
    have "eventually (\<lambda>i. poly.coeff p i = 0) cofinite"
      using MOST_coeff_eq_0 by blast
    hence "eventually (\<lambda>i. ?f i = 0) cofinite"
      by eventually_elim (use assms in \<open>auto simp: n_def\<close>)
    thus "?f \<in> {f. eventually (\<lambda>i. f i = 0) cofinite}" by simp
  qed auto

  have deg_p': "Polynomial.degree p' = n"
  proof -
    from assms have "(\<lambda>n. \<forall>i>n. poly.coeff p' i = 0) = (\<lambda>n. \<forall>i>n. poly.coeff p i = 0)"
      by (auto simp: coeff_p' fun_eq_iff n_def)
    thus ?thesis
      by (simp add: Polynomial.degree_def n_def)
  qed

  have lead_coeff_p': "Polynomial.lead_coeff p' = 1"
    by (simp add: coeff_p' deg_p')

  have "0 = of_int (c ^ (n - 1)) * (\<Sum>i\<le>n. of_int (poly.coeff p i) * x ^ i)"
    using assms unfolding n_def poly_altdef by simp
  also have "\<dots> = (\<Sum>i\<le>n. of_int (c ^ (n - 1) * poly.coeff p i) * x ^ i)"
    by (simp add: sum_distrib_left sum_distrib_right mult_ac)
  also have "\<dots> = (\<Sum>i\<le>n. of_int (poly.coeff p' i) * (of_int c * x) ^ i)"
  proof (intro sum.cong, goal_cases)
    case (2 i)
    have "of_int (poly.coeff p' i) * (of_int c * x) ^ i =
          of_int (c ^ i * poly.coeff p' i) * x ^ i"
      by (simp add: algebra_simps)
    also have "c ^ i * poly.coeff p' i = c ^ (n - 1) * poly.coeff p i"
    proof (cases "i = n")
      case True
      hence "c ^ i * poly.coeff p' i = c ^ n"
        by (auto simp: coeff_p' simp flip: power_Suc)
      also have "n = Suc (n - 1)"
        using \<open>n > 0\<close> by simp
      also have "c ^ \<dots> = c * c ^ (n - 1)"
        by simp
      finally show ?thesis
        using True by (simp add: c_def n_def)
    next
      case False
      thus ?thesis using 2
        by (auto simp: coeff_p' simp flip: power_add)
    qed
    finally show ?case ..
  qed auto
  also have "\<dots> = ipoly p' (of_int c * x)"
    by (simp add: poly_altdef n_def deg_p')
  finally have "ipoly p' (of_int c * x) = 0" ..

  with lead_coeff_p' show ?thesis
    unfolding algebraic_int_altdef_ipoly by blast
qed

lemma algebraic_imp_algebraic_int':
  fixes x :: "'a :: field_char_0"
  assumes "ipoly p x = 0" "p \<noteq> 0" "Polynomial.lead_coeff p dvd c"
  shows   "algebraic_int (of_int c * x)"
proof -
  from assms(3) obtain c' where c_eq: "c = Polynomial.lead_coeff p * c'"
    by auto
  have "algebraic_int (of_int c' * (of_int (Polynomial.lead_coeff p) * x))"
    by (rule algebraic_int_times[OF _ algebraic_imp_algebraic_int]) (use assms in auto)
  also have "of_int c' * (of_int (Polynomial.lead_coeff p) * x) = of_int c * x"
    by (simp add: c_eq mult_ac)
  finally show ?thesis .
qed

end


theory Chapter3
imports "~~/src/HOL/IMP/BExp"
        "~~/src/HOL/IMP/ASM"
begin

text{*
\section*{Chapter 3}

\exercise
To show that @{const asimp_const} really folds all subexpressions of the form
@{term "Plus (N i) (N j)"}, define a function
*}

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N n) = True" |
"optimal (V x) = True" |
"optimal (Plus (N i) (N j)) = False" |
"optimal (Plus l r) = (optimal l & optimal r)"

text{*
that checks that its argument does not contain a subexpression of the form
@{term "Plus (N i) (N j)"}. Then prove that the result of @{const asimp_const}
is optimal:
*}

lemma "optimal (asimp_const a)"
  apply(induction a)
    apply(auto split: aexp.split)
  done

text{*
This proof needs the same @{text "split:"} directive as the correctness proof of
@{const asimp_const}. This increases the chance of nontermination
of the simplifier. Therefore @{const optimal} should be defined purely by
pattern matching on the left-hand side,
without @{text case} expressions on the right-hand side.
\endexercise

\exercise
In this exercise we verify constant folding for @{typ aexp}
where we sum up all constants, even if they are not next to each other.
For example, @{term "Plus (N 1) (Plus (V x) (N 2))"} becomes
@{term "Plus (V x) (N 3)"}. This goes beyond @{const asimp}.
Below we follow a particular solution strategy but there are many others.

First, define a function @{text sumN} that returns the sum of all
constants in an expression and a function @{text zeroN} that replaces all
constants in an expression by zeroes (they will be optimized away later):
*}

fun sumN :: "aexp \<Rightarrow> int" where
"sumN (N n) = n" |
"sumN (V x) = 0" |
"sumN (Plus l r) = sumN l + sumN r"

fun zeroN :: "aexp \<Rightarrow> aexp" where
"zeroN (N n) = N 0" |
"zeroN (V x) = V x" |
"zeroN (Plus l r) = Plus (zeroN l) (zeroN r)"

text {*
Next, define a function @{text sepN} that produces an arithmetic expression
that adds the results of @{const sumN} and @{const zeroN}. Prove that
@{text sepN} preserves the value of an expression.
*}

definition sepN :: "aexp \<Rightarrow> aexp" where
"sepN exp = Plus (zeroN exp)  (N (sumN exp))"

lemma aval_sepN: "aval (sepN t) s = aval t s"
  apply(simp add: sepN_def)
  apply(induction t)
    apply(auto)
  done

text {*
Finally, define a function @{text full_asimp} that uses @{const asimp}
to eliminate the zeroes left over by @{const sepN}.
Prove that it preserves the value of an arithmetic expression.
*}

definition full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp exp = asimp (sepN exp)"

lemma aval_full_asimp: "aval (full_asimp t) s = aval t s"
  apply(simp add: full_asimp_def aval_sepN)
  done

text{*
\endexercise

\exercise\label{exe:subst}
Substitution is the process of replacing a variable
by an expression in an expression. Define a substitution function
*}

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (N n) = N n" |
"subst x a (V y) = (if x = y then a else V y)" |
"subst x a (Plus l r) = Plus (subst x a l) (subst x a r)"

text{*
such that @{term "subst x a e" } is the result of replacing
every occurrence of variable @{text x} by @{text a} in @{text e}.
For example:
@{lemma[display] "subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')" by simp}

Prove the so-called \concept{substitution lemma} that says that we can either
substitute first and evaluate afterwards or evaluate with an updated state:
*}

lemma subst_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
  apply(induction e)
    apply(auto)
  done

text {*
As a consequence prove that we can substitute equal expressions by equal expressions
and obtain the same result under evaluation:
*}
lemma "aval a1 s = aval a2 s
  \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply(simp add: subst_lemma)
  done

text{*
\endexercise

\exercise
Take a copy of theory @{theory AExp} and modify it as follows.
Extend type @{typ aexp} with a binary constructor @{text Times} that
represents multiplication. Modify the definition of the functions @{const aval}
and @{const asimp} accordingly. You can remove @{const asimp_const}.
Function @{const asimp} should eliminate 0 and 1 from multiplications
as well as evaluate constant subterms. Update all proofs concerned.
*}

text{*
\endexercise

\exercise
Define a datatype @{text aexp2} of extended arithmetic expressions that has,
in addition to the constructors of @{typ aexp}, a constructor for
modelling a C-like post-increment operation $x{++}$, where $x$ must be a
variable. Define an evaluation function @{text "aval2 :: aexp2 \<Rightarrow> state \<Rightarrow> val \<times> state"}
that returns both the value of the expression and the new state.
The latter is required because post-increment changes the state.

Extend @{text aexp2} and @{text aval2} with a division operation. Model partiality of
division by changing the return type of @{text aval2} to
@{typ "(val \<times> state) option"}. In case of division by 0 let @{text aval2}
return @{const None}. Division on @{typ int} is the infix @{text div}.
*}

datatype aexp2 =
    Const int
  | Var vname
  | PlusOp aexp2 aexp2
  | IncOp vname
  | DivOp aexp2 aexp2

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state) option"
  where
    "aval2 (Const n) s = Some (n, s)"
  | "aval2 (Var x) s = Some (s x, s)"
  | "aval2 (PlusOp l r) s =
      Option.bind (aval2 l s) (\<lambda> (lval, s\<^sub>1).
        Option.bind (aval2 r s\<^sub>1) (\<lambda> (rval, s\<^sub>2).
          Some (lval + rval, s\<^sub>2)))"
  | "aval2 (IncOp x) s = Some (s x, s(x := s x + 1))"
  | "aval2 (DivOp l r) s =
      Option.bind (aval2 l s) (\<lambda> (lval, s\<^sub>1).
        Option.bind (aval2 r s\<^sub>1) (\<lambda> (rval, s\<^sub>2).
          if rval = 0 then None else Some (lval div rval, s\<^sub>2)))"

value "aval2 (PlusOp (IncOp ''x'') (DivOp (Const 5) (Var ''x''))) (<''x'' := -1>)"

text{*
\endexercise

\exercise
The following type adds a @{text LET} construct to arithmetic expressions:
*}

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int"
  where
    "lval (Nl n) s = n"
  | "lval (Vl x) s = s x"
  | "lval (Plusl l r) s = lval l s + lval r s"
  | "lval (LET x e\<^sub>1 e\<^sub>2) s = lval e\<^sub>2 (s(x := lval e\<^sub>1 s))"

value "lval
        (LET ''x'' (Nl 5)
          (Plusl (Vl ''x'') (Nl 5))) <>"

fun inline :: "lexp \<Rightarrow> aexp"
  where
    "inline (Nl n) = N n"
  | "inline (Vl x) = V x"
  | "inline (Plusl l r) = Plus (inline l) (inline r)"
  | "inline (LET x e\<^sub>1 e\<^sub>2) = subst x (inline e\<^sub>1) (inline e\<^sub>2)"

lemma "lval e s = aval (inline e) s"
  apply(induction e arbitrary: s)
     apply(auto simp add: subst_lemma)
  done

text{* The @{const LET} constructor introduces a local variable:
the value of @{term "LET x e\<^sub>1 e\<^sub>2"} is the value of @{text e\<^sub>2}
in the state where @{text x} is bound to the value of @{text e\<^sub>1} in the original state.
Define a function @{const lval} @{text"::"} @{typ "lexp \<Rightarrow> state \<Rightarrow> int"}
that evaluates @{typ lexp} expressions. Remember @{term"s(x := i)"}.

Define a conversion @{const inline} @{text"::"} @{typ "lexp \<Rightarrow> aexp"}.
The expression \mbox{@{term "LET x e\<^sub>1 e\<^sub>2"}} is inlined by substituting
the converted form of @{text e\<^sub>1} for @{text x} in the converted form of @{text e\<^sub>2}.
See Exercise~\ref{exe:subst} for more on substitution.
Prove that @{const inline} is correct w.r.t.\ evaluation.
\endexercise

\exercise
Show that equality and less-or-equal tests on @{text aexp} are definable
*}

definition Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"Or e\<^sub>1 e\<^sub>2 = Not (And (Not e\<^sub>1) (Not e\<^sub>2))"

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq e\<^sub>1 e\<^sub>2 = And (Not (Less e\<^sub>1 e\<^sub>2)) (Not (Less e\<^sub>2 e\<^sub>1))"

value "bval (Eq (N 5) (Plus (N 3) (V ''x''))) <''x'' := 2>"

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le e\<^sub>1 e\<^sub>2 = Or (Eq e\<^sub>1 e\<^sub>2) (Less e\<^sub>1 e\<^sub>2)"

value "bval (Le (N 5) (Plus (N 3) (V ''x''))) <''x'' := 3>"

text{*
and prove that they do what they are supposed to:
*}

lemma bval_Eq: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  apply(simp add: Eq_def)
  apply(auto)
  done

lemma bval_Le: "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
  apply(simp add: Le_def Eq_def Or_def)
  apply(auto)
  done

text{*
\endexercise

\exercise
Consider an alternative type of boolean expressions featuring a conditional: *}

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

text {*  First define an evaluation function analogously to @{const bval}: *}

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool"
  where
    "ifval (Bc2 b) s = b"
  | "ifval (If e\<^sub>1 e\<^sub>2 e\<^sub>3) s =
      (if ifval e\<^sub>1 s then
         ifval e\<^sub>2 s
       else
         ifval e\<^sub>3 s)"
  | "ifval (Less2 a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"

text{* Then define two translation functions *}

fun b2ifexp :: "bexp \<Rightarrow> ifexp"
  where
    "b2ifexp (Bc b) = Bc2 b"
  | "b2ifexp (Not e) = (If (b2ifexp e) (Bc2 False) (Bc2 True))"
  | "b2ifexp (And e\<^sub>1 e\<^sub>2) =
      (If (b2ifexp e\<^sub>1)
        (If (b2ifexp e\<^sub>2)
          (Bc2 True)
          (Bc2 False))
        (Bc2 False))"
  | "b2ifexp (Less a\<^sub>1 a\<^sub>2) = Less2 a\<^sub>1 a\<^sub>2"

(* if a then b else c \<equiv> (a \<and> b) \<or> (\<not>a \<and> c) *)
fun if2bexp :: "ifexp \<Rightarrow> bexp"
  where
    "if2bexp (Bc2 b) = Bc b"
  | "if2bexp (If e\<^sub>1 e\<^sub>2 e\<^sub>3) =
      (let be\<^sub>1 = if2bexp e\<^sub>1 in
        Or (And      be\<^sub>1  (if2bexp e\<^sub>2))
           (And (Not be\<^sub>1) (if2bexp e\<^sub>3)))"
  | "if2bexp (Less2 a\<^sub>1 a\<^sub>2) = Less a\<^sub>1 a\<^sub>2"

text{* and prove their correctness: *}

lemma "bval (if2bexp exp) s = ifval exp s"
  apply(induction exp arbitrary: s)
    apply(auto simp add: Let_def Or_def)
  done

lemma "ifval (b2ifexp exp) s = bval exp s"
  apply(induction exp arbitrary: s)
     apply(auto)
  done

text{*
\endexercise

\exercise
We define a new type of purely boolean expressions without any arithmetic
*}

datatype pbexp =
  VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

text{*
where variables range over values of type @{typ bool},
as can be seen from the evaluation function:
*}

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool"
  where
    "pbval (VAR x) s = s x"
  | "pbval (NOT b) s = (\<not> pbval b s)"
  | "pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)"
  | "pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

text {* Define a function that checks whether a boolean expression is in NNF
(negation normal form), i.e., if @{const NOT} is only applied directly
to @{const VAR}s: *}

fun is_nnf :: "pbexp \<Rightarrow> bool"
  where
    "is_nnf (VAR x) = True"
  | "is_nnf (NOT (VAR x)) = True"
  | "is_nnf (NOT b) = False"
  | "is_nnf (AND b\<^sub>1 b\<^sub>2) = (is_nnf b\<^sub>1 & is_nnf b\<^sub>2)"
  | "is_nnf (OR b\<^sub>1 b\<^sub>2) = (is_nnf b\<^sub>1 & is_nnf b\<^sub>2)"

text{*
Now define a function that converts a @{text bexp} into NNF by pushing
@{const NOT} inwards as much as possible:
*}

fun nnf :: "pbexp \<Rightarrow> pbexp"
  where
    "nnf (VAR x) = VAR x"
  | "nnf (NOT (AND b\<^sub>1 b\<^sub>2)) = OR (nnf (NOT b\<^sub>1)) (nnf (NOT b\<^sub>2))"
  | "nnf (NOT (OR b\<^sub>1 b\<^sub>2)) = AND (nnf (NOT b\<^sub>1)) (nnf (NOT b\<^sub>2))"
  | "nnf (NOT (NOT b)) = nnf b"
  | "nnf (AND b\<^sub>1 b\<^sub>2) = AND (nnf b\<^sub>1) (nnf b\<^sub>2)"
  | "nnf (OR b\<^sub>1 b\<^sub>2) = OR (nnf b\<^sub>1) (nnf b\<^sub>2)"
  | "nnf b = b"

text{*
Prove that @{const nnf} does what it is supposed to do:
*}

lemma pbval_nnf: "pbval (nnf b) s = pbval b s"
  apply(induction b arbitrary:s rule:nnf.induct)
    apply(auto)
  done

lemma is_nnf_nnf: "is_nnf (nnf b)"
  apply(induction b rule:nnf.induct)
    apply(auto)
  done

text{*
An expression is in DNF (disjunctive normal form) if it is in NNF
and if no @{const OR} occurs below an @{const AND}. Define a corresponding
test:
*}

fun is_dnf :: "pbexp \<Rightarrow> bool"
  where
    "is_dnf (AND (OR _ _) _) = False"
  | "is_dnf (AND _ (OR _ _)) = False"
  | "is_dnf (AND b\<^sub>1 b\<^sub>2) = (is_dnf b\<^sub>1 & is_dnf b\<^sub>2)"
  | "is_dnf (OR b\<^sub>1 b\<^sub>2) = (is_dnf b\<^sub>1 & is_dnf b\<^sub>2)"
  | "is_dnf b = is_nnf b"

value "is_dnf (OR (AND (VAR ''A'') (VAR ''B'')) (NOT (VAR ''A'')))"
value "is_dnf (NOT (OR (VAR ''A'') (VAR ''B'')))"
value "is_dnf (OR (VAR ''A'')
                  (AND (VAR ''B'')
                       (OR (VAR ''C'')
                           (VAR ''D''))))"

text {*
An NNF can be converted into a DNF in a bottom-up manner.
The critical case is the conversion of @{term (sub) "AND b1 b2"}.
Having converted @{text b\<^sub>1} and @{text b\<^sub>2}, apply distributivity of @{const AND}
over @{const OR}. If we write @{const OR} as a multi-argument function,
we can express the distributivity step as follows:
@{text "dist_AND (OR a\<^sub>1 ... a\<^sub>n) (OR b\<^sub>1 ... b\<^sub>m)"}
= @{text "OR (AND a\<^sub>1 b\<^sub>1) (AND a\<^sub>1 b\<^sub>2) ... (AND a\<^sub>n b\<^sub>m)"}. Define
*}

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp"
  where
    "dist_AND b (OR c\<^sub>1 c\<^sub>2) = OR (dist_AND b c\<^sub>1) (dist_AND b c\<^sub>2)"
  | "dist_AND (OR b\<^sub>1 b\<^sub>2) c = OR (dist_AND b\<^sub>1 c) (dist_AND b\<^sub>2 c)"
  | "dist_AND b c = AND b c"

value "dist_AND (OR (VAR ''A1'') (VAR ''A2''))
                (OR (VAR ''B1'') (VAR ''B2''))"

text {* and prove that it behaves as follows: *}

lemma pbval_dist: "pbval (dist_AND b1 b2) s = pbval (AND b1 b2) s"
  apply(induction b1 b2 arbitrary:s rule:dist_AND.induct)
    apply(auto)
  done

lemma is_dnf_dist: "is_dnf b1 \<Longrightarrow> is_dnf b2 \<Longrightarrow> is_dnf (dist_AND b1 b2)"
  apply(induction b1 b2 rule:dist_AND.induct)
    apply(auto)
  done

text {* Use @{const dist_AND} to write a function that converts an NNF
  to a DNF in the above bottom-up manner.
*}

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp"
  where
    "dnf_of_nnf (AND b\<^sub>1 b\<^sub>2) = dist_AND (dnf_of_nnf b\<^sub>1) (dnf_of_nnf b\<^sub>2)"
  | "dnf_of_nnf (OR b\<^sub>1 b\<^sub>2) = OR (dnf_of_nnf b\<^sub>1) (dnf_of_nnf b\<^sub>2)"
  | "dnf_of_nnf b = b"

text {* Prove the correctness of your function: *}

lemma "pbval (dnf_of_nnf b) s = pbval b s"
  apply(induction b arbitrary:s rule:dnf_of_nnf.induct)
    apply(auto simp add:pbval_dist)
  done

lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
  apply(induction b rule: dnf_of_nnf.induct)
    apply(auto simp add:is_dnf_dist)
  done

text{*
\endexercise

\exercise\label{exe:stack-underflow}
A \concept{stack underflow} occurs when executing an @{text ADD}
instruction on a stack of size less than two. In our semantics
stack underflow leads to a term involving @{term "hd []"},
which is not an error or exception --- HOL does not
have those concepts --- but some unspecified value. Modify
theory @{theory ASM} such that stack underflow is modelled by @{const None}
and normal execution by @{text Some}, i.e., the execution functions
have return type @{typ "stack option"}. Modify all theorems and proofs
accordingly.
Hint: you may find @{text"split: option.split"} useful in your proofs.
*}

text{*
\endexercise

\exercise\label{exe:register-machine}
This exercise is about a register machine
and compiler for @{typ aexp}. The machine instructions are
*}
type_synonym reg = nat
datatype instr = LDI val reg | LD vname reg | ADD reg reg

text {*
where type @{text reg} is a synonym for @{typ nat}.
Instruction @{term "LDI i r"} loads @{text i} into register @{text r},
@{term "LD x r"} loads the value of @{text x} into register @{text r},
and @{term[names_short] "ADD r\<^sub>1 r\<^sub>2"} adds register @{text r\<^sub>2} to register @{text r\<^sub>1}.

Define the execution of an instruction given a state and a register state;
the result is the new register state: *}

type_synonym rstate = "reg \<Rightarrow> val"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate"
  where
    "exec1 (LDI v r) _ rs = rs(r := v)"
  | "exec1 (LD vn r) s rs = rs(r := s vn)"
  | "exec1 (ADD r\<^sub>1 r\<^sub>2) _ rs = rs(r\<^sub>1 := rs r\<^sub>1 + rs r\<^sub>2)"

text{*
Define the execution @{const[source] exec} of a list of instructions as for the stack machine.*}

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate"
  where
    "exec [] _ rs = rs"
  | "exec (x#xs) s rs = exec xs s (exec1 x s rs)"

value "exec [LDI 2 0, LDI 2 1, ADD 0 1] <> <> 0"
value "exec [LDI 2 0, LD ''x'' 1, ADD 0 1] <''x'' := 3> <> 0"

text{*
The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into @{text r}. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "< r"} should be left alone.
Define the compiler and prove it correct:
*}

fun comp :: "aexp \<Rightarrow> reg \<Rightarrow> instr list"
  where
    "comp (N n) r = [LDI n r]"
  | "comp (V x) r = [LD x r]"
  | "comp (Plus e\<^sub>1 e\<^sub>2) r = comp e\<^sub>1 r @ comp e\<^sub>2 (r+1) @ [ADD r (r+1)]"

value "comp (Plus (N 2) (N 2)) 0"
value "comp (Plus (Plus (N 1) (N 2)) (Plus (N 1) (N 0))) 0"

value "exec (comp
              (Plus (Plus (N 2) (N 2)) (Plus (N 1) (N 5)))
              0)
            <>
            <>
            0"

lemma exec_append: "exec (p\<^sub>1 @ p\<^sub>2) s rs = exec p\<^sub>2 s (exec p\<^sub>1 s rs)"
  apply(induction p\<^sub>1 arbitrary: rs)
   apply(auto)
  done

lemma exec_safe: "rn > r \<Longrightarrow> exec (comp a rn) s rs r = rs r"
  apply(induction a arbitrary: r rn rs)
    apply(auto simp add: exec_append)
  done

theorem "exec (comp a r) s rs r = aval a s"
  apply(induction a arbitrary: r rs)
    apply(auto simp add: exec_append exec_safe)
  done

text{*
\endexercise

\exercise\label{exe:accumulator}
This exercise is a variation of the previous one
with a different instruction set:
*}

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

text{*
All instructions refer implicitly to register 0 as a source or target:
@{const LDI0} and @{const LD0} load a value into register 0, @{term "MV0 r"}
copies the value in register 0 into register @{text r}, and @{term "ADD0 r"}
adds the value in register @{text r} to the value in register 0;
@{term "MV0 0"} and @{term "ADD0 0"} are legal. Define the execution functions
*}

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate"
  where
    "exec01 (LDI0 n) s rs = rs(0 := n)"
  | "exec01 (LD0 vn) s rs = rs(0 := s vn)"
  | "exec01 (MV0 r) s rs = rs(r := rs 0)"
  | "exec01 (ADD0 r) s rs = rs(0 := rs 0 + rs r)"

fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate"
  where
    "exec0 [] s rs = rs"
  | "exec0 (x#xs) s rs = exec0 xs s (exec01 x s rs)"

text{*
and @{const exec0} for instruction lists.

The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into register 0. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "\<le> r"} should be left alone
(with the exception of 0). Define the compiler and prove it correct:
*}

fun comp0 :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list"
  where
    "comp0 (N n) r = [LDI0 n]"
  | "comp0 (V x) r = [LD0 x]"
  | "comp0 (Plus e\<^sub>1 e\<^sub>2) r = comp0 e\<^sub>1 r @ [MV0 (r+1)] @ comp0 e\<^sub>2 (r+1) @ [ADD0 (r+1)]"

lemma comp0_append: "exec0 (p\<^sub>1 @ p\<^sub>2) s rs = exec0 p\<^sub>2 s (exec0 p\<^sub>1 s rs)"
  apply(induction p\<^sub>1 arbitrary: rs)
   apply(auto)
  done

lemma comp0_safe: "\<lbrakk>r \<noteq> 0 \<and> rn \<ge> r\<rbrakk> \<Longrightarrow> exec0 (comp0 a rn) s rs r = rs r"
  apply(induction a arbitrary: r rn rs)
    apply(auto simp add: comp0_append)
  done

theorem "exec0 (comp0 a r) s rs 0 = aval a s"
  apply(induction a arbitrary: r rs)
    apply(auto simp add: comp0_append comp0_safe)
  done

text{*
\endexercise
*}

end