(*  Title:      HOL/Order_Relation.thy
    Author:     Tobias Nipkow
    Author:     Andrei Popescu, TU Muenchen
*)

section \<open>Orders as Relations\<close>

theory Order_Relation
imports Wfrec
begin

subsection \<open>Orders on a set\<close>

definition "preorder_on A r \<equiv> refl_on A r \<and> trans r"

definition "partial_order_on A r \<equiv> preorder_on A r \<and> antisym r"

definition "linear_order_on A r \<equiv> partial_order_on A r \<and> total_on A r"

definition "strict_linear_order_on A r \<equiv> trans r \<and> irrefl r \<and> total_on A r"

definition "well_order_on A r \<equiv> linear_order_on A r \<and> wf(r - Id)"

lemmas order_on_defs =
  preorder_on_def partial_order_on_def linear_order_on_def
  strict_linear_order_on_def well_order_on_def

lemma partial_order_onD:
  assumes "partial_order_on A r" shows "refl_on A r" and "trans r" and "antisym r"
  using assms unfolding partial_order_on_def preorder_on_def by auto

lemma preorder_on_empty[simp]: "preorder_on {} {}"
  by (simp add: preorder_on_def trans_def)

lemma partial_order_on_empty[simp]: "partial_order_on {} {}"
  by (simp add: partial_order_on_def)

lemma lnear_order_on_empty[simp]: "linear_order_on {} {}"
  by (simp add: linear_order_on_def)

lemma well_order_on_empty[simp]: "well_order_on {} {}"
  by (simp add: well_order_on_def)

lemma preorder_on_converse[simp]: "preorder_on A (r\<inverse>) = preorder_on A r"
  by (simp add: preorder_on_def)

lemma partial_order_on_converse[simp]: "partial_order_on A (r\<inverse>) = partial_order_on A r"
  by (simp add: partial_order_on_def)

lemma linear_order_on_converse[simp]: "linear_order_on A (r\<inverse>) = linear_order_on A r"
  by (simp add: linear_order_on_def)

lemma partial_order_on_acyclic:
  "partial_order_on A r \<Longrightarrow> acyclic (r - Id)"
  by (simp add: acyclic_irrefl partial_order_on_def preorder_on_def trans_diff_Id)

lemma partial_order_on_well_order_on:
  "finite r \<Longrightarrow> partial_order_on A r \<Longrightarrow> wf (r - Id)"
  by (simp add: finite_acyclic_wf partial_order_on_acyclic)

lemma strict_linear_order_on_diff_Id: "linear_order_on A r \<Longrightarrow> strict_linear_order_on A (r - Id)"
  by (simp add: order_on_defs trans_diff_Id)

lemma linear_order_on_singleton [simp]: "linear_order_on {x} {(x, x)}"
  by (simp add: order_on_defs)

lemma linear_order_on_acyclic:
  assumes "linear_order_on A r"
  shows "acyclic (r - Id)"
  using strict_linear_order_on_diff_Id[OF assms]
  by (auto simp add: acyclic_irrefl strict_linear_order_on_def)

lemma linear_order_on_well_order_on:
  assumes "finite r"
  shows "linear_order_on A r \<longleftrightarrow> well_order_on A r"
  unfolding well_order_on_def
  using assms finite_acyclic_wf[OF _ linear_order_on_acyclic, of r] by blast

subsection \<open>Orders on the field\<close>

abbreviation "Refl r \<equiv> refl_on (Field r) r"

abbreviation "Preorder r \<equiv> preorder_on (Field r) r"

abbreviation "Partial_order r \<equiv> partial_order_on (Field r) r"

abbreviation "Total r \<equiv> total_on (Field r) r"

abbreviation "Linear_order r \<equiv> linear_order_on (Field r) r"

abbreviation "Well_order r \<equiv> well_order_on (Field r) r"

lemma subset_Image_Image_iff:
  "Preorder r \<Longrightarrow> A \<subseteq> Field r \<Longrightarrow> B \<subseteq> Field r \<Longrightarrow>
    r `` A \<subseteq> r `` B \<longleftrightarrow> (\<forall>a\<in>A.\<exists>b\<in>B. (b, a) \<in> r)"
  apply (simp add: preorder_on_def refl_on_def Image_def subset_eq)
  apply (simp only: trans_def)
  apply fast
  done

lemma subset_Image1_Image1_iff:
  "Preorder r \<Longrightarrow> a \<in> Field r \<Longrightarrow> b \<in> Field r \<Longrightarrow> r `` {a} \<subseteq> r `` {b} \<longleftrightarrow> (b, a) \<in> r"
  by (simp add: subset_Image_Image_iff)

lemma Refl_antisym_eq_Image1_Image1_iff:
  assumes "Refl r"
    and as: "antisym r"
    and abf: "a \<in> Field r" "b \<in> Field r"
  shows "r `` {a} = r `` {b} \<longleftrightarrow> a = b"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then have *: "\<And>x. (a, x) \<in> r \<longleftrightarrow> (b, x) \<in> r"
    by (simp add: set_eq_iff)
  have "(a, a) \<in> r" "(b, b) \<in> r" using \<open>Refl r\<close> abf by (simp_all add: refl_on_def)
  then have "(a, b) \<in> r" "(b, a) \<in> r" using *[of a] *[of b] by simp_all
  then show ?rhs
    using \<open>antisym r\<close>[unfolded antisym_def] by blast
next
  assume ?rhs
  then show ?lhs by fast
qed

lemma Partial_order_eq_Image1_Image1_iff:
  "Partial_order r \<Longrightarrow> a \<in> Field r \<Longrightarrow> b \<in> Field r \<Longrightarrow> r `` {a} = r `` {b} \<longleftrightarrow> a = b"
  by (auto simp: order_on_defs Refl_antisym_eq_Image1_Image1_iff)

lemma Total_Id_Field:
  assumes "Total r"
    and not_Id: "\<not> r \<subseteq> Id"
  shows "Field r = Field (r - Id)"
proof -
  have "Field r \<subseteq> Field (r - Id)"
  proof (rule subsetI)
    fix a assume *: "a \<in> Field r"
    from not_Id have "r \<noteq> {}" by fast
    with not_Id obtain b and c where "b \<noteq> c \<and> (b,c) \<in> r" by auto
    then have "b \<noteq> c \<and> {b, c} \<subseteq> Field r" by (auto simp: Field_def)
    with * obtain d where "d \<in> Field r" "d \<noteq> a" by auto
    with * \<open>Total r\<close> have "(a, d) \<in> r \<or> (d, a) \<in> r" by (simp add: total_on_def)
    with \<open>d \<noteq> a\<close> show "a \<in> Field (r - Id)" unfolding Field_def by blast
  qed
  then show ?thesis
    using mono_Field[of "r - Id" r] Diff_subset[of r Id] by auto
qed

subsection\<open>Relations given by a predicate and the field\<close>

definition relation_of :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set"
  where "relation_of P A \<equiv> { (a, b) \<in> A \<times> A. P a b }"

lemma Field_relation_of:
  assumes "refl_on A (relation_of P A)" shows "Field (relation_of P A) = A"
  using assms unfolding refl_on_def Field_def by auto

lemma partial_order_on_relation_ofI:
  assumes refl: "\<And>a. a \<in> A \<Longrightarrow> P a a"
    and trans: "\<And>a b c. \<lbrakk> a \<in> A; b \<in> A; c \<in> A \<rbrakk> \<Longrightarrow> P a b \<Longrightarrow> P b c \<Longrightarrow> P a c"
    and antisym: "\<And>a b. \<lbrakk> a \<in> A; b \<in> A \<rbrakk> \<Longrightarrow> P a b \<Longrightarrow> P b a \<Longrightarrow> a = b"
  shows "partial_order_on A (relation_of P A)"
proof -
  from refl have "refl_on A (relation_of P A)"
    unfolding refl_on_def relation_of_def by auto
  moreover have "trans (relation_of P A)" and "antisym (relation_of P A)"
    unfolding relation_of_def
    by (auto intro: transI dest: trans, auto intro: antisymI dest: antisym)
  ultimately show ?thesis
    unfolding partial_order_on_def preorder_on_def by simp
qed

lemma Partial_order_relation_ofI:
  assumes "partial_order_on A (relation_of P A)" shows "Partial_order (relation_of P A)"
  using Field_relation_of assms partial_order_on_def preorder_on_def by fastforce

subsection \<open>Orders on a type\<close>

abbreviation "strict_linear_order \<equiv> strict_linear_order_on UNIV"

abbreviation "linear_order \<equiv> linear_order_on UNIV"

abbreviation "well_order \<equiv> well_order_on UNIV"

subsection \<open>Order-like relations\<close>

text \<open>
  In this subsection, we develop basic concepts and results pertaining
  to order-like relations, i.e., to reflexive and/or transitive and/or symmetric and/or
  total relations. We also further define upper and lower bounds operators.
\<close>

subsubsection \<open>Auxiliaries\<close>

lemma refl_on_domain: "refl_on A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> a \<in> A \<and> b \<in> A"
  by (auto simp add: refl_on_def)

