(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
subsection \<open>Resultant\<close>

text \<open>This theory contains
  facts about resultants which are required for addition and multiplication
  of algebraic numbers.

  The results are taken from the textbook \cite[pages 227ff and 235ff]{AlgNumbers}.
\<close>

theory Resultant
imports
  Polynomial_Factorization.Rational_Factorization
  Subresultants.Subresultant_Gcd
  Berlekamp_Zassenhaus.Unique_Factorization_Poly
  Bivariate_Polynomials
begin

subsubsection \<open>Sylvester matrices and vector representation of polynomials\<close>

definition vec_of_poly_rev_shifted where
  "vec_of_poly_rev_shifted p n j \<equiv>
   vec n (\<lambda>i. if i \<le> j \<and> j \<le> degree p + i then coeff p (degree p + i - j) else 0)"

lemma vec_of_poly_rev_shifted_dim[simp]: "dim_vec (vec_of_poly_rev_shifted p n j) = n"
  unfolding vec_of_poly_rev_shifted_def by auto

lemma col_sylvester:
  fixes p q
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes j: "j < m+n"
  shows "col (sylvester_mat p q) j =
    vec_of_poly_rev_shifted p n j @\<^sub>v vec_of_poly_rev_shifted q m j" (is "?l = ?r")
proof
  note [simp] = m_def[symmetric] n_def[symmetric]
  show "dim_vec ?l = dim_vec ?r" by simp
  fix i assume "i < dim_vec ?r" hence i: "i < m+n" by auto
  show "?l $ i = ?r $ i"
    unfolding vec_of_poly_rev_shifted_def
    apply (subst index_col) using i apply simp using j apply simp
    apply (subst sylvester_index_mat) using i apply simp using j apply simp
    apply (cases "i < n") apply force using i by simp
qed

lemma inj_on_diff_nat2: "inj_on (\<lambda>i. (n::nat) - i) {..n}" by (rule inj_onI, auto)

lemma image_diff_atMost: "(\<lambda>i. (n::nat) - i) ` {..n} = {..n}" (is "?l = ?r")
  unfolding set_eq_iff
proof (intro allI iffI)
  fix x assume x: "x \<in> ?r"
    thus "x \<in> ?l" unfolding image_def mem_Collect_eq
    by(intro bexI[of _ "n-x"],auto)
qed auto

lemma sylvester_sum_mat_upper:
  fixes p q :: "'a :: comm_semiring_1 poly"
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes i: "i < n"
  shows "(\<Sum>j<m+n. monom (sylvester_mat p q $$ (i,j)) (m + n - Suc j)) =
    monom 1 (n - Suc i) * p" (is "sum ?f _ = ?r")
proof -
  have n1: "n \<ge> 1" using i by auto
  define ni1 where "ni1 = n-Suc i"
  hence ni1: "n-i = Suc ni1" using i by auto
  define l where "l = m+n-1"
  hence l: "Suc l = m+n" using n1 by auto
  let ?g = "\<lambda>j. monom (coeff (monom 1 (n-Suc i) * p) j) j"
  let ?p = "\<lambda>j. l-j"
  have "sum ?f {..<m+n} = sum ?f {..l}"
    unfolding l[symmetric] unfolding lessThan_Suc_atMost..
  also {
    fix j assume j: "j\<le>l"
    have "?f j = ((\<lambda>j. monom (coeff (monom 1 (n-i) * p) (Suc j)) j) \<circ> ?p) j"
      apply(subst sylvester_index_mat2)
      using i j unfolding l_def m_def[symmetric] n_def[symmetric]
      by (auto simp add: Suc_diff_Suc)
    also have "... = (?g \<circ> ?p) j"
      unfolding ni1
      unfolding coeff_monom_Suc
      unfolding ni1_def
      using i by auto
    finally have "?f j = (?g \<circ> ?p) j".
  }
  hence "(\<Sum>j\<le>l. ?f j) = (\<Sum>j\<le>l. (?g\<circ>?p) j)" using l by auto
  also have "... = (\<Sum>j\<le>l. ?g j)"
    unfolding l_def
    using sum.reindex[OF inj_on_diff_nat2,symmetric,unfolded image_diff_atMost].
  also have "degree ?r \<le> l"
      using degree_mult_le[of "monom 1 (n-Suc i)" p]
      unfolding l_def m_def
      unfolding degree_monom_eq[OF one_neq_zero] using i by auto
    from poly_as_sum_of_monoms'[OF this]
    have "(\<Sum>j\<le>l. ?g j) = ?r".
  finally show ?thesis.
qed

lemma sylvester_sum_mat_lower:
  fixes p q :: "'a :: comm_semiring_1 poly"
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes ni: "n \<le> i" and imn: "i < m+n"
  shows "(\<Sum>j<m+n. monom (sylvester_mat p q $$ (i,j)) (m + n - Suc j)) =
    monom 1 (m + n - Suc i) * q" (is "sum ?f _ = ?r")
proof -
  define l where "l = m+n-1"
  hence l: "Suc l = m+n" using imn by auto
  define mni1 where "mni1 = m + n - Suc i"
  hence mni1: "m+n-i = Suc mni1" using imn by auto
  let ?g = "\<lambda>j. monom (coeff (monom 1 (m + n - Suc i) * q) j) j"
  let ?p = "\<lambda>j. l-j"
  have "sum ?f {..<m+n} = sum ?f {..l}"
    unfolding l[symmetric] unfolding lessThan_Suc_atMost..
  also {
    fix j assume j: "j\<le>l"
    have "?f j = ((\<lambda>j. monom (coeff (monom 1 (m+n-i) * q) (Suc j)) j) \<circ> ?p) j"
      apply(subst sylvester_index_mat2)
      using ni imn j unfolding l_def m_def[symmetric] n_def[symmetric]
      by (auto simp add: Suc_diff_Suc)
    also have "... = (?g \<circ> ?p) j"
      unfolding mni1
      unfolding coeff_monom_Suc
      unfolding mni1_def..
    finally have "?f j = ...".
  }
  hence "(\<Sum>j\<le>l. ?f j) = (\<Sum>j\<le>l. (?g\<circ>?p) j)" by auto
  also have "... = (\<Sum>j\<le>l. ?g j)"
    using sum.reindex[OF inj_on_diff_nat2,symmetric,unfolded image_diff_atMost].
  also have "degree ?r \<le> l"
      using degree_mult_le[of "monom 1 (m+n-1-i)" q]
      unfolding l_def n_def[symmetric]
      unfolding degree_monom_eq[OF one_neq_zero] using ni imn by auto
    from poly_as_sum_of_monoms'[OF this]
    have "(\<Sum>j\<le>l. ?g j) = ?r".
  finally show ?thesis.
qed

definition "vec_of_poly p \<equiv> let m = degree p in vec (Suc m) (\<lambda>i. coeff p (m-i))"

definition "poly_of_vec v \<equiv> let d = dim_vec v in \<Sum>i<d. monom (v $ (d - Suc i)) i"

lemma poly_of_vec_of_poly[simp]:
  fixes p :: "'a :: comm_monoid_add poly"
  shows "poly_of_vec (vec_of_poly p) = p"
  unfolding poly_of_vec_def vec_of_poly_def Let_def
  unfolding dim_vec
  unfolding lessThan_Suc_atMost
  using poly_as_sum_of_monoms[of p] by auto

lemma poly_of_vec_0[simp]: "poly_of_vec (0\<^sub>v n) = 0" unfolding poly_of_vec_def Let_def by auto

lemma poly_of_vec_0_iff[simp]:
  fixes v  :: "'a :: comm_monoid_add vec"
  shows "poly_of_vec v = 0 \<longleftrightarrow> v = 0\<^sub>v (dim_vec v)" (is "?v = _ \<longleftrightarrow> _ = ?z")
proof
  assume "?v = 0"
  hence "\<forall>i\<in>{..<dim_vec v}. v $ (dim_vec v - Suc i) = 0"
    unfolding poly_of_vec_def Let_def
    by (subst sum_monom_0_iff[symmetric],auto)
  hence a: "\<And>i. i < dim_vec v \<Longrightarrow> v $ (dim_vec v - Suc i) = 0" by auto
  { fix i assume "i < dim_vec v"
    hence "v $ i = 0" using a[of "dim_vec v - Suc i"] by auto
  }
  thus "v = ?z" by auto
  next assume r: "v = ?z"
  show "?v = 0" apply (subst r) by auto
qed

(* TODO: move, copied from no longer existing Cayley-Hamilton/Polynomial_extension *)
lemma degree_sum_smaller:
  assumes "n > 0" "finite A"
  shows "(\<And> x. x \<in>A \<Longrightarrow> degree (f x) < n) \<Longrightarrow> degree (\<Sum>x\<in>A. f x) < n"
  using \<open>finite A\<close>
  by(induct rule: finite_induct)
    (simp_all add: degree_add_less assms)

lemma degree_poly_of_vec_less:
  fixes v :: "'a :: comm_monoid_add vec"
  assumes dim: "dim_vec v > 0"
  shows "degree (poly_of_vec v) < dim_vec v"
  unfolding poly_of_vec_def Let_def
  apply(rule degree_sum_smaller)
    using dim apply force
    apply force
  unfolding lessThan_iff
  by (metis degree_0 degree_monom_eq dim monom_eq_0_iff)

lemma coeff_poly_of_vec:
  "coeff (poly_of_vec v) i = (if i < dim_vec v then v $ (dim_vec v - Suc i) else 0)"
  (is "?l = ?r")
proof -
  have "?l = (\<Sum>x<dim_vec v. if x = i then v $ (dim_vec v - Suc x) else 0)" (is "_ = ?m")
    unfolding poly_of_vec_def Let_def coeff_sum coeff_monom ..
  also have "\<dots> = ?r"
  proof (cases "i < dim_vec v")
    case False
    show ?thesis
      by (subst sum.neutral, insert False, auto)
  next
    case True
    show ?thesis
      by (subst sum.remove[of _ i], force, force simp: True, subst sum.neutral, insert True, auto)
  qed
  finally show ?thesis .
qed

lemma vec_of_poly_rev_shifted_scalar_prod:
  fixes p v
  defines "q \<equiv> poly_of_vec v"
  assumes m[simp]: "degree p = m" and n: "dim_vec v = n"
  assumes j: "j < m+n"
  shows "vec_of_poly_rev_shifted p n (n+m-Suc j) \<bullet> v = coeff (p * q) j" (is "?l = ?r")
proof -
  have id1: "\<And> i. m + i - (n + m - Suc j) = i + Suc j - n"
    using j by auto
  let ?g = "\<lambda> i. if i \<le> n + m - Suc j \<and> n - Suc j \<le> i then coeff p (i + Suc j - n) *  v $ i else 0"
  have "?thesis = ((\<Sum>i = 0..<n. ?g i) =
        (\<Sum>i\<le>j. coeff p i * (if j - i < n then v $ (n - Suc (j - i)) else 0)))" (is "_ = (?l = ?r)")
    unfolding vec_of_poly_rev_shifted_def coeff_mult m scalar_prod_def n q_def
      coeff_poly_of_vec
    by (subst sum.cong, insert id1, auto)
  also have "..."
  proof -
    have "?r = (\<Sum>i\<le>j. (if j - i < n then coeff p i * v $ (n - Suc (j - i)) else 0))" (is "_ = sum ?f _")
      by (rule sum.cong, auto)
    also have "sum ?f {..j} = sum ?f ({i. i \<le> j \<and> j - i < n} \<union> {i. i \<le> j \<and> \<not> j - i < n})"
      (is "_ = sum _ (?R1 \<union> ?R2)")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?f ?R1 + sum ?f ?R2"
      by (subst sum.union_disjoint, auto)
    also have "sum ?f ?R2 = 0"
      by (rule sum.neutral, auto)
    also have "sum ?f ?R1 + 0 = sum (\<lambda> i. coeff p i * v $ (i + n - Suc j)) ?R1"
      (is "_ = sum ?F _")
      by (subst sum.cong, auto simp: ac_simps)
    also have "\<dots> = sum ?F ((?R1 \<inter> {..m}) \<union> (?R1 - {..m}))"
      (is "_ = sum _ (?R \<union> ?R')")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?F ?R + sum ?F ?R'"
      by (subst sum.union_disjoint, auto)
    also have "sum ?F ?R' = 0"
    proof -
      {
        fix x
        assume "x > m"
        from coeff_eq_0[OF this[folded m]]
        have "?F x = 0" by simp
      }
      thus ?thesis
        by (subst sum.neutral, auto)
    qed
    finally have r: "?r = sum ?F ?R" by simp

    have "?l = sum ?g ({i. i < n \<and> i \<le> n + m - Suc j \<and> n - Suc j \<le> i}
      \<union> {i. i < n \<and> \<not> (i \<le> n + m - Suc j \<and> n - Suc j \<le> i)})"
      (is "_ = sum _ (?L1 \<union> ?L2)")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?g ?L1 + sum ?g ?L2"
      by (subst sum.union_disjoint, auto)
    also have "sum ?g ?L2 = 0"
      by (rule sum.neutral, auto)
    also have "sum ?g ?L1 + 0 = sum (\<lambda> i. coeff p (i + Suc j - n) * v $ i) ?L1"
      (is "_ = sum ?G _")
      by (subst sum.cong, auto)
    also have "\<dots> = sum ?G (?L1 \<inter> {i. i + Suc j - n \<le> m} \<union> (?L1 - {i. i + Suc j - n \<le> m}))"
      (is "_ = sum _ (?L \<union> ?L')")
      by (subst sum.cong, auto)
    also have "\<dots> = sum ?G ?L + sum ?G ?L'"
      by (subst sum.union_disjoint, auto)
    also have "sum ?G ?L' = 0"
    proof -
      {
        fix x
        assume "x + Suc j - n > m"
        from coeff_eq_0[OF this[folded m]]
        have "?G x = 0" by simp
      }
      thus ?thesis
        by (subst sum.neutral, auto)
    qed
    finally have l: "?l = sum ?G ?L" by simp

    let ?bij = "\<lambda> i. i + n - Suc j"
    {
      fix x
      assume x: "j < m + n" "Suc (x + j) - n \<le> m" "x < n" "n - Suc j \<le> x"
      define y where "y = x + Suc j - n"
      from x have "x + Suc j \<ge> n" by auto
      with x have xy: "x = ?bij y" unfolding y_def by auto
      from x have y: "y \<in> ?R" unfolding y_def by auto
      have "x \<in> ?bij ` ?R" unfolding xy using y by blast
    } note tedious = this
    show ?thesis unfolding l r
      by (rule sum.reindex_cong[of ?bij], insert j, auto simp: inj_on_def tedious)
  qed
  finally show ?thesis by simp