corollary well_order_on_domain: "well_order_on A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> a \<in> A \<and> b \<in> A"
  by (auto simp add: refl_on_domain order_on_defs)

lemma well_order_on_Field: "well_order_on A r \<Longrightarrow> A = Field r"
  by (auto simp add: refl_on_def Field_def order_on_defs)

lemma well_order_on_Well_order: "well_order_on A r \<Longrightarrow> A = Field r \<and> Well_order r"
  using well_order_on_Field [of A] by auto

lemma Total_subset_Id:
  assumes "Total r"
    and "r \<subseteq> Id"
  shows "r = {} \<or> (\<exists>a. r = {(a, a)})"
proof -
  have "\<exists>a. r = {(a, a)}" if "r \<noteq> {}"
  proof -
    from that obtain a b where ab: "(a, b) \<in> r" by fast
    with \<open>r \<subseteq> Id\<close> have "a = b" by blast
    with ab have aa: "(a, a) \<in> r" by simp
    have "a = c \<and> a = d" if "(c, d) \<in> r" for c d
    proof -
      from that have "{a, c, d} \<subseteq> Field r"
        using ab unfolding Field_def by blast
      then have "((a, c) \<in> r \<or> (c, a) \<in> r \<or> a = c) \<and> ((a, d) \<in> r \<or> (d, a) \<in> r \<or> a = d)"
        using \<open>Total r\<close> unfolding total_on_def by blast
      with \<open>r \<subseteq> Id\<close> show ?thesis by blast
    qed
    then have "r \<subseteq> {(a, a)}" by auto
    with aa show ?thesis by blast
  qed
  then show ?thesis by blast
qed

lemma Linear_order_in_diff_Id:
  assumes "Linear_order r"
    and "a \<in> Field r"
    and "b \<in> Field r"
  shows "(a, b) \<in> r \<longleftrightarrow> (b, a) \<notin> r - Id"
  using assms unfolding order_on_defs total_on_def antisym_def Id_def refl_on_def by force

subsubsection \<open>The upper and lower bounds operators\<close>

text \<open>
  Here we define upper (``above") and lower (``below") bounds operators. We
  think of \<open>r\<close> as a \<^emph>\<open>non-strict\<close> relation. The suffix \<open>S\<close> at the names of
  some operators indicates that the bounds are strict -- e.g., \<open>underS a\<close> is
  the set of all strict lower bounds of \<open>a\<close> (w.r.t. \<open>r\<close>). Capitalization of
  the first letter in the name reminds that the operator acts on sets, rather
  than on individual elements.
\<close>

definition under :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "under r a \<equiv> {b. (b, a) \<in> r}"

definition underS :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "underS r a \<equiv> {b. b \<noteq> a \<and> (b, a) \<in> r}"

definition Under :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "Under r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (b, a) \<in> r}"

definition UnderS :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "UnderS r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (b, a) \<in> r}"

definition above :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "above r a \<equiv> {b. (a, b) \<in> r}"

definition aboveS :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "aboveS r a \<equiv> {b. b \<noteq> a \<and> (a, b) \<in> r}"

definition Above :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "Above r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (a, b) \<in> r}"

definition AboveS :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "AboveS r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (a, b) \<in> r}"

definition ofilter :: "'a rel \<Rightarrow> 'a set \<Rightarrow> bool"
  where "ofilter r A \<equiv> A \<subseteq> Field r \<and> (\<forall>a \<in> A. under r a \<subseteq> A)"

text \<open>
  Note: In the definitions of \<open>Above[S]\<close> and \<open>Under[S]\<close>, we bounded
  comprehension by \<open>Field r\<close> in order to properly cover the case of \<open>A\<close> being
  empty.
\<close>

lemma underS_subset_under: "underS r a \<subseteq> under r a"
  by (auto simp add: underS_def under_def)

lemma underS_notIn: "a \<notin> underS r a"
  by (simp add: underS_def)

lemma Refl_under_in: "Refl r \<Longrightarrow> a \<in> Field r \<Longrightarrow> a \<in> under r a"
  by (simp add: refl_on_def under_def)

lemma AboveS_disjoint: "A \<inter> (AboveS r A) = {}"
  by (auto simp add: AboveS_def)

lemma in_AboveS_underS: "a \<in> Field r \<Longrightarrow> a \<in> AboveS r (underS r a)"
  by (auto simp add: AboveS_def underS_def)

lemma Refl_under_underS: "Refl r \<Longrightarrow> a \<in> Field r \<Longrightarrow> under r a = underS r a \<union> {a}"
  unfolding under_def underS_def
  using refl_on_def[of _ r] by fastforce

lemma underS_empty: "a \<notin> Field r \<Longrightarrow> underS r a = {}"
  by (auto simp: Field_def underS_def)

lemma under_Field: "under r a \<subseteq> Field r"
  by (auto simp: under_def Field_def)

lemma underS_Field: "underS r a \<subseteq> Field r"
  by (auto simp: underS_def Field_def)

lemma underS_Field2: "a \<in> Field r \<Longrightarrow> underS r a \<subset> Field r"
  using underS_notIn underS_Field by fast

lemma underS_Field3: "Field r \<noteq> {} \<Longrightarrow> underS r a \<subset> Field r"
  by (cases "a \<in> Field r") (auto simp: underS_Field2 underS_empty)

lemma AboveS_Field: "AboveS r A \<subseteq> Field r"
  by (auto simp: AboveS_def Field_def)

lemma under_incr:
  assumes "trans r"
    and "(a, b) \<in> r"
  shows "under r a \<subseteq> under r b"
  unfolding under_def
proof safe
  fix x assume "(x, a) \<in> r"
  with assms trans_def[of r] show "(x, b) \<in> r" by blast
qed

lemma underS_incr:
  assumes "trans r"
    and "antisym r"
    and ab: "(a, b) \<in> r"
  shows "underS r a \<subseteq> underS r b"
  unfolding underS_def
proof safe
  assume *: "b \<noteq> a" and **: "(b, a) \<in> r"
  with \<open>antisym r\<close> antisym_def[of r] ab show False
    by blast
next
  fix x assume "x \<noteq> a" "(x, a) \<in> r"
  with ab \<open>trans r\<close> trans_def[of r] show "(x, b) \<in> r"
    by blast
qed

lemma underS_incl_iff:
  assumes LO: "Linear_order r"
    and INa: "a \<in> Field r"
    and INb: "b \<in> Field r"
  shows "underS r a \<subseteq> underS r b \<longleftrightarrow> (a, b) \<in> r"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs
  with \<open>Linear_order r\<close> show ?lhs
    by (simp add: order_on_defs underS_incr)
next
  assume *: ?lhs
  have "(a, b) \<in> r" if "a = b"
    using assms that by (simp add: order_on_defs refl_on_def)
  moreover have False if "a \<noteq> b" "(b, a) \<in> r"
  proof -
    from that have "b \<in> underS r a" unfolding underS_def by blast
    with * have "b \<in> underS r b" by blast
    then show ?thesis by (simp add: underS_notIn)
  qed
  ultimately show "(a,b) \<in> r"
    using assms order_on_defs[of "Field r" r] total_on_def[of "Field r" r] by blast
qed

lemma finite_Partial_order_induct[consumes 3, case_names step]:
  assumes "Partial_order r"
    and "x \<in> Field r"
    and "finite r"
    and step: "\<And>x. x \<in> Field r \<Longrightarrow> (\<And>y. y \<in> aboveS r x \<Longrightarrow> P y) \<Longrightarrow> P x"
  shows "P x"
  using assms(2)
proof (induct rule: wf_induct[of "r\<inverse> - Id"])
  case 1
  from assms(1,3) show "wf (r\<inverse> - Id)"
    using partial_order_on_well_order_on partial_order_on_converse by blast
next
  case prems: (2 x)
  show ?case
    by (rule step) (use prems in \<open>auto simp: aboveS_def intro: FieldI2\<close>)
qed

lemma finite_Linear_order_induct[consumes 3, case_names step]:
  assumes "Linear_order r"
    and "x \<in> Field r"
    and "finite r"
    and step: "\<And>x. x \<in> Field r \<Longrightarrow> (\<And>y. y \<in> aboveS r x \<Longrightarrow> P y) \<Longrightarrow> P x"
  shows "P x"
  using assms(2)
proof (induct rule: wf_induct[of "r\<inverse> - Id"])
  case 1
  from assms(1,3) show "wf (r\<inverse> - Id)"
    using linear_order_on_well_order_on linear_order_on_converse
    unfolding well_order_on_def by blast
next
  case prems: (2 x)
  show ?case
    by (rule step) (use prems in \<open>auto simp: aboveS_def intro: FieldI2\<close>)
qed

subsection \<open>Variations on Well-Founded Relations\<close>

text \<open>
  This subsection contains some variations of the results from \<^theory>\<open>HOL.Wellfounded\<close>:
    \<^item> means for slightly more direct definitions by well-founded recursion;
    \<^item> variations of well-founded induction;
    \<^item> means for proving a linear order to be a well-order.
\<close>