qed

lemma sylvester_vec_poly:
  fixes p q :: "'a :: comm_semiring_0 poly"
  defines "m \<equiv> degree p"
      and "n \<equiv> degree q"
  assumes v: "v \<in> carrier_vec (m+n)"
  shows "poly_of_vec (transpose_mat (sylvester_mat p q) *\<^sub>v v) =
    poly_of_vec (vec_first v n) * p + poly_of_vec (vec_last v m) * q" (is "?l = ?r")
proof (rule poly_eqI)
  fix i
  note mn[simp] = m_def[symmetric] n_def[symmetric]
  let ?Tv = "transpose_mat (sylvester_mat p q) *\<^sub>v v"
  have dim: "dim_vec (vec_first v n) = n" "dim_vec (vec_last v m) = m" "dim_vec ?Tv = n + m"
    using v by auto
  have if_distrib: "\<And> x y z. (if x then y else (0 :: 'a)) * z = (if x then y * z else 0)"
    by auto
  show "coeff ?l i = coeff ?r i"
  proof (cases "i < m+n")
    case False
      hence i_mn: "i \<ge> m+n"
        and i_n: "\<And>x. x \<le> i \<and> x < n \<longleftrightarrow> x < n"
        and i_m: "\<And>x. x \<le> i \<and> x < m \<longleftrightarrow> x < m" by auto
      have "coeff ?r i =
            (\<Sum> x < n. vec_first v n $ (n - Suc x) * coeff p (i - x)) +
            (\<Sum> x < m. vec_last v m $ (m - Suc x) * coeff q (i - x))"
        (is "_ = sum ?f _ + sum ?g _")
        unfolding coeff_add coeff_mult Let_def
        unfolding coeff_poly_of_vec dim if_distrib
        unfolding atMost_def
        apply(subst sum.inter_filter[symmetric],simp)
        apply(subst sum.inter_filter[symmetric],simp)
        unfolding mem_Collect_eq
        unfolding i_n i_m
        unfolding lessThan_def by simp
      also { fix x assume x: "x < n"
        have "coeff p (i-x) = 0"
          apply(rule coeff_eq_0) using i_mn x unfolding m_def by auto
        hence "?f x = 0" by auto
      } hence "sum ?f {..<n} = 0" by auto
      also { fix x assume x: "x < m"
        have "coeff q (i-x) = 0"
          apply(rule coeff_eq_0) using i_mn x unfolding n_def by auto
        hence "?g x = 0" by auto
      } hence "sum ?g {..<m} = 0" by auto
      finally have "coeff ?r i = 0" by auto
      also from False have "0 = coeff ?l i"
        unfolding coeff_poly_of_vec dim sum.distrib[symmetric] by auto
      finally show ?thesis by auto
    next case True
      hence "coeff ?l i = (transpose_mat (sylvester_mat p q) *\<^sub>v v) $ (n + m - Suc i)"
        unfolding coeff_poly_of_vec dim sum.distrib[symmetric] by auto
      also have "... = coeff (p * poly_of_vec (vec_first v n) + q * poly_of_vec (vec_last v m)) i"
        apply(subst index_mult_mat_vec) using True apply simp
        apply(subst row_transpose) using True apply simp
        apply(subst col_sylvester)
        unfolding mn using True apply simp
        apply(subst vec_first_last_append[of v n m,symmetric]) using v apply(simp add: add.commute)
        apply(subst scalar_prod_append)
        apply (rule carrier_vecI,simp)+
        apply (subst vec_of_poly_rev_shifted_scalar_prod,simp,simp) using True apply simp
        apply (subst add.commute[of n m])
        apply (subst vec_of_poly_rev_shifted_scalar_prod,simp,simp) using True apply simp
        by simp
      also have "... =
        (\<Sum>x\<le>i. (if x < n then vec_first v n $ (n - Suc x) else 0) * coeff p (i - x)) +
        (\<Sum>x\<le>i. (if x < m then vec_last v m $ (m - Suc x) else 0) * coeff q (i - x))"
        unfolding coeff_poly_of_vec[of "vec_first v n",unfolded dim_vec_first,symmetric]
        unfolding coeff_poly_of_vec[of "vec_last v m",unfolded dim_vec_last,symmetric]
        unfolding coeff_mult[symmetric] by (simp add: mult.commute)
      also have "... = coeff ?r i"
        unfolding coeff_add coeff_mult Let_def
        unfolding coeff_poly_of_vec dim..
      finally show ?thesis.
  qed
qed

subsubsection \<open>Homomorphism and Resultant\<close>

text \<open>Here we prove Lemma~7.3.1 of the textbook.\<close>

lemma(in comm_ring_hom) resultant_sub_map_poly:
  fixes p q :: "'a poly"
  shows "hom (resultant_sub m n p q) = resultant_sub m n (map_poly hom p) (map_poly hom q)"
    (is "?l = ?r'")
proof -
  let ?mh = "map_poly hom"
  have "?l = det (sylvester_mat_sub m n (?mh p) (?mh q))"
    unfolding resultant_sub_def
    apply(subst sylvester_mat_sub_map[symmetric]) by auto
  thus ?thesis unfolding resultant_sub_def.
qed

(*
lemma (in comm_ring_hom) resultant_map_poly:
  fixes p q :: "'a poly"
    defines "p' \<equiv> map_poly hom p"
    defines "q' \<equiv> map_poly hom q"
    defines "m \<equiv> degree p"
    defines "n \<equiv> degree q"
    defines "m' \<equiv> degree p'"
    defines "n' \<equiv> degree q'"
    defines "r \<equiv> resultant p q"
    defines "r' \<equiv> resultant p' q'"
  shows "m' = m \<Longrightarrow> n' = n \<Longrightarrow> hom r = r'"
    and "m' = m \<Longrightarrow> hom r = hom (coeff p m')^(n-n') * r'"
    and "m' \<noteq> m \<Longrightarrow> n' = n \<Longrightarrow>
      hom r = (if even n then 1 else (-1)^(m-m')) * hom (coeff q n)^(m-m') * r'"
      (is "_ \<Longrightarrow> _ \<Longrightarrow> ?goal")
    and "m' \<noteq> m \<Longrightarrow> n' \<noteq> n \<Longrightarrow> hom r = 0"
proof -
  have m'm: "m' \<le> m" unfolding m_def m'_def p'_def using degree_map_poly_le by auto
  have n'n: "n' \<le> n" unfolding n_def n'_def q'_def using degree_map_poly_le by auto

  have coeffp'[simp]: "\<And>i. coeff p' i = hom (coeff p i)" unfolding p'_def by auto
  have coeffq'[simp]: "\<And>i. coeff q' i = hom (coeff q i)" unfolding q'_def by auto

  let ?f = "\<lambda>i. (if even n then 1 else (-1)^i) * hom (coeff q n)^i"

  have "hom r = resultant_sub m n p' q'"
    unfolding r_def resultant_sub
    unfolding m_def n_def p'_def q'_def
    by(rule resultant_sub_map_poly)
  also have "... = ?f (m-m') * resultant_sub m' n p' q'"
    using resultant_sub_trim_upper[of p' "m-m'" n q',folded m'_def] m'm
    by (auto simp: power_minus[symmetric])
  also have "... = ?f (m-m') * hom (coeff p m')^(n-n') * r'"
    using resultant_sub_trim_lower[of m' q' "n-n'" p'] n'n
    unfolding r'_def resultant_sub m'_def n'_def by auto
  finally have main: "hom r = ?f (m-m') * hom (coeff p m')^(n-n') * r'" by auto

  { assume "m' = m"
    thus "hom r = hom (coeff p m')^(n-n') * r'" using main by auto
    thus "n' = n \<Longrightarrow> hom r = r'" by auto
  }
  assume "m' \<noteq> m"
  hence m'm: "m' < m" using m'm by auto
  thus "n' = n \<Longrightarrow> ?goal" using main by simp
  assume "n' \<noteq> n"
  hence "n' < n" using n'n by auto
  hence "hom (coeff q n) = 0"
    unfolding coeffq'[symmetric] unfolding n'_def by(rule coeff_eq_0)
  hence "hom (coeff q n) ^ (m-m') = 0" using m'm by (simp add: power_0_left)
  from main[unfolded this]
  show "hom r = 0" using power_0_Suc by auto
qed
*)

subsubsection\<open>Resultant as Polynomial Expression\<close>
context begin
text \<open>This context provides notions for proving Lemma 7.2.1 of the textbook.\<close>

private fun mk_poly_sub where
  "mk_poly_sub A l 0 = A"
| "mk_poly_sub A l (Suc j) = mat_addcol (monom 1 (Suc j)) l (l-Suc j) (mk_poly_sub A l j)"

definition  "mk_poly A = mk_poly_sub (map_mat coeff_lift A) (dim_col A - 1) (dim_col A - 1)"

private lemma mk_poly_sub_dim[simp]:
  "dim_row (mk_poly_sub A l j) = dim_row A"
  "dim_col (mk_poly_sub A l j) = dim_col A"
  by (induct j,auto)

private lemma mk_poly_sub_carrier:
  assumes "A \<in> carrier_mat nr nc" shows "mk_poly_sub A l j \<in> carrier_mat nr nc"
  apply (rule carrier_matI) using assms by auto

private lemma mk_poly_dim[simp]:
  "dim_col (mk_poly A) = dim_col A"
  "dim_row (mk_poly A) = dim_row A"
  unfolding mk_poly_def by auto

private lemma mk_poly_sub_others[simp]:
  assumes "l \<noteq> j'" and "i < dim_row A" and "j' < dim_col A"
  shows "mk_poly_sub A l j $$ (i,j') = A $$ (i,j')"
  using assms by (induct j; simp)

private lemma mk_poly_others[simp]:
  assumes i: "i < dim_row A" and j: "j < dim_col A - 1"
  shows "mk_poly A $$ (i,j) = [: A $$ (i,j) :]"
  unfolding mk_poly_def
  apply(subst mk_poly_sub_others)
  using i j by auto

private lemma mk_poly_delete[simp]:
  assumes i: "i < dim_row A"
  shows "mat_delete (mk_poly A) i (dim_col A - 1) = map_mat coeff_lift (mat_delete A i (dim_col A - 1))"
  apply(rule eq_matI) unfolding mat_delete_def by auto

private lemma col_mk_poly_sub[simp]:
  assumes "l \<noteq> j'" and "j' < dim_col A"
  shows "col (mk_poly_sub A l j) j' = col A j'"
  by(rule eq_vecI; insert assms; simp)

private lemma det_mk_poly_sub:
  assumes A: "(A :: 'a :: comm_ring_1 poly mat) \<in> carrier_mat n n" and i: "i < n"
  shows "det (mk_poly_sub A (n-1) i) = det A"
  using i
proof (induct i)
  case (Suc i)
    show ?case unfolding mk_poly_sub.simps
    apply(subst det_addcol[of _ n])
      using Suc apply simp
      using Suc apply simp
      apply (rule mk_poly_sub_carrier[OF A])
      using Suc by auto
qed simp

private lemma det_mk_poly:
  fixes A :: "'a :: comm_ring_1 mat"
  shows "det (mk_poly A) = [: det A :]"
proof (cases "dim_row A = dim_col A")
  case True
    define n where "n = dim_col A"
    have "map_mat coeff_lift A \<in> carrier_mat (dim_row A) (dim_col A)" by simp
    hence sq: "map_mat coeff_lift A \<in> carrier_mat (dim_col A) (dim_col A)" unfolding True.
    show ?thesis
    proof(cases "dim_col A = 0")
      case True thus ?thesis unfolding det_def by simp
      next case False thus ?thesis
      unfolding mk_poly_def
      by (subst det_mk_poly_sub[OF sq]; simp)
    qed
  next case False
    hence f2: "dim_row A = dim_col A \<longleftrightarrow> False" by simp
    hence f3: "dim_row (mk_poly A) = dim_col (mk_poly A) \<longleftrightarrow> False"
      unfolding mk_poly_dim by auto
    show ?thesis unfolding det_def unfolding f2 f3 if_False by simp
qed

private fun mk_poly2_row where
  "mk_poly2_row A d j pv 0 = pv"
| "mk_poly2_row A d j pv (Suc n) =
   mk_poly2_row A d j pv n |\<^sub>v n \<mapsto> pv $ n + monom (A$$(n,j)) d"

private fun mk_poly2_col where
  "mk_poly2_col A pv 0 = pv"
| "mk_poly2_col A pv (Suc m) =
   mk_poly2_row A m (dim_col A - Suc m) (mk_poly2_col A pv m) (dim_row A)"

private definition "mk_poly2 A \<equiv> mk_poly2_col A (0\<^sub>v (dim_row A)) (dim_col A)"

private lemma mk_poly2_row_dim[simp]: "dim_vec (mk_poly2_row A d j pv i) = dim_vec pv"
  by(induct i arbitrary: pv, auto)

private lemma mk_poly2_col_dim[simp]: "dim_vec (mk_poly2_col A pv j) = dim_vec pv"
  by (induct j arbitrary: pv, auto)

private lemma mk_poly2_row:
  assumes n: "n \<le> dim_vec pv"
  shows "mk_poly2_row A d j pv n $ i =
    (if i < n then pv $ i + monom (A $$ (i,j)) d else pv $ i)"
  using n
proof (induct n arbitrary: pv)
  case (Suc n) thus ?case
    unfolding mk_poly2_row.simps by (cases rule: linorder_cases[of "i" "n"],auto)
qed simp

private lemma mk_poly2_row_col:
  assumes dim[simp]: "dim_vec pv = n" "dim_row A = n" and j: "j < dim_col A"
  shows "mk_poly2_row A d j pv n = pv + map_vec (\<lambda>a. monom a d) (col A j)"
  apply rule using mk_poly2_row[of _ pv] j by auto

private lemma mk_poly2_col:
  fixes pv :: "'a :: comm_semiring_1 poly vec" and A :: "'a mat"
  assumes i: "i < dim_row A" and dim: "dim_row A = dim_vec pv"
  shows "mk_poly2_col A pv j $ i = pv $ i + (\<Sum>j'<j. monom (A $$ (i, dim_col A - Suc j')) j')"
  using dim
proof (induct j arbitrary: pv)
  case (Suc j) show ?case
    unfolding mk_poly2_col.simps
    apply (subst mk_poly2_row)
      using Suc apply simp
    unfolding Suc(1)[OF Suc(2)]
    using i by (simp add: add.assoc)
qed simp

private lemma mk_poly2_pre:
  fixes A :: "'a :: comm_semiring_1 mat"
  assumes i: "i < dim_row A"
  shows "mk_poly2 A $ i = (\<Sum>j'<dim_col A. monom (A $$ (i, dim_col A - Suc j')) j')"
  unfolding mk_poly2_def
  apply(subst mk_poly2_col) using i by auto

private lemma mk_poly2:
  fixes A :: "'a :: comm_semiring_1 mat"
  assumes i: "i < dim_row A"
      and c: "dim_col A > 0"
  shows "mk_poly2 A $ i = (\<Sum>j'<dim_col A. monom (A $$ (i,j')) (dim_col A - Suc  j'))"
    (is "?l = sum ?f ?S")
proof -
  define l where "l = dim_col A - 1"
  have dim: "dim_col A = Suc l" unfolding l_def using i c by auto
  let ?g = "\<lambda>j. l - j"
  have "?l = sum (?f \<circ> ?g) ?S" unfolding l_def mk_poly2_pre[OF i] by auto
  also have "... = sum ?f ?S"
    unfolding dim
    unfolding lessThan_Suc_atMost
    using sum.reindex[OF inj_on_diff_nat2,symmetric,unfolded image_diff_atMost].
  finally show ?thesis.
qed

private lemma mk_poly2_sylvester_upper:
  fixes p q :: "'a :: comm_semiring_1 poly"
  assumes i: "i < degree q"
  shows "mk_poly2 (sylvester_mat p q) $ i = monom 1 (degree q - Suc i) * p"
  apply (subst mk_poly2)
    using i apply simp using i apply simp
  apply (subst sylvester_sum_mat_upper[OF i,symmetric])
  apply (rule sum.cong)
    unfolding sylvester_mat_dim lessThan_Suc_atMost apply simp
  by auto

private lemma mk_poly2_sylvester_lower:
  fixes p q :: "'a :: comm_semiring_1 poly"
  assumes mi: "i \<ge> degree q" and imn: "i < degree p + degree q"
  shows "mk_poly2 (sylvester_mat p q) $ i = monom 1 (degree p + degree q - Suc i) * q"
  apply (subst mk_poly2)
    using imn apply simp using mi imn apply simp
  unfolding sylvester_mat_dim
  using sylvester_sum_mat_lower[OF mi imn]
  apply (subst sylvester_sum_mat_lower) using mi imn by auto

private lemma foo:
  fixes v :: "'a :: comm_semiring_1 vec"
  shows "monom 1 d \<cdot>\<^sub>v map_vec coeff_lift v = map_vec (\<lambda>a. monom a d) v"
  apply (rule eq_vecI)
  unfolding index_map_vec index_col
  by (auto simp add: Polynomial.smult_monom)

private lemma mk_poly_sub_corresp:
  assumes dimA[simp]: "dim_col A = Suc l" and dimpv[simp]: "dim_vec pv = dim_row A"
      and j: "j < dim_col A"
  shows "pv + col (mk_poly_sub (map_mat coeff_lift A) l j) l =
    mk_poly2_col A pv (Suc j)"
proof(insert j, induct j)
  have le: "dim_row A \<le> dim_vec pv" using dimpv by simp
  have l: "l < dim_col A" using dimA by simp
  { case 0 show ?case
      apply (rule eq_vecI)
      using mk_poly2_row[OF le]
      by (auto simp add: monom_0)
  }
  { case (Suc j)
      hence j: "j < dim_col A" by simp
      show ?case
        unfolding mk_poly_sub.simps
        apply(subst col_addcol)
          apply simp
          apply simp
        apply(subst(2) comm_add_vec)
          apply(rule carrier_vecI, simp)
          apply(rule carrier_vecI, simp)
        apply(subst assoc_add_vec[symmetric])
          apply(rule carrier_vecI, rule refl)
          apply(rule carrier_vecI, simp)
          apply(rule carrier_vecI, simp)
        unfolding Suc(1)[OF j]
        apply(subst(2) mk_poly2_col.simps)
        apply(subst mk_poly2_row_col)
          apply simp
          apply simp
          using Suc apply simp
        apply(subst col_mk_poly_sub)
          using Suc apply simp
          using Suc apply simp
        apply(subst col_map_mat)
          using dimA apply simp
        unfolding foo dimA by simp
  }
qed

private lemma col_mk_poly_mk_poly2:
  fixes A :: "'a :: comm_semiring_1 mat"
  assumes dim: "dim_col A > 0"
  shows "col (mk_poly A) (dim_col A - 1) = mk_poly2 A"
proof -
  define l where "l = dim_col A - 1"
  have dim: "dim_col A = Suc l" unfolding l_def using dim by auto
  show ?thesis
    unfolding mk_poly_def mk_poly2_def dim
    apply(subst mk_poly_sub_corresp[symmetric])
      apply(rule dim)
      apply simp
      using dim apply simp
    apply(subst left_zero_vec)
      apply(rule carrier_vecI) using dim apply simp
    apply simp
    done
qed

private lemma mk_poly_mk_poly2:
  fixes A :: "'a :: comm_semiring_1 mat"
  assumes dim: "dim_col A > 0" and i: "i < dim_row A"
  shows "mk_poly A $$ (i,dim_col A - 1) = mk_poly2 A $ i"
proof -
  have "mk_poly A $$ (i,dim_col A - 1) = col (mk_poly A) (dim_col A - 1) $ i"
    apply (subst index_col(1)) using dim i by auto
  also note col_mk_poly_mk_poly2[OF dim]
  finally show ?thesis.
qed

lemma mk_poly_sylvester_upper:
  fixes p q :: "'a :: comm_ring_1 poly"
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes i: "i < n"
  shows "mk_poly (sylvester_mat p q) $$ (i, m + n - 1) = monom 1 (n - Suc i) * p" (is "?l = ?r")
proof -
  let ?S = "sylvester_mat p q"
  have c: "m+n = dim_col ?S" and r: "m+n = dim_row ?S" unfolding m_def n_def by auto
  hence "dim_col ?S > 0" "i < dim_row ?S" using i by auto
  from mk_poly_mk_poly2[OF this]
  have "?l = mk_poly2 (sylvester_mat p q) $ i" unfolding m_def n_def by auto
  also have "... = ?r"
    apply(subst mk_poly2_sylvester_upper)
      using i unfolding n_def m_def by auto
  finally show ?thesis.
qed

lemma mk_poly_sylvester_lower:
  fixes p q :: "'a :: comm_ring_1 poly"
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes ni: "n \<le> i" and imn: "i < m+n"
  shows "mk_poly (sylvester_mat p q) $$ (i, m + n - 1) = monom 1 (m + n - Suc i) * q" (is "?l = ?r")
proof -
  let ?S = "sylvester_mat p q"
  have c: "m+n = dim_col ?S" and r: "m+n = dim_row ?S" unfolding m_def n_def by auto
  hence "dim_col ?S > 0" "i < dim_row ?S" using imn by auto
  from mk_poly_mk_poly2[OF this]
  have "?l = mk_poly2 (sylvester_mat p q) $ i" unfolding m_def n_def by auto
  also have "... = ?r"
    apply(subst mk_poly2_sylvester_lower)
      using ni imn unfolding n_def m_def by auto
  finally show ?thesis.
qed

text \<open>The next lemma corresponds to Lemma 7.2.1.\<close>
lemma resultant_as_poly:
  fixes p q :: "'a :: comm_ring_1 poly"
  assumes degp: "degree p > 0" and degq: "degree q > 0"
  shows "\<exists>p' q'. degree p' < degree q \<and> degree q' < degree p \<and>
         [: resultant p q :] = p' * p + q' * q"
proof (intro exI conjI)
  define m where "m = degree p"
  define n where "n = degree q"
  define d where "d = dim_row (mk_poly (sylvester_mat p q))"
  define c where "c = (\<lambda>i. coeff_lift (cofactor (sylvester_mat p q) i (m+n-1)))"
  define p' where "p' = (\<Sum>i<n. monom 1 (n - Suc i) * c i)"
  define q' where "q' = (\<Sum>i<m. monom 1 (m - Suc i) * c (n+i))"

  have degc: "\<And>i. degree (c i) = 0" unfolding c_def by auto

  have dmn: "d = m+n" and mnd: "m + n = d" unfolding d_def m_def n_def by auto
  have "[: resultant p q :] =
    (\<Sum>i<d. mk_poly (sylvester_mat p q) $$ (i,m+n-1) *
        cofactor (mk_poly (sylvester_mat p q)) i (m+n-1))"
    unfolding resultant_def
    unfolding det_mk_poly[symmetric]
    unfolding m_def n_def d_def
    apply(rule laplace_expansion_column[of _ _ "degree p + degree q - 1"])
    apply(rule carrier_matI) using degp by auto
  also { fix i assume i: "i<d"
    have d2: "d = dim_row (sylvester_mat p q)" unfolding d_def by auto
    have "cofactor (mk_poly (sylvester_mat p q)) i (m+n-1) =
      (- 1) ^ (i + (m+n-1)) * det (mat_delete (mk_poly (sylvester_mat p q)) i (m+n-1))"
      using cofactor_def.
    also have "... =
      (- 1) ^ (i+m+n-1) * coeff_lift (det (mat_delete (sylvester_mat p q) i (m+n-1)))"
      using mk_poly_delete[OF i[unfolded d2]] degp degq
      unfolding m_def n_def by (auto simp add: add.assoc)
    also have "i+m+n-1 = i+(m+n-1)" using i[folded mnd] by auto
    finally have "cofactor (mk_poly (sylvester_mat p q)) i (m+n-1) = c i"
      unfolding c_def cofactor_def hom_distribs by simp
  }
  hence "... = (\<Sum>i<d. mk_poly (sylvester_mat p q) $$ (i, m+n-1) * c i)"
    (is "_ = sum ?f _") by auto
  also have "... = sum ?f ({..<n} \<union> {n ..<d})" unfolding dmn apply(subst ivl_disj_un(8)) by auto
  also have "... = sum ?f {..<n} + sum ?f {n..<d}" apply(subst sum.union_disjoint) by auto
  also { fix i assume i: "i < n"
    have "?f i = monom 1 (n - Suc i) * c i * p"
      unfolding m_def n_def
      apply(subst mk_poly_sylvester_upper)
      using i unfolding n_def by auto
  }
  hence "sum ?f {..<n} = p' * p" unfolding p'_def sum_distrib_right by auto
  also { fix i assume i: "i \<in> {n..<d}"
    have "?f i = monom 1 (m + n - Suc i) * c i * q"
      unfolding m_def n_def
      apply(subst mk_poly_sylvester_lower)
      using i unfolding dmn n_def m_def by auto
  }
  hence "sum ?f {n..<d} = (\<Sum>i=n..<d. monom 1 (m + n - Suc i) * c i) * q"
    (is "_ = sum ?h _ * _") unfolding sum_distrib_right by auto
  also have "{n..<d} = (\<lambda>i. i+n) ` {0..<m}"
    by (simp add: dmn)
  also have "sum ?h ... = sum (?h \<circ> (\<lambda>i. i+n)) {0..<m}"
    apply(subst sum.reindex[symmetric])
    apply (rule inj_onI) by auto
  also have "... = q'" unfolding q'_def apply(rule sum.cong) by (auto simp add: add.commute)
  finally show main: "[:resultant p q:] = p' * p + q' * q".
  show "degree p' < n"
    unfolding p'_def
    apply(rule degree_sum_smaller)
    using degq[folded n_def] apply force+
  proof -
    fix i assume i: "i \<in> {..<n}"
    show "degree (monom 1 (n - Suc i) * c i) < n"
      apply (rule order.strict_trans1)
      apply (rule degree_mult_le)
      unfolding add.right_neutral degc
      apply (rule order.strict_trans1)
      apply (rule degree_monom_le) using i by auto
  qed
  show "degree q' < m"
    unfolding q'_def
    apply (rule degree_sum_smaller)
    using degp[folded m_def] apply force+
  proof -
    fix i assume i: "i \<in> {..<m}"
    show "degree (monom 1 (m-Suc i) * c (n+i)) < m"
    apply (rule order.strict_trans1)
    apply (rule degree_mult_le)
    unfolding add.right_neutral degc
    apply (rule order.strict_trans1)
    apply (rule degree_monom_le) using i by auto
  qed
qed

end

subsubsection \<open>Resultant as Nonzero Polynomial Expression\<close>

lemma resultant_zero:
  fixes p q :: "'a :: comm_ring_1 poly"
  assumes deg: "degree p > 0 \<or> degree q > 0"
      and xp: "poly p x = 0" and xq: "poly q x = 0"
  shows "resultant p q = 0"
proof -
  { assume degp: "degree p > 0" and degq: "degree q > 0"
    obtain p' q' where "[: resultant p q :] = p' * p + q' * q"
      using resultant_as_poly[OF degp degq] by force
    hence "resultant p q = poly (p' * p + q' * q) x"
      using mpoly_base_conv(2)[of "resultant p q"] by auto
    also have "... = poly p x * poly p' x + poly q x * poly q' x"
      unfolding poly2_def by simp
    finally have ?thesis using xp xq by simp
  } moreover
  { assume degp: "degree p = 0"
    have p: "p = [:0:]" using xp degree_0_id[OF degp,symmetric] by (metis mpoly_base_conv(2))
    have ?thesis unfolding p using degp deg by simp
  } moreover
  { assume degq: "degree q = 0"
    have q: "q = [:0:]" using xq degree_0_id[OF degq,symmetric] by (metis mpoly_base_conv(2))
    have ?thesis unfolding q using degq deg by simp
  }
  ultimately show ?thesis by auto
qed

lemma poly_resultant_zero:
  fixes p q :: "'a :: comm_ring_1 poly poly"
  assumes deg: "degree p > 0 \<or> degree q > 0"
  assumes p0: "poly2 p x y = 0" and q0: "poly2 q x y = 0"
  shows "poly (resultant p q) x = 0"
proof -
  { assume "degree p > 0" "degree q > 0"
    from resultant_as_poly[OF this]
    obtain p' q' where "[: resultant p q :] = p' * p + q' * q" by force
    hence "resultant p q = poly (p' * p + q' * q) [:y:]"
      using mpoly_base_conv(2)[of "resultant p q"] by auto
    also have "poly ... x = poly2 p x y * poly2 p' x y + poly2 q x y * poly2 q' x y"
      unfolding poly2_def by simp
    finally have ?thesis unfolding p0 q0 by simp
  } moreover {
    assume degp: "degree p = 0"
    hence p: "p = [: coeff p 0 :]" by(subst degree_0_id[OF degp,symmetric],simp)
    hence "resultant p q = coeff p 0 ^ degree q" using resultant_const(1) by metis
    also have "poly ... x = poly (coeff p 0) x ^ degree q" by auto
    also have "... = poly2 p x y ^ degree q" unfolding poly2_def by(subst p, auto)
    finally have ?thesis unfolding p0 using deg degp zero_power by auto
  } moreover {
    assume degq: "degree q = 0"
    hence q: "q = [: coeff q 0 :]" by(subst degree_0_id[OF degq,symmetric],simp)
    hence "resultant p q = coeff q 0 ^ degree p" using resultant_const(2) by metis
    also have "poly ... x = poly (coeff q 0) x ^ degree p" by auto
    also have "... = poly2 q x y ^ degree p" unfolding poly2_def by(subst q, auto)
    finally have ?thesis unfolding q0 using deg degq zero_power by auto
  }
  ultimately show ?thesis by auto
qed

lemma resultant_as_nonzero_poly_weak:
  fixes p q :: "'a :: idom poly"
  assumes degp: "degree p > 0" and degq: "degree q > 0"
      and r0: "resultant p q \<noteq> 0"
  shows "\<exists>p' q'. degree p' < degree q \<and> degree q' < degree p \<and>
         [: resultant p q :] = p' * p + q' * q \<and> p' \<noteq> 0 \<and> q' \<noteq> 0"
proof -
  obtain p' q'
    where deg: "degree p' < degree q" "degree q' < degree p"
      and main: "[: resultant p q :] = p' * p + q' * q"
      using resultant_as_poly[OF degp degq] by auto
  have p0: "p \<noteq> 0" using degp by auto
  have q0: "q \<noteq> 0" using degq by auto
  show ?thesis
  proof (intro exI conjI notI)
    assume "p' = 0"
    hence "[: resultant p q :] = q' * q" using main by auto
    also hence d0: "0 = degree (q' * q)" by (metis degree_pCons_0)
      { assume "q' \<noteq> 0"
        hence "degree (q' * q) = degree q' + degree q"
          apply(rule degree_mult_eq) using q0 by auto
        hence False using d0 degq by auto
      } hence "q' = 0" by auto
    finally show False using r0 by auto
  next
    assume "q' = 0"
    hence "[: resultant p q :] = p' * p" using main by auto
    also
      hence d0: "0 = degree (p' * p)" by (metis degree_pCons_0)
      { assume "p' \<noteq> 0"
        hence "degree (p' * p) = degree p' + degree p"
          apply(rule degree_mult_eq) using p0 by auto
        hence False using d0 degp by auto
      } hence "p' = 0" by auto
    finally show False using r0 by auto
  qed fact+
qed

text \<open> Next lemma corresponds to Lemma 7.2.2 of the textbook \<close>

lemma resultant_as_nonzero_poly:
  fixes p q :: "'a :: idom poly"
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes degp: "m > 0" and degq: "n > 0"
  shows "\<exists>p' q'. degree p' < n \<and> degree q' < m \<and>
         [: resultant p q :] = p' * p + q' * q \<and> p' \<noteq> 0 \<and> q' \<noteq> 0"
proof (cases "resultant p q = 0")
  case False
  thus ?thesis
    using resultant_as_nonzero_poly_weak degp degq
    unfolding m_def n_def by auto
next case True
  define S where "S = transpose_mat (sylvester_mat p q)"
  have S: "S \<in> carrier_mat (m+n) (m+n)" unfolding S_def m_def n_def by auto
  have "det S = 0" using True
    unfolding resultant_def S_def apply (subst det_transpose) by auto
  then obtain v
    where v: "v \<in> carrier_vec (m+n)" and v0: "v \<noteq> 0\<^sub>v (m+n)" and "S *\<^sub>v v = 0\<^sub>v (m+n)"
    using det_0_iff_vec_prod_zero[OF S] by auto
  hence "poly_of_vec (S *\<^sub>v v) = 0" by auto
  hence main: "poly_of_vec (vec_first v n) * p + poly_of_vec (vec_last v m) * q = 0"
    (is "?p * _ + ?q * _ = _")
    using sylvester_vec_poly[OF v[unfolded m_def n_def], folded m_def n_def S_def]
    by auto
  have split: "vec_first v n @\<^sub>v vec_last v m = v"
    using vec_first_last_append[simplified add.commute] v by auto
  show ?thesis
  proof(intro exI conjI)
    show "[: resultant p q :] = ?p * p + ?q * q" unfolding True using main by auto
    show "?p \<noteq> 0"
    proof
      assume p'0: "?p = 0"
      hence "?q * q = 0" using main by auto
      hence "?q = 0" using degq n_def by auto
      hence "vec_last v m = 0\<^sub>v m" unfolding poly_of_vec_0_iff by auto
      also have "vec_first v n @\<^sub>v ... = 0\<^sub>v (m+n)" using p'0 unfolding poly_of_vec_0_iff by auto
      finally have "v = 0\<^sub>v (m+n)" using split by auto
      thus False using v0 by auto
    qed
    show "?q \<noteq> 0"
    proof
      assume q'0: "?q = 0"
      hence "?p * p = 0" using main by auto
      hence "?p = 0" using degp m_def by auto
      hence "vec_first v n = 0\<^sub>v n" unfolding poly_of_vec_0_iff by auto
      also have "... @\<^sub>v vec_last v m = 0\<^sub>v (m+n)" using q'0 unfolding poly_of_vec_0_iff by auto
      finally have "v = 0\<^sub>v (m+n)" using split by auto
      thus False using v0 by auto
    qed
    show "degree ?p < n" using degree_poly_of_vec_less[of "vec_first v n"] using degq by auto
    show "degree ?q < m" using degree_poly_of_vec_less[of "vec_last v m"] using degp by auto
  qed
qed

text\<open>Corresponds to Lemma 7.2.3 of the textbook\<close>

lemma resultant_zero_imp_common_factor:
  fixes p q :: "'a :: ufd poly"
  assumes deg: "degree p > 0 \<or> degree q > 0" and r0: "resultant p q = 0"
  shows "\<not> coprime p q"
  unfolding neq0_conv[symmetric]
proof -
  { assume degp: "degree p > 0" and degq: "degree q > 0"
    assume cop: "coprime p q"
    obtain p' q' where "p' * p + q' * q = 0"
      and p': "degree p' < degree q" and q': "degree q' < degree p"
      and p'0: "p' \<noteq> 0" and q'0: "q' \<noteq> 0"
      using resultant_as_nonzero_poly[OF degp degq] r0 by auto
    hence "p' * p = - q' * q" by (simp add: eq_neg_iff_add_eq_0)

    from some_gcd.coprime_mult_cross_dvd[OF cop this]
    have "p dvd q'" by auto
    from dvd_imp_degree_le[OF this q'0]
    have "degree p \<le> degree q'" by auto
    hence False using q' by auto
  }
  moreover
  { assume degp: "degree p = 0"
    then obtain x where "p = [:x:]" by (elim degree_eq_zeroE)
    moreover hence "resultant p q = x ^ degree q" using resultant_const by auto
      hence "x = 0" using r0 by auto
    ultimately have "p = 0" by auto
    hence ?thesis unfolding not_coprime_iff_common_factor
      by (metis deg degp dvd_0_right dvd_refl less_numeral_extra(3) poly_dvd_1)
  }
  moreover
  { assume degq: "degree q = 0"
    then obtain x where "q = [:x:]" by (elim degree_eq_zeroE)
    moreover hence "resultant p q = x ^ degree p" using resultant_const by auto
      hence "x = 0" using r0 by auto
    ultimately have "q = 0" by auto
    hence ?thesis unfolding not_coprime_iff_common_factor
      by (metis deg degq dvd_0_right dvd_refl less_numeral_extra(3) poly_dvd_1)
  }
  ultimately show ?thesis by auto
qed

lemma resultant_non_zero_imp_coprime:
  assumes nz: "resultant (f :: 'a :: field poly) g \<noteq> 0"
  and nz': "f \<noteq> 0 \<or> g \<noteq> 0"
shows "coprime f g"
proof (cases "degree f = 0 \<or> degree g = 0")
  case False
  define r where "r = [:resultant f g:]"
  from nz have r: "r \<noteq> 0" unfolding r_def by auto
  from False have "degree f > 0" "degree g > 0" by auto
  from resultant_as_nonzero_poly_weak[OF this nz]
  obtain p q where "degree p < degree g" "degree q < degree f"
    and id: "r = p * f + q * g"
    and "p \<noteq> 0" "q \<noteq> 0" unfolding r_def by auto
  define h where "h = some_gcd f g"
  have "h dvd f" "h dvd g" unfolding h_def by auto
  then obtain j k where f: "f = h * j" and g: "g = h * k" unfolding dvd_def by auto
  from id[unfolded f g] have id: "h * (p * j + q * k) = r" by (auto simp: field_simps)
  from arg_cong[OF id, of degree] have "degree (h * (p * j + q * k)) = 0"
    unfolding r_def by auto
  also have "degree (h * (p * j + q * k)) = degree h + degree (p * j + q * k)"
    by (subst degree_mult_eq, insert id r, auto)
  finally have h: "degree h = 0" "h \<noteq> 0" using r id by auto
  thus ?thesis unfolding h_def using is_unit_iff_degree some_gcd.gcd_dvd_1 by blast
next
  case True
  {
    fix f g :: "'a poly"
    assume deg_g: "degree g = 0" and res: "resultant f g \<noteq> 0" and nz: "f \<noteq> 0 \<or> g \<noteq> 0"
    have "coprime f g"
    proof (cases "g = 0")
      case False
      then show ?thesis using divides_degree[of _ g, unfolded deg_g]
        by (simp add: is_unit_right_imp_coprime)
    next
      case g: True
      then have "g = [:0:]" by auto
      from res[unfolded this resultant_const] have "degree f = 0" by auto
      with nz show ?thesis unfolding g by auto
    qed
  } note main = this
  from True
  show ?thesis
  proof
    assume f: "degree f = 0"
    from nz[unfolded resultant_swap[of f g]] have "resultant g f \<noteq> 0" by (auto split: if_splits)
    from main[OF f this] nz' show ?thesis by (auto simp: ac_simps)
  next
    assume "degree g = 0"
    from main[OF this nz nz'] show ?thesis .
  qed
qed

end


theory Env
  imports Main "HOLCF-Join-Classes"
begin

default_sort type

text \<open>
Our type for environments is a function with a pcpo as the co-domain; this theory collects
related definitions.
\<close>

subsubsection \<open>The domain of a pcpo-valued function\<close>

definition edom :: "('key \<Rightarrow> 'value::pcpo) \<Rightarrow> 'key set"
  where "edom m = {x. m x \<noteq> \<bottom>}"

lemma bot_edom[simp]: "edom \<bottom> = {}" by (simp add: edom_def)

lemma bot_edom2[simp]: "edom (\<lambda>_ . \<bottom>) = {}" by (simp add: edom_def)

lemma edomIff: "(a \<in> edom m) = (m a \<noteq> \<bottom>)" by (simp add: edom_def)
lemma edom_iff2: "(m a = \<bottom>) \<longleftrightarrow> (a \<notin> edom m)" by (simp add: edom_def)

lemma edom_empty_iff_bot: "edom m = {} \<longleftrightarrow> m = \<bottom>"
  by (metis below_bottom_iff bot_edom edomIff empty_iff fun_belowI)

lemma lookup_not_edom: "x \<notin> edom m \<Longrightarrow> m x = \<bottom>"  by (auto iff:edomIff)

lemma lookup_edom[simp]: "m x \<noteq> \<bottom> \<Longrightarrow> x \<in> edom m"  by (auto iff:edomIff)

lemma edom_mono: "x \<sqsubseteq> y \<Longrightarrow> edom x \<subseteq> edom y"
  unfolding edom_def
  by auto (metis below_bottom_iff fun_belowD)

lemma edom_subset_adm[simp]:
  "adm (\<lambda>ae'. edom ae' \<subseteq> S)"
  apply (rule admI)
  apply rule
  apply (subst (asm) edom_def) back
  apply simp
  apply (subst (asm) lub_fun) apply assumption
  apply (subst (asm) lub_eq_bottom_iff)
  apply (erule ch2ch_fun)
  unfolding not_all
  apply (erule exE)
  apply (rule subsetD)
  apply (rule allE) apply assumption apply assumption
  unfolding edom_def
  apply simp
  done

subsubsection \<open>Updates\<close>

lemma edom_fun_upd_subset: "edom (h (x := v)) \<subseteq> insert x (edom h)"
  by (auto simp add: edom_def)

declare fun_upd_same[simp] fun_upd_other[simp]

subsubsection \<open>Restriction\<close>

definition env_restr :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b::pcpo) \<Rightarrow> ('a \<Rightarrow> 'b)"
  where "env_restr S m = (\<lambda> x. if x \<in> S then m x else \<bottom>)"

abbreviation env_restr_rev  (infixl "f|`"  110)
  where "env_restr_rev m S \<equiv> env_restr S m"

notation (latex output) env_restr_rev ("_|\<^bsub>_\<^esub>")

lemma env_restr_empty_iff[simp]: "m f|` S = \<bottom> \<longleftrightarrow> edom m \<inter> S = {}"
  apply (auto simp add: edom_def env_restr_def lambda_strict[symmetric]  split:if_splits)
  apply metis
  apply (fastforce simp add: edom_def env_restr_def lambda_strict[symmetric]  split:if_splits)
  done
lemmas env_restr_empty = iffD2[OF env_restr_empty_iff, simp]

lemma lookup_env_restr[simp]: "x \<in> S \<Longrightarrow> (m f|` S) x = m x"
  by (fastforce simp add: env_restr_def)

lemma lookup_env_restr_not_there[simp]: "x \<notin> S \<Longrightarrow> (env_restr S m) x = \<bottom>"
  by (fastforce simp add: env_restr_def)

lemma lookup_env_restr_eq: "(m f|` S) x = (if x \<in> S then m x else \<bottom>)"
  by simp

lemma env_restr_eqI: "(\<And>x. x \<in> S \<Longrightarrow> m\<^sub>1 x = m\<^sub>2 x) \<Longrightarrow> m\<^sub>1 f|` S = m\<^sub>2 f|` S"
  by (auto simp add: lookup_env_restr_eq)

lemma env_restr_eqD: "m\<^sub>1 f|` S = m\<^sub>2 f|` S \<Longrightarrow> x \<in> S \<Longrightarrow> m\<^sub>1 x = m\<^sub>2 x"
  by (auto dest!: fun_cong[where x = x])

lemma env_restr_belowI: "(\<And>x. x \<in> S \<Longrightarrow> m\<^sub>1 x \<sqsubseteq> m\<^sub>2 x) \<Longrightarrow> m\<^sub>1 f|` S \<sqsubseteq> m\<^sub>2 f|` S"
  by (auto intro: fun_belowI simp add: lookup_env_restr_eq)

lemma env_restr_env_restr[simp]:
 "x f|` d2 f|` d1 = x f|` (d1 \<inter> d2)"
  by (fastforce simp add: env_restr_def)

lemma env_restr_env_restr_subset:
 "d1 \<subseteq> d2 \<Longrightarrow> x f|` d2 f|` d1 = x f|` d1"
 by (metis Int_absorb2 env_restr_env_restr)

lemma env_restr_useless: "edom m \<subseteq> S \<Longrightarrow> m f|` S = m"
  by (rule ext) (auto simp add: lookup_env_restr_eq dest!: subsetD)

lemma env_restr_UNIV[simp]: "m f|` UNIV = m"
  by (rule env_restr_useless) simp

lemma env_restr_fun_upd[simp]: "x \<in> S \<Longrightarrow> m1(x := v) f|` S = (m1 f|` S)(x := v)"
  apply (rule ext)
  apply (case_tac "xa = x")
  apply (auto simp add: lookup_env_restr_eq)
  done

lemma env_restr_fun_upd_other[simp]: "x \<notin> S \<Longrightarrow> m1(x := v) f|` S = m1 f|` S"
  apply (rule ext)
  apply (case_tac "xa = x")
  apply (auto simp add: lookup_env_restr_eq)
  done

lemma env_restr_eq_subset:
  assumes "S \<subseteq> S'"
  and "m1 f|` S' = m2 f|` S'"
  shows "m1 f|` S = m2 f|` S"
using assms
by (metis env_restr_env_restr le_iff_inf)

lemma env_restr_below_subset:
  assumes "S \<subseteq> S'"
  and "m1 f|` S' \<sqsubseteq> m2 f|` S'"
  shows "m1 f|` S \<sqsubseteq> m2 f|` S"
using assms
by (auto intro!: env_restr_belowI dest!: env_restr_belowD)

lemma edom_env[simp]:
  "edom (m f|` S) = edom m \<inter> S"
  unfolding edom_def env_restr_def by auto

lemma env_restr_below_self: "f f|` S \<sqsubseteq> f"
  by (rule fun_belowI) (auto simp add: env_restr_def)

lemma env_restr_below_trans:
  "m1 f|` S1 \<sqsubseteq> m2 f|` S1 \<Longrightarrow> m2 f|` S2 \<sqsubseteq> m3 f|` S2 \<Longrightarrow> m1 f|` (S1 \<inter> S2) \<sqsubseteq> m3 f|` (S1 \<inter> S2)"
by (auto intro!: env_restr_belowI dest!: env_restr_belowD elim: below_trans)

lemma env_restr_cont: "cont (env_restr S)"
  apply (rule cont2cont_lambda)
  unfolding env_restr_def
  apply (intro cont2cont cont_fun)
  done

lemma env_restr_mono: "m1 \<sqsubseteq> m2 \<Longrightarrow>  m1 f|` S \<sqsubseteq> m2 f|` S"
  by (metis env_restr_belowI fun_belowD)

lemma env_restr_mono2: "S2 \<subseteq> S1  \<Longrightarrow> m f|` S2 \<sqsubseteq> m f|` S1"
  by (metis env_restr_below_self env_restr_env_restr_subset)

lemmas cont_compose[OF env_restr_cont, cont2cont, simp]

lemma env_restr_cong: "(\<And>x. edom m \<subseteq> S \<inter> S' \<union> -S \<inter> -S')  \<Longrightarrow> m f|` S = m f|` S'"
  by (rule ext)(auto simp add: lookup_env_restr_eq edom_def)

subsubsection \<open>Deleting\<close>

definition env_delete :: "'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::pcpo)"
  where "env_delete x m = m(x := \<bottom>)"

lemma lookup_env_delete[simp]:
  "x' \<noteq> x \<Longrightarrow> env_delete x m x' = m x'"
  by (simp add: env_delete_def)

lemma lookup_env_delete_None[simp]:
  "env_delete x m x = \<bottom>"
  by (simp add: env_delete_def)

lemma edom_env_delete[simp]:
  "edom (env_delete x m) = edom m - {x}"
  by (auto simp add: env_delete_def edom_def)

lemma edom_env_delete_subset:
  "edom (env_delete x m) \<subseteq> edom m" by auto

lemma env_delete_fun_upd[simp]:
  "env_delete x (m(x := v)) = env_delete x m"
  by (auto simp add: env_delete_def)

lemma env_delete_fun_upd2[simp]:
  "(env_delete x m)(x := v) = m(x := v)"
  by (auto simp add: env_delete_def)

lemma env_delete_fun_upd3[simp]:
  "x \<noteq> y \<Longrightarrow> env_delete x (m(y := v)) = (env_delete x m)(y := v)"
  by (auto simp add: env_delete_def)

lemma env_delete_noop[simp]:
  "x \<notin> edom m \<Longrightarrow> env_delete x m = m"
  by (auto simp add: env_delete_def edom_def)

lemma env_restr_env_delete_other[simp]: "x \<notin> S \<Longrightarrow> env_delete x m f|` S = m f|` S"
  apply (rule ext)
  apply (auto simp add: lookup_env_restr_eq)
  by (metis lookup_env_delete)

lemma env_delete_restr: "env_delete x m = m f|` (-{x})"
  by (auto simp add: lookup_env_restr_eq)

lemma below_env_deleteI: "f x = \<bottom> \<Longrightarrow> f \<sqsubseteq> g \<Longrightarrow> f \<sqsubseteq> env_delete x g"
  by (metis env_delete_def env_delete_restr env_restr_mono fun_upd_triv)

lemma env_delete_below_cong[intro]:
  assumes "x \<noteq> v \<Longrightarrow> e1 x \<sqsubseteq> e2 x"
  shows "env_delete v e1 x \<sqsubseteq> env_delete v e2 x"
  using assms unfolding env_delete_def by auto

lemma env_delete_env_restr_swap:
  "env_delete x (env_restr S e) = env_restr S (env_delete x e)"
  by (metis (erased, hide_lams) env_delete_def env_restr_fun_upd env_restr_fun_upd_other fun_upd_triv lookup_env_restr_eq)

lemma env_delete_mono:
  "m \<sqsubseteq> m' \<Longrightarrow> env_delete x m \<sqsubseteq> env_delete x m'"
  unfolding env_delete_restr
  by (rule env_restr_mono)

lemma env_delete_below_arg:
  "env_delete x m \<sqsubseteq> m"
  unfolding env_delete_restr
  by (rule env_restr_below_self)

subsubsection \<open>Merging of two functions\<close>

text \<open>
We'd like to have some nice syntax for @{term "override_on"}.
\<close>

abbreviation override_on_syn ("_ ++\<^bsub>_\<^esub> _" [100, 0, 100] 100) where "f1 ++\<^bsub>S\<^esub> f2 \<equiv> override_on f1 f2 S"

lemma override_on_bot[simp]:
  "\<bottom> ++\<^bsub>S\<^esub> m = m f|` S"
  "m ++\<^bsub>S\<^esub> \<bottom> = m f|` (-S)"
  by (auto simp add: override_on_def env_restr_def)

lemma edom_override_on[simp]: "edom (m1 ++\<^bsub>S\<^esub> m2) = (edom m1 - S) \<union> (edom m2 \<inter> S)"
  by (auto simp add: override_on_def edom_def)

lemma lookup_override_on_eq: "(m1 ++\<^bsub>S\<^esub> m2) x = (if x \<in> S then m2 x else m1 x)"
  by (cases "x \<notin> S") simp_all

lemma override_on_upd_swap:
  "x \<notin> S \<Longrightarrow> \<rho>(x := z) ++\<^bsub>S\<^esub> \<rho>' = (\<rho> ++\<^bsub>S\<^esub> \<rho>')(x := z)"
  by (auto simp add: override_on_def  edom_def)

lemma override_on_upd:
  "x \<in> S \<Longrightarrow> \<rho> ++\<^bsub>S\<^esub> (\<rho>'(x := z)) = (\<rho> ++\<^bsub>S - {x}\<^esub> \<rho>')(x := z)"
  by (auto simp add: override_on_def  edom_def)

lemma env_restr_add: "(m1 ++\<^bsub>S2\<^esub> m2) f|` S = m1 f|` S ++\<^bsub>S2\<^esub> m2 f|` S"
  by (auto simp add: override_on_def  edom_def env_restr_def)

lemma env_delete_add: "env_delete x (m1 ++\<^bsub>S\<^esub> m2) = env_delete x m1 ++\<^bsub>S - {x}\<^esub> env_delete x m2"
  by (auto simp add: override_on_def  edom_def env_restr_def env_delete_def)

subsubsection \<open>Environments with binary joins\<close>

lemma edom_join[simp]: "edom (f \<squnion> (g::('a::type \<Rightarrow> 'b::{Finite_Join_cpo,pcpo}))) = edom f \<union> edom g"
  unfolding edom_def by auto

lemma env_delete_join[simp]: "env_delete x (f \<squnion> (g::('a::type \<Rightarrow> 'b::{Finite_Join_cpo,pcpo}))) = env_delete x f \<squnion> env_delete x g"
  by (metis env_delete_def fun_upd_meet_simp)

lemma env_restr_join:
  fixes m1 m2 :: "'a::type \<Rightarrow> 'b::{Finite_Join_cpo,pcpo}"
  shows "(m1 \<squnion> m2) f|` S = (m1 f|` S) \<squnion> (m2 f|` S )"
  by (auto simp add: env_restr_def)

lemma env_restr_join2:
  fixes m :: "'a::type \<Rightarrow> 'b::{Finite_Join_cpo,pcpo}"
  shows "m f|` S \<squnion> m f|` S' = m f|` (S \<union> S')"
  by (auto simp add: env_restr_def)

lemma join_env_restr_UNIV:
  fixes m :: "'a::type \<Rightarrow> 'b::{Finite_Join_cpo,pcpo}"
  shows "S1 \<union> S2 = UNIV \<Longrightarrow> (m f|` S1) \<squnion> (m f|` S2) = m"
  by (fastforce simp add: env_restr_def)

lemma env_restr_split:
  fixes m :: "'a::type \<Rightarrow> 'b::{Finite_Join_cpo,pcpo}"
  shows "m = m f|` S \<squnion> m f|` (- S)"
by (simp add: env_restr_join2 Compl_partition)

lemma env_restr_below_split:
  "m f|` S \<sqsubseteq> m' \<Longrightarrow> m f|` (- S) \<sqsubseteq> m' \<Longrightarrow> m \<sqsubseteq> m'"
  by (metis ComplI fun_below_iff lookup_env_restr)

subsubsection \<open>Singleton environments\<close>

definition esing :: "'a \<Rightarrow> 'b::{pcpo} \<rightarrow> ('a \<Rightarrow> 'b)"
  where "esing x = (\<Lambda> a. (\<lambda> y . (if x = y then a else \<bottom>)))"

lemma esing_bot[simp]: "esing x \<cdot> \<bottom> = \<bottom>"
  by (rule ext)(simp add: esing_def)

lemma esing_simps[simp]:
  "(esing x \<cdot> n) x = n"
  "x' \<noteq> x \<Longrightarrow> (esing x \<cdot> n) x' = \<bottom>"
  by (simp_all add: esing_def)

lemma esing_eq_up_iff[simp]: "(esing x\<cdot>(up\<cdot>a)) y = up\<cdot>a' \<longleftrightarrow> (x = y \<and> a = a')"
  by (auto simp add: fun_below_iff esing_def)

lemma esing_below_iff[simp]: "esing x \<cdot> a \<sqsubseteq> ae  \<longleftrightarrow> a \<sqsubseteq> ae x"
  by (auto simp add: fun_below_iff esing_def)

lemma edom_esing_subset: "edom (esing x\<cdot>n) \<subseteq> {x}"
  unfolding edom_def esing_def by auto

lemma edom_esing_up[simp]: "edom (esing x \<cdot> (up \<cdot> n)) = {x}"
  unfolding edom_def esing_def by auto

lemma env_delete_esing[simp]: "env_delete x (esing x \<cdot> n) = \<bottom>"
  unfolding env_delete_def esing_def
  by auto

lemma env_restr_esing[simp]:
  "x\<in> S \<Longrightarrow> esing x\<cdot>v f|` S = esing x\<cdot>v"
  by (auto intro: env_restr_useless dest: subsetD[OF edom_esing_subset])

lemma env_restr_esing2[simp]:
  "x \<notin> S \<Longrightarrow> esing x\<cdot>v f|` S = \<bottom>"
  by (auto  dest: subsetD[OF edom_esing_subset])

lemma esing_eq_iff[simp]:
  "esing x\<cdot>v = esing x\<cdot>v' \<longleftrightarrow> v = v'"
  by (metis esing_simps(1))

end


(*  Title:      ZF/EquivClass.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>Equivalence Relations\<close>

theory EquivClass imports Trancl Perm begin

definition
  quotient   :: "[i,i]=>i"    (infixl "'/'/" 90)  (*set of equiv classes*)  where
      "A//r == {r``{x} . x \<in> A}"

definition
  congruent  :: "[i,i=>i]=>o"  where
      "congruent(r,b) == \<forall>y z. <y,z>:r \<longrightarrow> b(y)=b(z)"

definition
  congruent2 :: "[i,i,[i,i]=>i]=>o"  where
      "congruent2(r1,r2,b) == \<forall>y1 z1 y2 z2.
           <y1,z1>:r1 \<longrightarrow> <y2,z2>:r2 \<longrightarrow> b(y1,y2) = b(z1,z2)"

abbreviation
  RESPECTS ::"[i=>i, i] => o"  (infixr "respects" 80) where
  "f respects r == congruent(r,f)"

abbreviation
  RESPECTS2 ::"[i=>i=>i, i] => o"  (infixr "respects2 " 80) where
  "f respects2 r == congruent2(r,r,f)"
    \<comment>\<open>Abbreviation for the common case where the relations are identical\<close>

subsection\<open>Suppes, Theorem 70:
    @{term r} is an equiv relation iff @{term "converse(r) O r = r"}\<close>

(** first half: equiv(A,r) ==> converse(r) O r = r **)

lemma sym_trans_comp_subset:
    "[| sym(r); trans(r) |] ==> converse(r) O r \<subseteq> r"
by (unfold trans_def sym_def, blast)

lemma refl_comp_subset:
    "[| refl(A,r); r \<subseteq> A*A |] ==> r \<subseteq> converse(r) O r"
by (unfold refl_def, blast)

lemma equiv_comp_eq:
    "equiv(A,r) ==> converse(r) O r = r"
apply (unfold equiv_def)
apply (blast del: subsetI intro!: sym_trans_comp_subset refl_comp_subset)
done

(*second half*)
lemma comp_equivI:
    "[| converse(r) O r = r;  domain(r) = A |] ==> equiv(A,r)"
apply (unfold equiv_def refl_def sym_def trans_def)
apply (erule equalityE)
apply (subgoal_tac "\<forall>x y. <x,y> \<in> r \<longrightarrow> <y,x> \<in> r", blast+)
done

(** Equivalence classes **)

(*Lemma for the next result*)
lemma equiv_class_subset:
    "[| sym(r);  trans(r);  <a,b>: r |] ==> r``{a} \<subseteq> r``{b}"
by (unfold trans_def sym_def, blast)

lemma equiv_class_eq:
    "[| equiv(A,r);  <a,b>: r |] ==> r``{a} = r``{b}"
apply (unfold equiv_def)
apply (safe del: subsetI intro!: equalityI equiv_class_subset)
apply (unfold sym_def, blast)
done

lemma equiv_class_self:
    "[| equiv(A,r);  a \<in> A |] ==> a \<in> r``{a}"
by (unfold equiv_def refl_def, blast)

(*Lemma for the next result*)
lemma subset_equiv_class:
    "[| equiv(A,r);  r``{b} \<subseteq> r``{a};  b \<in> A |] ==> <a,b>: r"
by (unfold equiv_def refl_def, blast)

lemma eq_equiv_class: "[| r``{a} = r``{b};  equiv(A,r);  b \<in> A |] ==> <a,b>: r"
by (assumption | rule equalityD2 subset_equiv_class)+

(*thus r``{a} = r``{b} as well*)
lemma equiv_class_nondisjoint:
    "[| equiv(A,r);  x: (r``{a} \<inter> r``{b}) |] ==> <a,b>: r"
by (unfold equiv_def trans_def sym_def, blast)

lemma equiv_type: "equiv(A,r) ==> r \<subseteq> A*A"
by (unfold equiv_def, blast)

lemma equiv_class_eq_iff:
     "equiv(A,r) ==> <x,y>: r \<longleftrightarrow> r``{x} = r``{y} & x \<in> A & y \<in> A"
by (blast intro: eq_equiv_class equiv_class_eq dest: equiv_type)

lemma eq_equiv_class_iff:
     "[| equiv(A,r);  x \<in> A;  y \<in> A |] ==> r``{x} = r``{y} \<longleftrightarrow> <x,y>: r"
by (blast intro: eq_equiv_class equiv_class_eq dest: equiv_type)

(*** Quotients ***)

(** Introduction/elimination rules -- needed? **)

lemma quotientI [TC]: "x \<in> A ==> r``{x}: A//r"
apply (unfold quotient_def)
apply (erule RepFunI)
done

lemma quotientE:
    "[| X \<in> A//r;  !!x. [| X = r``{x};  x \<in> A |] ==> P |] ==> P"
by (unfold quotient_def, blast)

lemma Union_quotient:
    "equiv(A,r) ==> \<Union>(A//r) = A"
by (unfold equiv_def refl_def quotient_def, blast)

lemma quotient_disj:
    "[| equiv(A,r);  X \<in> A//r;  Y \<in> A//r |] ==> X=Y | (X \<inter> Y \<subseteq> 0)"
apply (unfold quotient_def)
apply (safe intro!: equiv_class_eq, assumption)
apply (unfold equiv_def trans_def sym_def, blast)
done

subsection\<open>Defining Unary Operations upon Equivalence Classes\<close>

(** Could have a locale with the premises equiv(A,r)  and  congruent(r,b)
**)

(*Conversion rule*)
lemma UN_equiv_class:
    "[| equiv(A,r);  b respects r;  a \<in> A |] ==> (\<Union>x\<in>r``{a}. b(x)) = b(a)"
apply (subgoal_tac "\<forall>x \<in> r``{a}. b(x) = b(a)")
 apply simp
 apply (blast intro: equiv_class_self)
apply (unfold equiv_def sym_def congruent_def, blast)
done

(*type checking of  @{term"\<Union>x\<in>r``{a}. b(x)"} *)
lemma UN_equiv_class_type:
    "[| equiv(A,r);  b respects r;  X \<in> A//r;  !!x.  x \<in> A ==> b(x) \<in> B |]
     ==> (\<Union>x\<in>X. b(x)) \<in> B"
apply (unfold quotient_def, safe)
apply (simp (no_asm_simp) add: UN_equiv_class)
done

(*Sufficient conditions for injectiveness.  Could weaken premises!
  major premise could be an inclusion; bcong could be !!y. y \<in> A ==> b(y):B
*)
lemma UN_equiv_class_inject:
    "[| equiv(A,r);   b respects r;
        (\<Union>x\<in>X. b(x))=(\<Union>y\<in>Y. b(y));  X \<in> A//r;  Y \<in> A//r;
        !!x y. [| x \<in> A; y \<in> A; b(x)=b(y) |] ==> <x,y>:r |]
     ==> X=Y"
apply (unfold quotient_def, safe)
apply (rule equiv_class_eq, assumption)
apply (simp add: UN_equiv_class [of A r b])
done

subsection\<open>Defining Binary Operations upon Equivalence Classes\<close>

lemma congruent2_implies_congruent:
    "[| equiv(A,r1);  congruent2(r1,r2,b);  a \<in> A |] ==> congruent(r2,b(a))"
by (unfold congruent_def congruent2_def equiv_def refl_def, blast)

lemma congruent2_implies_congruent_UN:
    "[| equiv(A1,r1);  equiv(A2,r2);  congruent2(r1,r2,b);  a \<in> A2 |] ==>
     congruent(r1, %x1. \<Union>x2 \<in> r2``{a}. b(x1,x2))"
apply (unfold congruent_def, safe)
apply (frule equiv_type [THEN subsetD], assumption)
apply clarify
apply (simp add: UN_equiv_class congruent2_implies_congruent)
apply (unfold congruent2_def equiv_def refl_def, blast)
done

lemma UN_equiv_class2:
    "[| equiv(A1,r1);  equiv(A2,r2);  congruent2(r1,r2,b);  a1: A1;  a2: A2 |]
     ==> (\<Union>x1 \<in> r1``{a1}. \<Union>x2 \<in> r2``{a2}. b(x1,x2)) = b(a1,a2)"
by (simp add: UN_equiv_class congruent2_implies_congruent
              congruent2_implies_congruent_UN)

(*type checking*)
lemma UN_equiv_class_type2:
    "[| equiv(A,r);  b respects2 r;
        X1: A//r;  X2: A//r;
        !!x1 x2.  [| x1: A; x2: A |] ==> b(x1,x2) \<in> B
     |] ==> (\<Union>x1\<in>X1. \<Union>x2\<in>X2. b(x1,x2)) \<in> B"
apply (unfold quotient_def, safe)
apply (blast intro: UN_equiv_class_type congruent2_implies_congruent_UN
                    congruent2_implies_congruent quotientI)
done

(*Suggested by John Harrison -- the two subproofs may be MUCH simpler
  than the direct proof*)
lemma congruent2I:
    "[|  equiv(A1,r1);  equiv(A2,r2);
        !! y z w. [| w \<in> A2;  <y,z> \<in> r1 |] ==> b(y,w) = b(z,w);
        !! y z w. [| w \<in> A1;  <y,z> \<in> r2 |] ==> b(w,y) = b(w,z)
     |] ==> congruent2(r1,r2,b)"
apply (unfold congruent2_def equiv_def refl_def, safe)
apply (blast intro: trans)
done

lemma congruent2_commuteI:
 assumes equivA: "equiv(A,r)"
     and commute: "!! y z. [| y \<in> A;  z \<in> A |] ==> b(y,z) = b(z,y)"
     and congt:   "!! y z w. [| w \<in> A;  <y,z>: r |] ==> b(w,y) = b(w,z)"
 shows "b respects2 r"
apply (insert equivA [THEN equiv_type, THEN subsetD])
apply (rule congruent2I [OF equivA equivA])
apply (rule commute [THEN trans])
apply (rule_tac [3] commute [THEN trans, symmetric])
apply (rule_tac [5] sym)
apply (blast intro: congt)+
done

(*Obsolete?*)
lemma congruent_commuteI:
    "[| equiv(A,r);  Z \<in> A//r;
        !!w. [| w \<in> A |] ==> congruent(r, %z. b(w,z));
        !!x y. [| x \<in> A;  y \<in> A |] ==> b(y,x) = b(x,y)
     |] ==> congruent(r, %w. \<Union>z\<in>Z. b(w,z))"
apply (simp (no_asm) add: congruent_def)
apply (safe elim!: quotientE)
apply (frule equiv_type [THEN subsetD], assumption)
apply (simp add: UN_equiv_class [of A r])
apply (simp add: congruent_def)
done

end


(*  Author:      David Sanan
    License:     LGPL
*)

(*  Title:      FactExample.thy
    Author:     David Sanan

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

(*<*)
theory FactExample
imports VcgSeq

begin
(*>*)

primrec fac:: "nat \<Rightarrow> nat"
where
"fac 0 = 1" |
"fac (Suc n) = (Suc n) * fac n"

(*<*)
lemma fac_simp [simp]: "0 < i \<Longrightarrow>  fac i = i * fac (i - 1)"
  by (cases i) simp_all
(*>*)

record vars =
  I_' :: nat
  M_' :: nat

definition Factorial
  where "Factorial n \<equiv>
  IF\<^sub>s (n = 0) THEN \<acute>I :==\<^sub>s 1
  ELSE
    \<acute>I:==\<^sub>s 1;;\<^sub>s \<acute>M:==\<^sub>s 1;;\<^sub>s
    WHILE\<^sub>s (\<acute>M<n) INV \<lbrace>\<acute>M \<le> n \<and> \<acute>I = fac \<acute>M\<rbrace> DO\<^sub>s
      \<acute>M:==\<^sub>s \<acute>M + 1;;\<^sub>s
      \<acute>I:==\<^sub>s \<acute>I*\<acute>M
    OD
  FI
"

lemma "\<forall>n. \<Gamma>\<turnstile> \<lbrace>True\<rbrace> Factorial n \<lbrace>\<acute>I = fac n\<rbrace>"
  unfolding Factorial_def apply vcg
  by auto

end
(*>*)


(*  Title:      ZF/Cardinal_AC.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

These results help justify infinite-branching datatypes
*)

section{*Cardinal Arithmetic Using AC*}

theory Cardinal_AC imports CardinalArith Zorn begin

subsection{*Strengthened Forms of Existing Theorems on Cardinals*}

lemma cardinal_eqpoll: "|A| \<approx> A"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_cardinal_eqpoll)
done

text{*The theorem @{term "||A|| = |A|"} *}
lemmas cardinal_idem = cardinal_eqpoll [THEN cardinal_cong, simp]

lemma cardinal_eqE: "|X| = |Y| ==> X \<approx> Y"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cardinal_eqE, assumption+)
done