subsubsection \<open>Characterizations of well-foundedness\<close>

text \<open>
  A transitive relation is well-founded iff it is ``locally'' well-founded,
  i.e., iff its restriction to the lower bounds of of any element is
  well-founded.
\<close>

lemma trans_wf_iff:
  assumes "trans r"
  shows "wf r \<longleftrightarrow> (\<forall>a. wf (r \<inter> (r\<inverse>``{a} \<times> r\<inverse>``{a})))"
proof -
  define R where "R a = r \<inter> (r\<inverse>``{a} \<times> r\<inverse>``{a})" for a
  have "wf (R a)" if "wf r" for a
    using that R_def wf_subset[of r "R a"] by auto
  moreover
  have "wf r" if *: "\<forall>a. wf(R a)"
    unfolding wf_def
  proof clarify
    fix phi a
    assume **: "\<forall>a. (\<forall>b. (b, a) \<in> r \<longrightarrow> phi b) \<longrightarrow> phi a"
    define chi where "chi b \<longleftrightarrow> (b, a) \<in> r \<longrightarrow> phi b" for b
    with * have "wf (R a)" by auto
    then have "(\<forall>b. (\<forall>c. (c, b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b) \<longrightarrow> (\<forall>b. chi b)"
      unfolding wf_def by blast
    also have "\<forall>b. (\<forall>c. (c, b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b"
    proof safe
      fix b
      assume "\<forall>c. (c, b) \<in> R a \<longrightarrow> chi c"
      moreover have "(b, a) \<in> r \<Longrightarrow> \<forall>c. (c, b) \<in> r \<and> (c, a) \<in> r \<longrightarrow> phi c \<Longrightarrow> phi b"
      proof -
        assume "(b, a) \<in> r" and "\<forall>c. (c, b) \<in> r \<and> (c, a) \<in> r \<longrightarrow> phi c"
        then have "\<forall>c. (c, b) \<in> r \<longrightarrow> phi c"
          using assms trans_def[of r] by blast
        with ** show "phi b" by blast
      qed
      ultimately show "chi b"
        by (auto simp add: chi_def R_def)
    qed
    finally have  "\<forall>b. chi b" .
    with ** chi_def show "phi a" by blast
  qed
  ultimately show ?thesis unfolding R_def by blast
qed

text\<open>A transitive relation is well-founded if all initial segments are finite.\<close>
corollary wf_finite_segments:
  assumes "irrefl r" and "trans r" and "\<And>x. finite {y. (y, x) \<in> r}"
  shows "wf r"
proof -
  have "\<And>a. acyclic (r \<inter> {x. (x, a) \<in> r} \<times> {x. (x, a) \<in> r})"
  proof -
    fix a
    have "trans (r \<inter> ({x. (x, a) \<in> r} \<times> {x. (x, a) \<in> r}))"
      using assms unfolding trans_def Field_def by blast
    then show "acyclic (r \<inter> {x. (x, a) \<in> r} \<times> {x. (x, a) \<in> r})"
      using assms acyclic_def assms irrefl_def by fastforce
  qed
  then show ?thesis
    by (clarsimp simp: trans_wf_iff wf_iff_acyclic_if_finite converse_def assms)
qed

text \<open>The next lemma is a variation of \<open>wf_eq_minimal\<close> from Wellfounded,
  allowing one to assume the set included in the field.\<close>

lemma wf_eq_minimal2: "wf r \<longleftrightarrow> (\<forall>A. A \<subseteq> Field r \<and> A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a', a) \<notin> r))"
proof-
  let ?phi = "\<lambda>A. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r)"
  have "wf r \<longleftrightarrow> (\<forall>A. ?phi A)"
  proof
    assume "wf r"
    show  "\<forall>A. ?phi A"
    proof clarify
      fix A:: "'a set"
      assume "A \<noteq> {}"
      then obtain x where "x \<in> A"
        by auto
      show "\<exists>a\<in>A. \<forall>a'\<in>A. (a', a) \<notin> r"
        apply (rule wfE_min[of r x A])
          apply fact+
        by blast
    qed
  next
    assume *: "\<forall>A. ?phi A"
    then show "wf r"
      apply (clarsimp simp: ex_in_conv [THEN sym])
      apply (rule wfI_min)
      by fast
  qed
  also have "(\<forall>A. ?phi A) \<longleftrightarrow> (\<forall>B \<subseteq> Field r. ?phi B)"
  proof
    assume "\<forall>A. ?phi A"
    then show "\<forall>B \<subseteq> Field r. ?phi B" by simp
  next
    assume *: "\<forall>B \<subseteq> Field r. ?phi B"
    show "\<forall>A. ?phi A"
    proof clarify
      fix A :: "'a set"
      assume **: "A \<noteq> {}"
      define B where "B = A \<inter> Field r"
      show "\<exists>a \<in> A. \<forall>a' \<in> A. (a', a) \<notin> r"
      proof (cases "B = {}")
        case True
        with ** obtain a where a: "a \<in> A" "a \<notin> Field r"
          unfolding B_def by blast
        with a have "\<forall>a' \<in> A. (a',a) \<notin> r"
          unfolding Field_def by blast
        with a show ?thesis by blast
      next
        case False
        have "B \<subseteq> Field r" unfolding B_def by blast
        with False * obtain a where a: "a \<in> B" "\<forall>a' \<in> B. (a', a) \<notin> r"
          by blast
        have "(a', a) \<notin> r" if "a' \<in> A" for a'
        proof
          assume a'a: "(a', a) \<in> r"
          with that have "a' \<in> B" unfolding B_def Field_def by blast
          with a a'a show False by blast
        qed
        with a show ?thesis unfolding B_def by blast
      qed
    qed
  qed
  finally show ?thesis by blast
qed

subsubsection \<open>Characterizations of well-foundedness\<close>

text \<open>
  The next lemma and its corollary enable one to prove that a linear order is
  a well-order in a way which is more standard than via well-foundedness of
  the strict version of the relation.
\<close>

lemma Linear_order_wf_diff_Id:
  assumes "Linear_order r"
  shows "wf (r - Id) \<longleftrightarrow> (\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r))"
proof (cases "r \<subseteq> Id")
  case True
  then have *: "r - Id = {}" by blast
  have "wf (r - Id)" by (simp add: *)
  moreover have "\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r"
    if *: "A \<subseteq> Field r" and **: "A \<noteq> {}" for A
  proof -
    from \<open>Linear_order r\<close> True
    obtain a where a: "r = {} \<or> r = {(a, a)}"
      unfolding order_on_defs using Total_subset_Id [of r] by blast
    with * ** have "A = {a} \<and> r = {(a, a)}"
      unfolding Field_def by blast
    with a show ?thesis by blast
  qed
  ultimately show ?thesis by blast