lemma cardinal_eqpoll_iff: "|X| = |Y| \<longleftrightarrow> X \<approx> Y"
by (blast intro: cardinal_cong cardinal_eqE)

lemma cardinal_disjoint_Un:
     "[| |A|=|B|;  |C|=|D|;  A \<inter> C = 0;  B \<inter> D = 0 |]
      ==> |A \<union> C| = |B \<union> D|"
by (simp add: cardinal_eqpoll_iff eqpoll_disjoint_Un)

lemma lepoll_imp_Card_le: "A \<lesssim> B ==> |A| \<le> |B|"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_lepoll_imp_Card_le, assumption)
done

lemma cadd_assoc: "(i \<oplus> j) \<oplus> k = i \<oplus> (j \<oplus> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cadd_assoc, assumption+)
done

lemma cmult_assoc: "(i \<otimes> j) \<otimes> k = i \<otimes> (j \<otimes> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cmult_assoc, assumption+)
done

lemma cadd_cmult_distrib: "(i \<oplus> j) \<otimes> k = (i \<otimes> k) \<oplus> (j \<otimes> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cadd_cmult_distrib, assumption+)
done

lemma InfCard_square_eq: "InfCard(|A|) ==> A*A \<approx> A"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_InfCard_square_eq, assumption)
done