next
  case False
  with \<open>Linear_order r\<close> have Field: "Field r = Field (r - Id)"
    unfolding order_on_defs using Total_Id_Field [of r] by blast
  show ?thesis
  proof
    assume *: "wf (r - Id)"
    show "\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r)"
    proof clarify
      fix A
      assume **: "A \<subseteq> Field r" and ***: "A \<noteq> {}"
      then have "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id"
        using Field * unfolding wf_eq_minimal2 by simp
      moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r \<longleftrightarrow> (a', a) \<notin> r - Id"
        using Linear_order_in_diff_Id [OF \<open>Linear_order r\<close>] ** by blast
      ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r" by blast
    qed
  next
    assume *: "\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r)"
    show "wf (r - Id)"
      unfolding wf_eq_minimal2
    proof clarify
      fix A
      assume **: "A \<subseteq> Field(r - Id)" and ***: "A \<noteq> {}"
      then have "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r"
        using Field * by simp
      moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r \<longleftrightarrow> (a', a) \<notin> r - Id"
        using Linear_order_in_diff_Id [OF \<open>Linear_order r\<close>] ** mono_Field[of "r - Id" r] by blast
      ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id"
        by blast
    qed
  qed
qed

corollary Linear_order_Well_order_iff:
  "Linear_order r \<Longrightarrow>
    Well_order r \<longleftrightarrow> (\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r))"
  unfolding well_order_on_def using Linear_order_wf_diff_Id[of r] by blast

end


theory leftpad
  imports Main
  "~~/src/HOL/Library/Code_Target_Nat"
begin

section \<open>define leftpad\<close>

(* left pad. Takes a padding character, a string, and a total length, returns
the string padded to that length with that character. If length is less than
the length of the string, does nothing.

inspired by https://www.hillelwayne.com/post/theorem-prover-showdown/
*)

fun rightPad :: "'a => 'a list => nat => 'a list" where
  "rightPad p [] 0 = []" |
  "rightPad p [] (Suc n) = p # (rightPad p [] n)" |
  "rightPad p (x # xs) 0 = (x # xs)" |
  "rightPad p (x # xs) (Suc n) = x # (rightPad p xs n)"

fun leftPad :: "'a => 'a list => nat => 'a list" where
  "leftPad p xs n = rev (rightPad p (rev xs) n)"

value "leftPad 0 [1,2] 1 :: nat list"
value "leftPad 0 [1,2] 4 :: nat list"
value "leftPad 9 [1,1] 3 :: nat list"

(* Prove:

You have to specify it’s the right length,

that the added characters are all the padding character,

and that the suffix is the original string. *)

section \<open>Proofs\<close>

subsection \<open>right pad\<close>

lemma rightpad_empty_is_replicate:"\<lbrakk>padTo = n\<rbrakk> \<Longrightarrow> rightPad p [] padTo = replicate n p"
proof(induction padTo arbitrary: n)
  case 0
  then show ?case
    by simp
next
  case (Suc padTo)
  then show ?case
    by auto
qed

text "additional characters are padding"
lemma right_pad_adds_padding_character:
  fixes lst :: "'a list"
    and p :: "'a"
    and padTo :: nat
  assumes "length lst < padTo"
    and "length lst + n = padTo"
  shows "\<lbrakk>length lst < padTo; length lst + n = padTo\<rbrakk>
      \<Longrightarrow> drop (length lst) (rightPad p lst padTo) = replicate n p"
proof(induction lst arbitrary: padTo)
  case Nil
  then show ?case
  proof(induction padTo)
    case 0
    then show ?case by simp
  next
    case (Suc padTo)
    then show ?case
      by (simp add: rightpad_empty_is_replicate)
  qed
next
  case (Cons l ls)
  then show ?case
  proof(induction padTo)
    case 0
    then show ?case by simp
  next
    case (Suc padT)
    then show ?case by simp
  qed
qed

text "prefix of result is the list"
lemma right_pad_prefix_is_list:
  fixes lst :: "'a list"
    and p :: "'a"
    and padTo :: nat
  shows "take (length lst) (rightPad p lst padTo) = lst"
proof(induction lst arbitrary: padTo)
  case Nil
  then show ?case
    by simp
next
  case (Cons a lst)
  then show ?case
  proof(induction padTo)
    case 0
    then show ?case
      by simp
  next
    case (Suc padTo)
    then show ?case
      by simp
  qed
qed

text "length is correct"
lemma right_pad_length_is_correct:
  shows "length (rightPad p lst padTo) = max (length lst) padTo"
proof(induction lst arbitrary: padTo)
  case Nil
  then show ?case
    by (simp add: rightpad_empty_is_replicate)
next
  case (Cons a lst)
  then show ?case
  proof(induction padTo)
    case 0
    then show ?case
      by simp
  next
    case (Suc padTo)
    then show ?case
      by simp
  qed
qed

subsection \<open>left pad\<close>

text "length is correct"
theorem left_pad_length_is_correct:
  shows "length (leftPad p lst padTo) = max (length lst) padTo"
  by (simp add: right_pad_length_is_correct)

text "suffix of result is the list"
theorem left_pad_suffix_is_list:
  fixes lst :: "'a list"
    and p :: "'a"
    and padTo :: nat
  assumes "length lst < padTo"
    and "length lst + n = padTo"
  shows "\<lbrakk>length lst + n = padTo\<rbrakk> \<Longrightarrow> drop n (leftPad p lst padTo) = lst"
proof(induction lst)
  case Nil
  then show ?case
    by (simp add: rightpad_empty_is_replicate)
next
  case (Cons l ls)
  then show ?case
  proof(induction padTo)
    case 0
    then show ?case
      by simp
  next
    case (Suc padTo\<^sub>p)
    have "drop n (leftPad p ls padTo\<^sub>p) = ls"
      apply auto
    proof -
      have "length ls \<le> padTo\<^sub>p"
        by (metis (no_types) Suc.prems(2) Suc_inject add.commute add_Suc_right le_add1 length_Cons)
      then have "length (rightPad p (rev ls) padTo\<^sub>p) = padTo\<^sub>p"
        by (simp add: right_pad_length_is_correct)
      then have "length (rightPad p (rev ls) padTo\<^sub>p) - n = length ls"
        by (metis (no_types) Suc.prems(2) add.commute add_Suc_right add_diff_cancel_left' length_Cons)
      then show "drop n (rev (rightPad p (rev ls) padTo\<^sub>p)) = ls"
        by (metis (no_types) drop_rev length_rev rev_rev_ident right_pad_prefix_is_list)
    qed
    then show ?case
      apply auto
      proof -
        have "length (rightPad p (rev ls @ [l]) (Suc padTo\<^sub>p)) - n = length (l # ls)"
          by (metis Suc.prems(2) add_diff_cancel_right' le_add1 length_rev max_def_raw rev.simps(2) right_pad_length_is_correct)
        then show "drop n (rev (rightPad p (rev ls @ [l]) (Suc padTo\<^sub>p))) = l # ls"
          by (metis drop_rev length_rev rev.simps(2) rev_swap right_pad_prefix_is_list)
      qed
  qed
qed

text "additional characters are padding"
theorem left_pad_adds_padding_character:
  fixes lst :: "'a list"
    and p :: "'a"
    and padTo :: nat
    and n :: nat
  assumes "length lst < padTo"
    and "length lst + n = padTo"
  shows "\<lbrakk>length lst < padTo; length lst + n = padTo\<rbrakk>
      \<Longrightarrow> take n (leftPad p lst padTo) = replicate n p"
proof(induction lst arbitrary: padTo)
  case Nil
  then show ?case
  proof(induction padTo)
    case 0
    then show ?case by simp
  next
    case (Suc padTo)
    then show ?case
      apply auto
      by (simp add: replicate_append_same rightpad_empty_is_replicate)
  qed
next
  case (Cons l ls)
  then show ?case
  proof(induction padTo)
    case 0
    then show ?case by simp
  next
    case (Suc padTo\<^sub>p)
    then show ?case
      apply auto
    proof -
      assume a1: "padTo\<^sub>p = length ls + n"
      have f2: "length (rightPad p (rev ls @ [l]) (Suc (length ls + n))) = length (l # ls) + n"
        by (simp add: right_pad_length_is_correct)
      have f3: "length (rev ls @ [l]) + n = Suc padTo\<^sub>p"
        using Suc.prems(3) by auto
      have "length (rev ls @ [l]) < Suc padTo\<^sub>p"
        using Suc.prems(2) by force
      then have "drop (length (rev ls @ [l])) (rightPad p (rev ls @ [l]) (Suc padTo\<^sub>p)) = replicate n p"
        using f3 by (metis (full_types) right_pad_adds_padding_character)
      then show "take n (rev (rightPad p (rev ls @ [l]) (Suc (length ls + n)))) = replicate n p"
        using f2 a1 by (simp add: take_rev)
    qed
  qed
qed


(*
    Authors:    Jose Divasón
                Maximilian Haslbeck
                Sebastiaan Joosten
                René Thiemann
                Akihisa Yamada
    License:    BSD
*)

section \<open>Norms\<close>

text \<open>In this theory we provide the basic definitions and properties of several
  norms of vectors and polynomials.
\<close>

theory Norms
  imports "HOL-Computational_Algebra.Polynomial"
    "HOL-Library.Adhoc_Overloading"
    "Jordan_Normal_Form.Conjugate"
    "Algebraic_Numbers.Resultant" (* only for poly_of_vec *)
    Missing_Lemmas
begin

subsection \<open>L-\<open>\<infinity>\<close> Norms\<close>

consts linf_norm :: "'a \<Rightarrow> 'b" ("\<parallel>(_)\<parallel>\<^sub>\<infinity>")

definition linf_norm_vec where "linf_norm_vec v \<equiv> max_list (map abs (list_of_vec v) @ [0])"
adhoc_overloading linf_norm linf_norm_vec

definition linf_norm_poly where "linf_norm_poly f \<equiv> max_list (map abs (coeffs f) @ [0])"
adhoc_overloading linf_norm linf_norm_poly

lemma linf_norm_vec: "\<parallel>vec n f\<parallel>\<^sub>\<infinity> = max_list (map (abs \<circ> f) [0..<n] @ [0])"
  by (simp add: linf_norm_vec_def)

lemma linf_norm_vec_vCons[simp]: "\<parallel>vCons a v\<parallel>\<^sub>\<infinity> = max \<bar>a\<bar> \<parallel>v\<parallel>\<^sub>\<infinity>"
  by (auto simp: linf_norm_vec_def max_list_Cons)

lemma linf_norm_vec_0 [simp]: "\<parallel>vec 0 f\<parallel>\<^sub>\<infinity> = 0" by (simp add: linf_norm_vec_def)

lemma linf_norm_zero_vec [simp]: "\<parallel>0\<^sub>v n :: 'a :: ordered_ab_group_add_abs vec\<parallel>\<^sub>\<infinity> = 0"
  by (induct n, simp add: zero_vec_def, auto simp: zero_vec_Suc)

lemma linf_norm_vec_ge_0 [intro!]:
  fixes v :: "'a :: ordered_ab_group_add_abs vec"
  shows "\<parallel>v\<parallel>\<^sub>\<infinity> \<ge> 0"
  by (induct v, auto simp: max_def)

lemma linf_norm_vec_eq_0 [simp]:
  fixes v :: "'a :: ordered_ab_group_add_abs vec"
  assumes "v \<in> carrier_vec n"
  shows "\<parallel>v\<parallel>\<^sub>\<infinity> = 0 \<longleftrightarrow> v = 0\<^sub>v n"
  by (insert assms, induct rule: carrier_vec_induct, auto simp: zero_vec_Suc max_def)

lemma linf_norm_vec_greater_0 [simp]:
  fixes v :: "'a :: ordered_ab_group_add_abs vec"
  assumes "v \<in> carrier_vec n"
  shows "\<parallel>v\<parallel>\<^sub>\<infinity> > 0 \<longleftrightarrow> v \<noteq> 0\<^sub>v n"
  by (insert assms, induct rule: carrier_vec_induct, auto simp: zero_vec_Suc max_def)

lemma linf_norm_poly_0 [simp]: "\<parallel>0::_ poly\<parallel>\<^sub>\<infinity> = 0"
  by (simp add: linf_norm_poly_def)

lemma linf_norm_pCons [simp]:
  fixes p :: "'a :: ordered_ab_group_add_abs poly"
  shows "\<parallel>pCons a p\<parallel>\<^sub>\<infinity> = max \<bar>a\<bar> \<parallel>p\<parallel>\<^sub>\<infinity>"
  by (cases "p = 0", cases "a = 0", auto simp: linf_norm_poly_def max_list_Cons)

lemma linf_norm_poly_ge_0 [intro!]:
  fixes f :: "'a :: ordered_ab_group_add_abs poly"
  shows "\<parallel>f\<parallel>\<^sub>\<infinity> \<ge> 0"
  by (induct f, auto simp: max_def)

lemma linf_norm_poly_eq_0 [simp]:
  fixes f :: "'a :: ordered_ab_group_add_abs poly"
  shows "\<parallel>f\<parallel>\<^sub>\<infinity> = 0 \<longleftrightarrow> f = 0"
  by (induct f, auto simp: max_def)

lemma linf_norm_poly_greater_0 [simp]:
  fixes f :: "'a :: ordered_ab_group_add_abs poly"
  shows "\<parallel>f\<parallel>\<^sub>\<infinity> > 0 \<longleftrightarrow> f \<noteq> 0"
  by (induct f, auto simp: max_def)

subsection \<open>Square Norms\<close>

consts sq_norm :: "'a \<Rightarrow> 'b" ("\<parallel>(_)\<parallel>\<^sup>2")

abbreviation "sq_norm_conjugate x \<equiv> x * conjugate x"
adhoc_overloading sq_norm sq_norm_conjugate

subsubsection \<open>Square norms for vectors\<close>

text \<open>We prefer sum\_list over sum because it is not essentially dependent on commutativity,
  and easier for proving.
\<close>
definition "sq_norm_vec v \<equiv> \<Sum>x \<leftarrow> list_of_vec v. \<parallel>x\<parallel>\<^sup>2"
adhoc_overloading sq_norm sq_norm_vec

lemma sq_norm_vec_vCons[simp]: "\<parallel>vCons a v\<parallel>\<^sup>2 = \<parallel>a\<parallel>\<^sup>2 + \<parallel>v\<parallel>\<^sup>2"
  by (simp add: sq_norm_vec_def)

lemma sq_norm_vec_0[simp]: "\<parallel>vec 0 f\<parallel>\<^sup>2 = 0"
  by (simp add: sq_norm_vec_def)

lemma sq_norm_vec_as_cscalar_prod:
  fixes v :: "'a :: conjugatable_ring vec"
  shows "\<parallel>v\<parallel>\<^sup>2 = v \<bullet>c v"
  by (induct v, simp_all add: sq_norm_vec_def)

lemma sq_norm_zero_vec[simp]: "\<parallel>0\<^sub>v n :: 'a :: conjugatable_ring vec\<parallel>\<^sup>2 = 0"
  by (simp add: sq_norm_vec_as_cscalar_prod)

lemmas sq_norm_vec_ge_0 [intro!] = conjugate_square_ge_0_vec[folded sq_norm_vec_as_cscalar_prod]

lemmas sq_norm_vec_eq_0 [simp] = conjugate_square_eq_0_vec[folded sq_norm_vec_as_cscalar_prod]

lemmas sq_norm_vec_greater_0 [simp] = conjugate_square_greater_0_vec[folded sq_norm_vec_as_cscalar_prod]

subsubsection \<open>Square norm for polynomials\<close>

definition sq_norm_poly where "sq_norm_poly p \<equiv> \<Sum>a\<leftarrow>coeffs p. \<parallel>a\<parallel>\<^sup>2"

adhoc_overloading sq_norm sq_norm_poly

lemma sq_norm_poly_0 [simp]: "\<parallel>0::_poly\<parallel>\<^sup>2 = 0"
  by (auto simp: sq_norm_poly_def)

lemma sq_norm_poly_pCons [simp]:
  fixes a :: "'a :: conjugatable_ring"
  shows "\<parallel>pCons a p\<parallel>\<^sup>2 = \<parallel>a\<parallel>\<^sup>2 + \<parallel>p\<parallel>\<^sup>2"
  by (cases "p = 0"; cases "a = 0", auto simp: sq_norm_poly_def)

lemma sq_norm_poly_eq_0 [simp]:
  fixes p :: "'a :: {conjugatable_ordered_ring,ring_no_zero_divisors} poly"
  shows "\<parallel>p\<parallel>\<^sup>2 = 0 \<longleftrightarrow> p = 0"
proof (induct p)
  case IH: (pCons a p)
  show ?case
  proof (cases "a = 0")
    case True
    with IH show ?thesis by simp
  next
    case False
    then have "\<parallel>a\<parallel>\<^sup>2 + \<parallel>p\<parallel>\<^sup>2 > 0" by (intro add_pos_nonneg, auto)
    then show ?thesis by auto
  qed
qed simp

lemma sq_norm_poly_pos [simp]:
  fixes p :: "'a :: {conjugatable_ordered_ring,ring_no_zero_divisors} poly"
  shows "\<parallel>p\<parallel>\<^sup>2 > 0 \<longleftrightarrow> p \<noteq> 0"
  by (auto simp: less_le)

lemma sq_norm_vec_of_poly [simp]:
  fixes p :: "'a :: conjugatable_ring poly"
  shows "\<parallel>vec_of_poly p\<parallel>\<^sup>2 = \<parallel>p\<parallel>\<^sup>2"
  apply (unfold sq_norm_poly_def sq_norm_vec_def)
  apply (fold sum_mset_sum_list)
  apply auto.

lemma sq_norm_poly_of_vec [simp]:
  fixes v :: "'a :: conjugatable_ring vec"
  shows "\<parallel>poly_of_vec v\<parallel>\<^sup>2 = \<parallel>v\<parallel>\<^sup>2"
  apply (unfold sq_norm_poly_def sq_norm_vec_def coeffs_poly_of_vec)
  apply (fold rev_map)
  apply (fold sum_mset_sum_list)
  apply (unfold mset_rev)
  apply (unfold sum_mset_sum_list)
  by (auto intro: sum_list_map_dropWhile0)

subsection \<open>Relating Norms\<close>

text \<open>A class where ordering around 0 is linear.\<close>
abbreviation (in ordered_semiring) is_real where "is_real a \<equiv> a < 0 \<or> a = 0 \<or> 0 < a"

class semiring_real_line = ordered_semiring_strict + ordered_semiring_0 +
  assumes add_pos_neg_is_real: "a > 0 \<Longrightarrow> b < 0 \<Longrightarrow> is_real (a + b)"
      and mult_neg_neg: "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> 0 < a * b"
      and pos_pos_linear: "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> a < b \<or> a = b \<or> b < a"
      and neg_neg_linear: "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> a < b \<or> a = b \<or> b < a"
begin

lemma add_neg_pos_is_real: "a < 0 \<Longrightarrow> b > 0 \<Longrightarrow> is_real (a + b)"
  using add_pos_neg_is_real[of b a] by (simp add: ac_simps)

lemma nonneg_linorder_cases [consumes 2, case_names less eq greater]:
  assumes "0 \<le> a" and "0 \<le> b"
      and "a < b \<Longrightarrow> thesis" "a = b \<Longrightarrow> thesis" "b < a \<Longrightarrow> thesis"
  shows thesis
  using assms pos_pos_linear by (auto simp: le_less)

lemma nonpos_linorder_cases [consumes 2, case_names less eq greater]:
  assumes "a \<le> 0" "b \<le> 0"
      and "a < b \<Longrightarrow> thesis" "a = b \<Longrightarrow> thesis" "b < a \<Longrightarrow> thesis"
  shows thesis
  using assms neg_neg_linear by (auto simp: le_less)

lemma real_linear:
  assumes "is_real a" and "is_real b" shows "a < b \<or> a = b \<or> b < a"
  using pos_pos_linear neg_neg_linear assms by (auto dest: less_trans[of _ 0])

lemma real_linorder_cases [consumes 2, case_names less eq greater]:
  assumes real: "is_real a" "is_real b"
      and cases: "a < b \<Longrightarrow> thesis" "a = b \<Longrightarrow> thesis" "b < a \<Longrightarrow> thesis"
  shows thesis
  using real_linear[OF real] cases by auto

lemma
  assumes a: "is_real a" and b: "is_real b"
  shows real_add_le_cancel_left_pos: "c + a \<le> c + b \<longleftrightarrow> a \<le> b"
    and real_add_less_cancel_left_pos: "c + a < c + b \<longleftrightarrow> a < b"
    and real_add_le_cancel_right_pos: "a + c \<le> b + c \<longleftrightarrow> a \<le> b"
    and real_add_less_cancel_right_pos: "a + c < b + c \<longleftrightarrow> a < b"
  using add_strict_left_mono[of b a c] add_strict_left_mono[of a b c]
  using add_strict_right_mono[of b a c] add_strict_right_mono[of a b c]
  by (atomize(full), cases rule: real_linorder_cases[OF a b], auto)

lemma
  assumes a: "is_real a" and b: "is_real b" and c: "0 < c"
  shows real_mult_le_cancel_left_pos: "c * a \<le> c * b \<longleftrightarrow> a \<le> b"
    and real_mult_less_cancel_left_pos: "c * a < c * b \<longleftrightarrow> a < b"
    and real_mult_le_cancel_right_pos: "a * c \<le> b * c \<longleftrightarrow> a \<le> b"
    and real_mult_less_cancel_right_pos: "a * c < b * c \<longleftrightarrow> a < b"
  using mult_strict_left_mono[of b a c] mult_strict_left_mono[of a b c] c
  using mult_strict_right_mono[of b a c] mult_strict_right_mono[of a b c] c
  by (atomize(full), cases rule: real_linorder_cases[OF a b], auto)

lemma
  assumes a: "is_real a" and b: "is_real b"
  shows not_le_real: "\<not> a \<ge> b \<longleftrightarrow> a < b"
    and not_less_real: "\<not> a > b \<longleftrightarrow> a \<le> b"
  by (atomize(full), cases rule: real_linorder_cases[OF a b], auto simp: less_imp_le)

lemma real_mult_eq_0_iff:
  assumes a: "is_real a" and b: "is_real b"
  shows "a * b = 0 \<longleftrightarrow> a = 0 \<or> b = 0"
proof-
  { assume l: "a * b = 0" and "a \<noteq> 0" and "b \<noteq> 0"
    with a b have "a < 0 \<or> 0 < a" and "b < 0 \<or> 0 < b" by auto
    then have "False" using mult_pos_pos[of a b] mult_pos_neg[of a b] mult_neg_pos[of a b] mult_neg_neg[of a b]
      by (auto simp:l)
  } then show ?thesis by auto
qed

end

lemma real_pos_mult_max:
  fixes a b c :: "'a :: semiring_real_line"
  assumes c: "c > 0" and a: "is_real a" and b: "is_real b"
  shows "c * max a b = max (c * a) (c * b)"
  by (rule hom_max, simp add: real_mult_le_cancel_left_pos[OF a b c])

class ring_abs_real_line = ordered_ring_abs + semiring_real_line

class semiring_1_real_line = semiring_real_line + monoid_mult + zero_less_one
begin

subclass ordered_semiring_1 by (unfold_locales, auto)

lemma power_both_mono: "1 \<le> a \<Longrightarrow> m \<le> n \<Longrightarrow> a \<le> b \<Longrightarrow> a ^ m \<le> b ^ n"
  using power_mono[of a b n] power_increasing[of m n a]
  by (auto simp: order.trans[OF zero_le_one])

lemma power_pos:
  assumes a0: "0 < a" shows "0 < a ^ n"
  by (induct n, insert mult_strict_mono[OF a0] a0, auto)

lemma power_neg:
  assumes a0: "a < 0" shows "odd n \<Longrightarrow> a ^ n < 0" and "even n \<Longrightarrow> a ^ n > 0"
  by (atomize(full), induct n, insert a0, auto simp add: mult_pos_neg2 mult_neg_neg)

lemma power_ge_0_iff:
  assumes a: "is_real a"
  shows "0 \<le> a ^ n \<longleftrightarrow> 0 \<le> a \<or> even n"
using a proof (elim disjE)
  assume "a < 0"
  with power_neg[OF this, of n] show ?thesis by(cases "even n", auto)
next
  assume "0 < a"
  with power_pos[OF this] show ?thesis by auto
next
  assume "a = 0"
  then show ?thesis by (auto simp:power_0_left)
qed

lemma nonneg_power_less:
  assumes "0 \<le> a" and "0 \<le> b" shows "a^n < b^n \<longleftrightarrow> n > 0 \<and> a < b"
proof (insert assms, induct n arbitrary: a b)
  case 0
  then show ?case by auto
next
  case (Suc n)
  note a = \<open>0 \<le> a\<close>
  note b = \<open>0 \<le> b\<close>
  show ?case
  proof (cases "n > 0")
    case True
    from a b show ?thesis
    proof (cases rule: nonneg_linorder_cases)
      case less
      then show ?thesis by (auto simp: Suc.hyps[OF a b] True intro!:mult_strict_mono' a b zero_le_power)
    next
      case eq
      then show ?thesis by simp
    next
      case greater
      with Suc.hyps[OF b a] True have "b ^ n < a ^ n" by auto
      with mult_strict_mono'[OF greater this] b greater
      show ?thesis by auto
    qed
  qed auto
qed

lemma power_strict_mono:
  shows "a < b \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 < n \<Longrightarrow> a ^ n < b ^ n"
  by (subst nonneg_power_less, auto)

lemma nonneg_power_le:
  assumes "0 \<le> a" and "0 \<le> b" shows "a^n \<le> b^n \<longleftrightarrow> n = 0 \<or> a \<le> b"
using assms proof (cases rule: nonneg_linorder_cases)
  case less
  with power_strict_mono[OF this, of n] assms show ?thesis by (cases n, auto)
next
  case eq
  then show ?thesis by auto
next
  case greater
  with power_strict_mono[OF this, of n] assms show ?thesis by (cases n, auto)
qed

end

subclass (in linordered_idom) semiring_1_real_line
  apply unfold_locales
  by (auto simp: mult_strict_left_mono mult_strict_right_mono mult_neg_neg)

class ring_1_abs_real_line = ring_abs_real_line + semiring_1_real_line
begin

subclass ring_1..

lemma abs_cases:
  assumes "a = 0 \<Longrightarrow> thesis" and "\<bar>a\<bar> > 0 \<Longrightarrow> thesis" shows thesis
  using assms by auto

lemma abs_linorder_cases[case_names less eq greater]:
  assumes "\<bar>a\<bar> < \<bar>b\<bar> \<Longrightarrow> thesis" and "\<bar>a\<bar> = \<bar>b\<bar> \<Longrightarrow> thesis" and "\<bar>b\<bar> < \<bar>a\<bar> \<Longrightarrow> thesis"
  shows thesis
  apply (cases rule: nonneg_linorder_cases[of "\<bar>a\<bar>" "\<bar>b\<bar>"])
  using assms by auto

lemma abs_power_less [simp]: "\<bar>a\<bar>^n < \<bar>b\<bar>^n \<longleftrightarrow> n > 0 \<and> \<bar>a\<bar> < \<bar>b\<bar>"
  by (subst nonneg_power_less, auto)

lemma abs_power_le [simp]: "\<bar>a\<bar>^n \<le> \<bar>b\<bar>^n \<longleftrightarrow> n = 0 \<or> \<bar>a\<bar> \<le> \<bar>b\<bar>"
  by (subst nonneg_power_le, auto)

lemma abs_power_pos [simp]: "\<bar>a\<bar>^n > 0 \<longleftrightarrow> a \<noteq> 0 \<or> n = 0"
  using power_pos[of "\<bar>a\<bar>"] by (cases "n", auto)

lemma abs_power_nonneg [intro!]: "\<bar>a\<bar>^n \<ge> 0" by auto

lemma abs_power_eq_0 [simp]: "\<bar>a\<bar>^n = 0 \<longleftrightarrow> a = 0 \<and> n \<noteq> 0"
  apply (induct n, force)
  apply (unfold power_Suc)
  apply (subst real_mult_eq_0_iff, auto).

end

instance nat :: semiring_1_real_line by (intro_classes, auto)
instance int :: ring_1_abs_real_line..

lemma vec_index_vec_of_list [simp]: "vec_of_list xs $ i = xs ! i"
  by transfer (auto simp: mk_vec_def undef_vec_def dest: empty_nth)

lemma vec_of_list_append: "vec_of_list (xs @ ys) = vec_of_list xs @\<^sub>v vec_of_list ys"
  by (auto simp: nth_append)

lemma linf_norm_vec_of_list:
  "\<parallel>vec_of_list xs\<parallel>\<^sub>\<infinity> = max_list (map abs xs @ [0])"
  by (simp add: linf_norm_vec_def)

lemma linf_norm_vec_as_Greatest:
  fixes v :: "'a :: ring_1_abs_real_line vec"
  shows "\<parallel>v\<parallel>\<^sub>\<infinity> = (GREATEST a. a \<in> abs ` set (list_of_vec v) \<union> {0})"
  unfolding linf_norm_vec_of_list[of "list_of_vec v", simplified]
  by (subst max_list_as_Greatest, auto)

lemma vec_of_poly_pCons:
  assumes "f \<noteq> 0"
  shows "vec_of_poly (pCons a f) = vec_of_poly f @\<^sub>v vec_of_list [a]"
  using assms
  by (auto simp: vec_eq_iff Suc_diff_le)

lemma vec_of_poly_as_vec_of_list:
  assumes "f \<noteq> 0"
  shows "vec_of_poly f = vec_of_list (rev (coeffs f))"
proof (insert assms, induct f)
  case 0
  then show ?case by auto
next
  case (pCons a f)
  then show ?case
    by (cases "f = 0", auto simp: vec_of_list_append vec_of_poly_pCons)
qed

lemma linf_norm_vec_of_poly [simp]:
  fixes f :: "'a :: ring_1_abs_real_line poly"
  shows "\<parallel>vec_of_poly f\<parallel>\<^sub>\<infinity> = \<parallel>f\<parallel>\<^sub>\<infinity>"
proof (cases "f = 0")
  case False
  then show ?thesis
    apply (unfold vec_of_poly_as_vec_of_list linf_norm_vec_of_list linf_norm_poly_def)
    apply (subst (1 2) max_list_as_Greatest, auto).
qed simp

lemma linf_norm_poly_as_Greatest:
  fixes f :: "'a :: ring_1_abs_real_line poly"
  shows "\<parallel>f\<parallel>\<^sub>\<infinity> = (GREATEST a. a \<in> abs ` set (coeffs f) \<union> {0})"
  using linf_norm_vec_as_Greatest[of "vec_of_poly f"]
  by simp

lemma vec_index_le_linf_norm:
  fixes v :: "'a :: ring_1_abs_real_line vec"
  assumes "i < dim_vec v"
  shows "\<bar>v$i\<bar> \<le> \<parallel>v\<parallel>\<^sub>\<infinity>"
apply (unfold linf_norm_vec_def, rule le_max_list) using assms
apply (auto simp:  in_set_conv_nth intro!: imageI exI[of _ i]).

lemma coeff_le_linf_norm:
  fixes f :: "'a :: ring_1_abs_real_line poly"
  shows "\<bar>coeff f i\<bar> \<le> \<parallel>f\<parallel>\<^sub>\<infinity>"
  using vec_index_le_linf_norm[of "degree f - i" "vec_of_poly f"]
  by (cases "i \<le> degree f", auto simp: coeff_eq_0)

class conjugatable_ring_1_abs_real_line = conjugatable_ring + ring_1_abs_real_line + power +
  assumes sq_norm_as_sq_abs [simp]: "\<parallel>a\<parallel>\<^sup>2 = \<bar>a\<bar>\<^sup>2"
begin
subclass conjugatable_ordered_ring by (unfold_locales, simp)
end

instance int :: conjugatable_ring_1_abs_real_line
  by (intro_classes, simp add: numeral_2_eq_2)

instance rat :: conjugatable_ring_1_abs_real_line
  by (intro_classes, simp add: numeral_2_eq_2)

instance real :: conjugatable_ring_1_abs_real_line
  by (intro_classes, simp add: numeral_2_eq_2)

instance complex :: semiring_1_real_line
  apply intro_classes
  by (auto simp: complex_eq_iff mult_le_cancel_left mult_le_cancel_right mult_neg_neg)

text \<open>
  Due to the assumption @{thm abs_ge_self} from Groups.thy,
  @{type complex} cannot be @{class ring_1_abs_real_line}!
\<close>
instance complex :: ordered_ab_group_add_abs oops

lemma sq_norm_as_sq_abs [simp]: "(sq_norm :: 'a :: conjugatable_ring_1_abs_real_line \<Rightarrow> 'a) = power2 \<circ> abs"
  by auto

lemma sq_norm_vec_le_linf_norm:
  fixes v :: "'a :: {conjugatable_ring_1_abs_real_line} vec"
  assumes "v \<in> carrier_vec n"
  shows "\<parallel>v\<parallel>\<^sup>2 \<le> of_nat n * \<parallel>v\<parallel>\<^sub>\<infinity>\<^sup>2"
proof (insert assms, induct rule: carrier_vec_induct)
  case (Suc n a v)
  have [dest!]: "\<not> \<bar>a\<bar> \<le> \<parallel>v\<parallel>\<^sub>\<infinity> \<Longrightarrow> of_nat n * \<parallel>v\<parallel>\<^sub>\<infinity>\<^sup>2 \<le> of_nat n * \<bar>a\<bar>\<^sup>2"
    by (rule real_linorder_cases[of "\<bar>a\<bar>" "\<parallel>v\<parallel>\<^sub>\<infinity>"], insert Suc, auto simp: less_le intro!: power_mono mult_left_mono)
  from Suc show ?case
    by (auto simp: ring_distribs max_def intro!:add_mono power_mono)
qed simp

lemma sq_norm_poly_le_linf_norm:
  fixes p :: "'a :: {conjugatable_ring_1_abs_real_line} poly"
  shows "\<parallel>p\<parallel>\<^sup>2 \<le> of_nat (degree p + 1) * \<parallel>p\<parallel>\<^sub>\<infinity>\<^sup>2"
  using sq_norm_vec_le_linf_norm[of "vec_of_poly p" "degree p + 1"]
    by (auto simp: carrier_dim_vec)

lemma coeff_le_sq_norm:
  fixes f :: "'a :: {conjugatable_ring_1_abs_real_line} poly"
  shows "\<bar>coeff f i\<bar>\<^sup>2 \<le> \<parallel>f\<parallel>\<^sup>2"
proof (induct f arbitrary: i)
  case (pCons a f)
  show ?case
  proof (cases i)
    case (Suc ii)
    note pCons(2)[of ii]
    also have "\<parallel>f\<parallel>\<^sup>2 \<le> \<bar>a\<bar>\<^sup>2 + \<parallel>f\<parallel>\<^sup>2" by auto
    finally show ?thesis unfolding Suc by auto
  qed auto
qed simp

lemma max_norm_witness:
  fixes f :: "'a :: ordered_ring_abs poly"
  shows "\<exists> i. \<parallel>f\<parallel>\<^sub>\<infinity> = \<bar>coeff f i\<bar>"
  by (induct f, auto simp add: max_def intro: exI[of _ "Suc _"] exI[of _ 0])

lemma max_norm_le_sq_norm:
  fixes f ::  "'a :: conjugatable_ring_1_abs_real_line poly"
shows "\<parallel>f\<parallel>\<^sub>\<infinity>\<^sup>2 \<le> \<parallel>f\<parallel>\<^sup>2"
proof -
  from max_norm_witness[of f] obtain i where id: "\<parallel>f\<parallel>\<^sub>\<infinity> = \<bar>coeff f i\<bar>" by auto
  show ?thesis unfolding id using coeff_le_sq_norm[of f i] by auto
qed

(*TODO MOVE*)
lemma (in conjugatable_ring) conjugate_minus: "conjugate (x - y) = conjugate x - conjugate y"
  by (unfold diff_conv_add_uminus conjugate_dist_add conjugate_neg, rule)

lemma conjugate_1[simp]: "(conjugate 1 :: 'a :: {conjugatable_ring, ring_1}) = 1"
proof-
  have "conjugate 1 * 1 = (conjugate 1 :: 'a)" by simp
  also have "conjugate \<dots> = 1" by simp
  finally show ?thesis by (unfold conjugate_dist_mul, simp)
qed

lemma conjugate_of_int [simp]:
  "(conjugate (of_int x) :: 'a :: {conjugatable_ring,ring_1}) = of_int x"
proof (induct x)
  case (nonneg n)
  then show ?case by (induct n, auto simp: conjugate_dist_add)
next
  case (neg n)
  then show ?case apply (induct n, auto simp: conjugate_minus conjugate_neg)
    by (metis conjugate_1 conjugate_dist_add one_add_one)
qed

lemma sq_norm_of_int: "\<parallel>map_vec of_int v :: 'a :: {conjugatable_ring,ring_1} vec\<parallel>\<^sup>2 = of_int \<parallel>v\<parallel>\<^sup>2"
  unfolding sq_norm_vec_as_cscalar_prod scalar_prod_def
  unfolding hom_distribs
  by (rule sum.cong, auto)

definition "norm1 p = sum_list (map abs (coeffs p))"

lemma norm1_ge_0: "norm1 (f :: 'a :: {abs,ordered_semiring_0,ordered_ab_group_add_abs}poly) \<ge> 0"
  unfolding norm1_def by (rule sum_list_nonneg, auto)

lemma norm2_norm1_main_equality: fixes f :: "nat \<Rightarrow> 'a :: linordered_idom"
  shows "(\<Sum>i = 0..<n. \<bar>f i\<bar>)\<^sup>2 = (\<Sum>i = 0..<n. f i * f i)
      + (\<Sum>i = 0..<n. \<Sum>j = 0..<n. if i = j then 0 else \<bar>f i\<bar> * \<bar>f j\<bar>)"
proof (induct n)
  case (Suc n)
  have id: "{0 ..< Suc n} = insert n {0 ..< n}" by auto
  have id: "sum f {0 ..< Suc n} = f n + sum f {0 ..< n}" for f :: "nat \<Rightarrow> 'a"
    unfolding id by (rule sum.insert, auto)
  show ?case unfolding id power2_sum unfolding Suc
    by (auto simp: power2_eq_square sum_distrib_left sum.distrib ac_simps)
qed auto

lemma norm2_norm1_main_inequality: fixes f :: "nat \<Rightarrow> 'a :: linordered_idom"
  shows "(\<Sum>i = 0..<n. f i * f i) \<le> (\<Sum>i = 0..<n. \<bar>f i\<bar>)\<^sup>2"
  unfolding norm2_norm1_main_equality
  by (auto intro!: sum_nonneg)

lemma norm2_le_norm1_int: "\<parallel>f :: int poly\<parallel>\<^sup>2 \<le> (norm1 f)^2"
proof -
  define F where "F = (!) (coeffs f)"
  define n where "n = length (coeffs f)"
  have 1: "\<parallel>f\<parallel>\<^sup>2 = (\<Sum>i = 0..<n. F i * F i)"
    unfolding norm1_def sq_norm_poly_def sum_list_sum_nth F_def n_def
    by (subst sum.cong, auto simp: power2_eq_square)
  have 2: "norm1 f = (\<Sum>i = 0..<n. \<bar>F i\<bar>)"
    unfolding norm1_def sq_norm_poly_def sum_list_sum_nth F_def n_def
    by (subst sum.cong, auto)
  show ?thesis unfolding 1 2 by (rule norm2_norm1_main_inequality)
qed

lemma sq_norm_smult_vec: "sq_norm ((c :: 'a :: {conjugatable_ring,comm_semiring_0}) \<cdot>\<^sub>v v) = (c * conjugate c) * sq_norm v"
  unfolding sq_norm_vec_as_cscalar_prod
  by (subst scalar_prod_smult_left, force, unfold conjugate_smult_vec,
    subst scalar_prod_smult_right, force, simp add: ac_simps)

lemma vec_le_sq_norm:
  fixes v :: "'a :: conjugatable_ring_1_abs_real_line vec"
  assumes "v \<in> carrier_vec n" "i < n"
  shows "\<bar>v $ i\<bar>\<^sup>2 \<le> \<parallel>v\<parallel>\<^sup>2"
using assms proof (induction v arbitrary: i)
  case (Suc n a v i)
  note IH = Suc
  show ?case
  proof (cases i)
    case (Suc ii)
    then show ?thesis
      using IH IH(2)[of ii] le_add_same_cancel2 order_trans by fastforce
  qed auto
qed auto

class trivial_conjugatable =
  conjugate +
  assumes conjugate_id [simp]: "conjugate x = x"

class trivial_conjugatable_ordered_field =
  conjugatable_ordered_field + trivial_conjugatable

class trivial_conjugatable_linordered_field =
  trivial_conjugatable_ordered_field + linordered_field
begin
subclass conjugatable_ring_1_abs_real_line
  by (standard) (auto simp add: semiring_normalization_rules)
end

instance rat :: trivial_conjugatable_linordered_field
  by (standard, auto)

instance real :: trivial_conjugatable_linordered_field
  by (standard, auto)

lemma scalar_prod_ge_0: "(x :: 'a :: linordered_idom vec) \<bullet> x \<ge> 0"
  unfolding scalar_prod_def
  by (rule sum_nonneg, auto)

lemma cscalar_prod_is_scalar_prod[simp]: "(x :: 'a :: trivial_conjugatable_ordered_field vec) \<bullet>c y = x \<bullet> y"
  unfolding conjugate_id
  by (rule arg_cong[of _ _ "scalar_prod x"], auto)

lemma scalar_prod_Cauchy:
  fixes u v::"'a :: {trivial_conjugatable_linordered_field} Matrix.vec"
  assumes "u \<in> carrier_vec n" "v \<in> carrier_vec n"
  shows "(u \<bullet> v)\<^sup>2 \<le> \<parallel>u\<parallel>\<^sup>2 * \<parallel>v\<parallel>\<^sup>2 "
proof -
  { assume v_0: "v \<noteq> 0\<^sub>v n"
    have "0 \<le> (u - r \<cdot>\<^sub>v v) \<bullet> (u - r \<cdot>\<^sub>v v)" for r
      by (simp add: scalar_prod_ge_0)
    also have "(u - r \<cdot>\<^sub>v v) \<bullet> (u - r \<cdot>\<^sub>v v) = u \<bullet> u - r * (u \<bullet> v) - r * (u \<bullet> v) + r * r * (v \<bullet> v)" for r::'a
    proof -
      have "(u - r \<cdot>\<^sub>v v) \<bullet> (u - r \<cdot>\<^sub>v v) = (u - r \<cdot>\<^sub>v v) \<bullet> u - (u - r \<cdot>\<^sub>v v) \<bullet> (r \<cdot>\<^sub>v v)"
        using assms by (subst scalar_prod_minus_distrib) auto
      also have "\<dots> = u \<bullet> u - (r \<cdot>\<^sub>v v) \<bullet> u - r * ((u - r \<cdot>\<^sub>v v) \<bullet> v)"
        using assms by (subst minus_scalar_prod_distrib) auto
      also have "\<dots> = u \<bullet> u - r * (v \<bullet> u) - r * (u \<bullet> v - r * (v \<bullet> v))"
        using assms by (subst minus_scalar_prod_distrib) auto
      also have "\<dots> = u \<bullet> u - r * (u \<bullet> v) - r * (u \<bullet> v) + r * r * (v \<bullet> v)"
        using assms comm_scalar_prod by (auto simp add: field_simps)
      finally show ?thesis
        by simp
    qed
    also have "u \<bullet> u - r * (u \<bullet> v) - r * (u \<bullet> v) + r * r * (v \<bullet> v) = sq_norm u - (u \<bullet> v)\<^sup>2 / sq_norm v"
      if "r = (u \<bullet> v) / (v \<bullet> v)" for r
      unfolding that by (auto simp add: sq_norm_vec_as_cscalar_prod power2_eq_square)
    finally have "0 \<le> \<parallel>u\<parallel>\<^sup>2 - (u \<bullet> v)\<^sup>2 / \<parallel>v\<parallel>\<^sup>2"
      by auto
    then have "(u \<bullet> v)\<^sup>2 / \<parallel>v\<parallel>\<^sup>2 \<le> \<parallel>u\<parallel>\<^sup>2"
      by auto
    then have "(u \<bullet> v)\<^sup>2 \<le> \<parallel>u\<parallel>\<^sup>2 * \<parallel>v\<parallel>\<^sup>2"
      using pos_divide_le_eq[of "\<parallel>v\<parallel>\<^sup>2"] v_0 assms by (auto)
  }
  then show ?thesis
    by (fastforce simp add: assms)
qed

end


theory BExp imports AExp begin

subsection "Boolean Expressions"

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

text_raw{*\snip{BExpbvaldef}{1}{2}{% *}
fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"
text_raw{*}%endsnip*}

value "bval (Less (V ''x'') (Plus (N 3) (V ''y'')))
            <''x'' := 3, ''y'' := 1>"

subsection "Constant Folding"

text{* Optimizing constructors: *}

text_raw{*\snip{BExplessdef}{0}{2}{% *}
fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n\<^sub>1) (N n\<^sub>2) = Bc(n\<^sub>1 < n\<^sub>2)" |
"less a\<^sub>1 a\<^sub>2 = Less a\<^sub>1 a\<^sub>2"
text_raw{*}%endsnip*}

text_raw{*\snip{BExpanddef}{2}{2}{% *}
fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and b\<^sub>1 b\<^sub>2 = And b\<^sub>1 b\<^sub>2"
text_raw{*}%endsnip*}

lemma bval_and[simp]: "bval (and b1 b2) s = (bval b1 s \<and> bval b2 s)"
apply(induction b1 b2 rule: and.induct)
apply simp_all
done

text_raw{*\snip{BExpnotdef}{2}{2}{% *}
fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"
text_raw{*}%endsnip*}

lemma bval_not[simp]: "bval (not b) s = (\<not> bval b s)"
apply(induction b rule: not.induct)
apply simp_all
done

text{* Now the overall optimizer: *}

text_raw{*\snip{BExpbsimpdef}{0}{2}{% *}
fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not(bsimp b)" |
"bsimp (And b\<^sub>1 b\<^sub>2) = and (bsimp b\<^sub>1) (bsimp b\<^sub>2)" |
"bsimp (Less a\<^sub>1 a\<^sub>2) = less (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw{*}%endsnip*}

value "bsimp (And (Less (N 0) (N 1)) b)"

value "bsimp (And (Less (N 1) (N 0)) (Bc True))"

theorem "bval (bsimp b) s = bval b s"
apply(induction b)
apply simp_all
done

end