subsection {*The relationship between cardinality and le-pollence*}

lemma Card_le_imp_lepoll:
  assumes "|A| \<le> |B|" shows "A \<lesssim> B"
proof -
  have "A \<approx> |A|"
    by (rule cardinal_eqpoll [THEN eqpoll_sym])
  also have "... \<lesssim> |B|"
    by (rule le_imp_subset [THEN subset_imp_lepoll]) (rule assms)
  also have "... \<approx> B"
    by (rule cardinal_eqpoll)
  finally show ?thesis .
qed

lemma le_Card_iff: "Card(K) ==> |A| \<le> K \<longleftrightarrow> A \<lesssim> K"
apply (erule Card_cardinal_eq [THEN subst], rule iffI,
       erule Card_le_imp_lepoll)
apply (erule lepoll_imp_Card_le)
done

lemma cardinal_0_iff_0 [simp]: "|A| = 0 \<longleftrightarrow> A = 0"
apply auto
apply (drule cardinal_0 [THEN ssubst])
apply (blast intro: eqpoll_0_iff [THEN iffD1] cardinal_eqpoll_iff [THEN iffD1])
done

lemma cardinal_lt_iff_lesspoll:
  assumes i: "Ord(i)" shows "i < |A| \<longleftrightarrow> i \<prec> A"
proof
  assume "i < |A|"
  hence  "i \<prec> |A|"
    by (blast intro: lt_Card_imp_lesspoll Card_cardinal)
  also have "...  \<approx> A"
    by (rule cardinal_eqpoll)
  finally show "i \<prec> A" .
next
  assume "i \<prec> A"
  also have "...  \<approx> |A|"
    by (blast intro: cardinal_eqpoll eqpoll_sym)
  finally have "i \<prec> |A|" .
  thus  "i < |A|" using i
    by (force intro: cardinal_lt_imp_lt lesspoll_cardinal_lt)
qed

lemma cardinal_le_imp_lepoll: " i \<le> |A| ==> i \<lesssim> A"
  by (blast intro: lt_Ord Card_le_imp_lepoll Ord_cardinal_le le_trans)

subsection{*Other Applications of AC*}

lemma surj_implies_inj:
  assumes f: "f \<in> surj(X,Y)" shows "\<exists>g. g \<in> inj(Y,X)"
proof -
  from f AC_Pi [of Y "%y. f-``{y}"]
  obtain z where z: "z \<in> (\<Pi> y\<in>Y. f -`` {y})"
    by (auto simp add: surj_def) (fast dest: apply_Pair)
  show ?thesis
    proof
      show "z \<in> inj(Y, X)" using z surj_is_fun [OF f]
        by (blast dest: apply_type Pi_memberD
                  intro: apply_equality Pi_type f_imp_injective)
    qed
qed

text{*Kunen's Lemma 10.20*}
lemma surj_implies_cardinal_le:
  assumes f: "f \<in> surj(X,Y)" shows "|Y| \<le> |X|"
proof (rule lepoll_imp_Card_le)
  from f [THEN surj_implies_inj] obtain g where "g \<in> inj(Y,X)" ..
  thus "Y \<lesssim> X"
    by (auto simp add: lepoll_def)
qed

text{*Kunen's Lemma 10.21*}
lemma cardinal_UN_le:
  assumes K: "InfCard(K)"
  shows "(!!i. i\<in>K ==> |X(i)| \<le> K) ==> |\<Union>i\<in>K. X(i)| \<le> K"
proof (simp add: K InfCard_is_Card le_Card_iff)
  have [intro]: "Ord(K)" by (blast intro: InfCard_is_Card Card_is_Ord K)
  assume "!!i. i\<in>K ==> X(i) \<lesssim> K"
  hence "!!i. i\<in>K ==> \<exists>f. f \<in> inj(X(i), K)" by (simp add: lepoll_def)
  with AC_Pi obtain f where f: "f \<in> (\<Pi> i\<in>K. inj(X(i), K))"
    by force
  { fix z
    assume z: "z \<in> (\<Union>i\<in>K. X(i))"
    then obtain i where i: "i \<in> K" "Ord(i)" "z \<in> X(i)"
      by (blast intro: Ord_in_Ord [of K])
    hence "(LEAST i. z \<in> X(i)) \<le> i" by (fast intro: Least_le)
    hence "(LEAST i. z \<in> X(i)) < K" by (best intro: lt_trans1 ltI i)
    hence "(LEAST i. z \<in> X(i)) \<in> K" and "z \<in> X(LEAST i. z \<in> X(i))"
      by (auto intro: LeastI ltD i)
  } note mems = this
  have "(\<Union>i\<in>K. X(i)) \<lesssim> K \<times> K"
    proof (unfold lepoll_def)
      show "\<exists>f. f \<in> inj(\<Union>RepFun(K, X), K \<times> K)"
        apply (rule exI)
        apply (rule_tac c = "%z. \<langle>LEAST i. z \<in> X(i), f ` (LEAST i. z \<in> X(i)) ` z\<rangle>"
                    and d = "%\<langle>i,j\<rangle>. converse (f`i) ` j" in lam_injective)
        apply (force intro: f inj_is_fun mems apply_type Perm.left_inverse)+
        done
    qed
  also have "... \<approx> K"
    by (simp add: K InfCard_square_eq InfCard_is_Card Card_cardinal_eq)
  finally show "(\<Union>i\<in>K. X(i)) \<lesssim> K" .
qed

text{*The same again, using @{term csucc}*}
lemma cardinal_UN_lt_csucc:
     "[| InfCard(K);  \<And>i. i\<in>K \<Longrightarrow> |X(i)| < csucc(K) |]
      ==> |\<Union>i\<in>K. X(i)| < csucc(K)"
by (simp add: Card_lt_csucc_iff cardinal_UN_le InfCard_is_Card Card_cardinal)

text{*The same again, for a union of ordinals.  In use, j(i) is a bit like rank(i),
  the least ordinal j such that i:Vfrom(A,j). *}
lemma cardinal_UN_Ord_lt_csucc:
     "[| InfCard(K);  \<And>i. i\<in>K \<Longrightarrow> j(i) < csucc(K) |]
      ==> (\<Union>i\<in>K. j(i)) < csucc(K)"
apply (rule cardinal_UN_lt_csucc [THEN Card_lt_imp_lt], assumption)
apply (blast intro: Ord_cardinal_le [THEN lt_trans1] elim: ltE)
apply (blast intro!: Ord_UN elim: ltE)
apply (erule InfCard_is_Card [THEN Card_is_Ord, THEN Card_csucc])
done

subsection{*The Main Result for Infinite-Branching Datatypes*}

text{*As above, but the index set need not be a cardinal. Work
backwards along the injection from @{term W} into @{term K}, given
that @{term"W\<noteq>0"}.*}

lemma inj_UN_subset:
  assumes f: "f \<in> inj(A,B)" and a: "a \<in> A"
  shows "(\<Union>x\<in>A. C(x)) \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f)`y else a))"
proof (rule UN_least)
  fix x
  assume x: "x \<in> A"
  hence fx: "f ` x \<in> B" by (blast intro: f inj_is_fun [THEN apply_type])
  have "C(x) \<subseteq> C(if f ` x \<in> range(f) then converse(f) ` (f ` x) else a)"
    using f x by (simp add: inj_is_fun [THEN apply_rangeI])
  also have "... \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f) ` y else a))"
    by (rule UN_upper [OF fx])
  finally show "C(x) \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f)`y else a))" .
qed

theorem le_UN_Ord_lt_csucc:
  assumes IK: "InfCard(K)" and WK: "|W| \<le> K" and j: "\<And>w. w\<in>W \<Longrightarrow> j(w) < csucc(K)"
  shows "(\<Union>w\<in>W. j(w)) < csucc(K)"
proof -
  have CK: "Card(K)"
    by (simp add: InfCard_is_Card IK)
  then obtain f where f: "f \<in> inj(W, K)" using WK
    by(auto simp add: le_Card_iff lepoll_def)
  have OU: "Ord(\<Union>w\<in>W. j(w))" using j
    by (blast elim: ltE)
  note lt_subset_trans [OF _ _ OU, trans]
  show ?thesis
    proof (cases "W=0")
      case True  --{*solve the easy 0 case*}
      thus ?thesis by (simp add: CK Card_is_Ord Card_csucc Ord_0_lt_csucc)
    next
      case False
        then obtain x where x: "x \<in> W" by blast
        have "(\<Union>x\<in>W. j(x)) \<subseteq> (\<Union>k\<in>K. j(if k \<in> range(f) then converse(f) ` k else x))"
          by (rule inj_UN_subset [OF f x])
        also have "... < csucc(K)" using IK
          proof (rule cardinal_UN_Ord_lt_csucc)
            fix k
            assume "k \<in> K"
            thus "j(if k \<in> range(f) then converse(f) ` k else x) < csucc(K)" using f x j
              by (simp add: inj_converse_fun [THEN apply_type])
          qed
        finally show ?thesis .
    qed
qed

end


theory Set_Model
  imports Lattice
begin

definition SET where "SET \<equiv> \<lparr>carrier = UNIV, le = op \<subseteq>\<rparr>"

lemma SET_ord [intro]: "order SET"
  by (auto simp add: order_def SET_def)

lemma SET_js [intro]: "join_semilattice SET"
  by (auto simp add: join_semilattice_def join_semilattice_axioms_def order.is_lub_simp[OF SET_ord] intro: SET_ord) (auto simp add: SET_def)

lemma SET_ms [intro]: "meet_semilattice SET"
  by (auto simp add: meet_semilattice_def meet_semilattice_axioms_def order.is_glb_simp[OF SET_ord] intro: SET_ord) (auto simp add: SET_def)

lemma SET_lattice [intro]: "lattice SET"
  by (auto simp add: lattice_def intro: SET_ms SET_js)

lemma SET_meet [simp]: "x \<sqinter>\<^bsub>SET\<^esub> y = x \<inter> y"
  apply (simp add: order.meet_def[OF SET_ord] order.glb_def[OF SET_ord])
  apply (rule the1I2)
  apply auto
  apply (rule_tac x = "x \<inter> y" in exI)
  apply (simp add: order.is_glb_simp[OF SET_ord])
  apply (simp add: SET_def)
  apply (simp add: order.is_glb_simp[OF SET_ord], simp add: SET_def, blast)
  apply (simp add: order.is_glb_simp[OF SET_ord], simp add: SET_def, metis in_mono)
  apply (simp add: order.is_glb_simp[OF SET_ord], simp add: SET_def, metis in_mono)
  apply (simp add: order.is_glb_simp[OF SET_ord], simp add: SET_def, metis in_mono)
  apply (simp add: order.is_glb_simp[OF SET_ord], simp add: SET_def, blast)
  done

lemma SET_join [simp]: "x \<squnion>\<^bsub>SET\<^esub> y = x \<union> y"
  apply (simp add: order.join_def[OF SET_ord] order.lub_def[OF SET_ord])
  apply (rule the1I2)
  apply auto
  apply (rule_tac x = "x \<union> y" in exI)
  apply (simp add: order.is_lub_simp[OF SET_ord])
  apply (simp add: SET_def)
  apply (simp add: order.is_lub_simp[OF SET_ord], simp add: SET_def, metis in_mono)
  apply (simp add: order.is_lub_simp[OF SET_ord], simp add: SET_def, metis in_mono)
  apply (simp add: order.is_lub_simp[OF SET_ord], simp add: SET_def, blast)
  apply (simp add: order.is_lub_simp[OF SET_ord], simp add: SET_def, metis in_mono)
  apply (simp add: order.is_lub_simp[OF SET_ord], simp add: SET_def, blast)
  done

lemma SET_distrib [intro]: "distributive_lattice SET"
  by (auto simp add: distributive_lattice_def distributive_lattice_axioms_def intro: SET_lattice)

lemma SET_bounded [intro]: "bounded_lattice SET"
  by (simp add: bounded_lattice_def bounded_lattice_axioms_def SET_lattice) (auto simp add: SET_def)

lemma SET_top [simp]: "bounded_lattice.top SET = UNIV"
  by (simp add: bounded_lattice.top_def[OF SET_bounded], rule the1I2, auto simp add: SET_def)

lemma SET_bot [simp]: "bounded_lattice.bot SET = {}"
  by (simp add: bounded_lattice.bot_def[OF SET_bounded], rule the1I2, auto simp add: SET_def)

lemma SET_compl [intro]: "complemented_lattice SET"
  apply (simp add: complemented_lattice_def SET_bounded complemented_lattice_axioms_def)
  apply (simp add: SET_def)
  apply safe
  apply (rule_tac x = "-x" in exI)
  apply (rule conjI)
  by blast+

lemma SET_ba [intro]: "boolean_algebra SET"
  by (auto simp add: boolean_algebra_def)

lemma SET_cjs [intro]: "complete_join_semilattice SET"
  apply (auto simp add: complete_join_semilattice_def complete_join_semilattice_axioms_def)
  apply (rule_tac x = "\<Union>X" in bexI)
  apply (simp add: order.is_lub_simp[OF SET_ord])
  apply (auto simp add: SET_def)
  done

lemma SET_cms [intro]: "complete_meet_semilattice SET"
  by (metis SET_cjs complete_join_semilattice.is_cms)

lemma SET_cl [intro]: "complete_lattice SET"
  by (auto simp add: complete_lattice_def)

lemma SET_top_var [simp]: "complete_meet_semilattice.top SET = UNIV"
  by (simp add: complete_meet_semilattice.top_def[OF SET_cms], rule the1I2, auto simp add: SET_def)

lemma SET_bot_var [simp]: "complete_join_semilattice.bot SET = {}"
  by (simp add: complete_join_semilattice.bot_def[OF SET_cjs], rule the1I2, auto simp add: SET_def)

lemma SET_cbl: "complete_boolean_lattice SET"
  by (auto simp add: complete_boolean_lattice_def complete_boolean_lattice_axioms_def, rule_tac x = "-x" in exI, auto simp add: SET_def)

end


theory Star imports Main
begin

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"

hide_fact (open) refl step  \<comment> \<open>names too generic\<close>

lemma star_trans:
  "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
proof(induction rule: star.induct)
  case refl thus ?case .
next
  case step thus ?case by (metis star.step)
qed

lemmas star_induct =
  star.induct[of "r:: 'a*'b \<Rightarrow> 'a*'b \<Rightarrow> bool", split_format(complete)]

declare star.refl[simp,intro]

lemma star_step1[simp, intro]: "r x y \<Longrightarrow> star r x y"
by(metis star.refl star.step)

code_pred star .

end