(*
    ex.thy,v 1.1 2016/09/29 17:37:37 jdf Exp
    Original Author: Tjark Weber
    Updated to Isabelle 2016 and additions by Jacques Fleuriot
*)

section {* Propositional Logic *}

theory propositionalLogic imports Main begin

text {* In this exercise, we will prove some lemmas of propositional
logic with the aid of a calculus of natural deduction.

For the proofs, you may only use

notI: (?P \<Longrightarrow> False) \<Longrightarrow> \<not> ?P
notE: \<lbrakk>\<not> ?P; ?P\<rbrakk> \<Longrightarrow> ?R
conjI: \<lbrakk>?P; ?Q\<rbrakk> \<Longrightarrow> ?P \<and> ?Q
conjE: \<lbrakk>?P \<and> ?Q; \<lbrakk>?P; ?Q\<rbrakk> \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R
disjI1:?P \<Longrightarrow> ?P \<or> ?Q
disjI2: ?Q \<Longrightarrow> ?P \<or> ?Q
disjE: \<lbrakk>?P \<or> ?Q; ?P \<Longrightarrow> ?R; ?Q \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R
impI: (?P \<Longrightarrow> ?Q) \<Longrightarrow> ?P \<longrightarrow> ?Q
impE:\<lbrakk>?P \<longrightarrow> ?Q; ?P; ?Q \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R
mp: \<lbrakk>?P \<longrightarrow> ?Q; ?P\<rbrakk> \<Longrightarrow> ?Q
iffI:\<lbrakk>?P \<Longrightarrow> ?Q; ?Q \<Longrightarrow> ?P\<rbrakk> \<Longrightarrow> ?P = ?Q
iffE:\<lbrakk>?P = ?Q; \<lbrakk>?P \<longrightarrow> ?Q; ?Q \<longrightarrow> ?P\<rbrakk> \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R
classical: (\<not> ?P \<Longrightarrow> ?P) \<Longrightarrow> ?P

and the proof methods rule, erule and assumption.
\end{itemize}

Prove:
*}

lemma I: "A \<longrightarrow> A"
  apply (rule impI)
  apply assumption
  done

lemma "A \<and> B \<longrightarrow> B \<and> A"
  apply (rule impI)
  apply (erule conjE)
  apply (rule conjI)
   apply (assumption)
  apply (assumption)
  done

lemma "(A \<and> B) \<longrightarrow> (A \<or> B)"
  apply (rule impI)
  apply (erule conjE)
  apply (rule disjI1)
  apply (assumption)
  done

lemma "((A \<or> B) \<or> C) \<longrightarrow> A \<or> (B \<or> C)"
  apply (rule impI)
  apply (erule disjE)
   apply (erule disjE)
    apply (rule disjI1)
    apply assumption
   apply (rule disjI2)
  apply (rule disjI1)
   apply assumption
  apply (rule disjI2)
  apply (rule disjI2)
  apply assumption
  done

lemma "(A \<or> A) = (A \<and> A)"
  apply (rule iffI)
   apply (rule conjI)
    apply (erule disjE)
     apply assumption+
  apply (erule disjE)
    apply assumption+
  apply (erule conjE)
  apply (rule disjI1)
  apply assumption
  done

lemma S: "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> B) \<longrightarrow> A \<longrightarrow> C"
  apply (rule impI)+
  apply (erule impE)
   apply assumption
  apply (erule impE)
   apply assumption
  apply (erule impE)
   apply assumption+
  done

lemma "(A \<longrightarrow> B) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> A \<longrightarrow> C"
  apply (rule impI)+
  apply (erule impE)
   apply assumption
  apply (erule impE)
   apply assumption+
  done

lemma "\<not> \<not> A \<longrightarrow> A"
  apply (rule impI)
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma "A \<longrightarrow> \<not> \<not> A"
  apply (rule impI)
  apply (rule notI)
  apply (rule notE)
   apply assumption+
  done

lemma "(\<not> A \<longrightarrow> B) \<longrightarrow> (\<not> B \<longrightarrow> A)"
  apply (rule impI)+
  apply (rule classical)
  apply (erule impE)
   apply assumption
  apply (erule notE)
  apply assumption
  done

lemma "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
  apply (rule impI)
  apply (rule classical)
  apply (erule impE)
   apply (rule impI)
   apply (erule notE, assumption)+
  done

lemma "A \<or> \<not> A"
  apply (rule classical)
  apply (rule disjI2)
  apply (rule notI)
  apply (erule notE)
  apply (rule disjI1)
  apply assumption
  done

lemma "(\<not> (A \<and> B)) = (\<not> A \<or> \<not> B)"
  apply (rule iffI)
   apply (rule classical)
   apply (erule notE)
   apply (rule conjI)
    apply (rule classical)
    apply (erule notE)
    apply (rule disjI1)
    apply assumption
  apply (rule classical)
   apply (erule notE)
   apply (rule disjI2)
  apply assumption
  apply (rule notI)
  apply (erule conjE)
  apply (erule disjE)
   apply (erule notE, assumption)+
  done

end


(*
    Author:      Jose Divasón
    Email:       jose.divason@unirioja.es
*)

section \<open>Some theorems about rings and ideals\<close>

theory Rings2_Extended
  imports
    Echelon_Form.Rings2
    "HOL-Types_To_Sets.Types_To_Sets"
begin

subsection \<open>Missing properties on ideals\<close>

lemma ideal_generated_subset2:
  assumes  "\<forall>b\<in>B. b \<in> ideal_generated A"
  shows "ideal_generated B \<subseteq> ideal_generated A"
  by (metis (mono_tags, lifting) InterE assms ideal_generated_def
ideal_ideal_generated mem_Collect_eq subsetI)

context comm_ring_1
begin

lemma ideal_explicit: "ideal_generated S
      = {y. \<exists>f U. finite U \<and> U \<subseteq> S \<and> (\<Sum>i\<in>U. f i * i) = y}"
  by (simp add: ideal_generated_eq_left_ideal left_ideal_explicit)
end

lemma ideal_generated_minus:
  assumes a: "a \<in> ideal_generated (S-{a})"
  shows "ideal_generated S = ideal_generated (S-{a})"
proof (cases "a \<in> S")
  case True note a_in_S = True
  show ?thesis
  proof
    show "ideal_generated S \<subseteq> ideal_generated (S - {a})"
    proof (rule ideal_generated_subset2, auto)
      fix b assume b: "b \<in> S" show "b \<in> ideal_generated (S - {a})"
      proof (cases "b = a")
        case True
        then show ?thesis using a by auto
      next
        case False
        then show ?thesis using b
          by (simp add: ideal_generated_in)
      qed
    qed
    show "ideal_generated (S - {a}) \<subseteq> ideal_generated S"
      by (rule ideal_generated_subset, auto)
  qed
next
  case False
  then show ?thesis by simp
qed

lemma ideal_generated_dvd_eq:
  assumes a_dvd_b: "a dvd b"
  and a: "a \<in> S"
  and a_not_b: "a \<noteq> b"
  shows "ideal_generated S = ideal_generated (S - {b})"
proof
  show "ideal_generated S \<subseteq> ideal_generated (S - {b})"
  proof (rule ideal_generated_subset2, auto)
    fix x assume x: "x \<in> S"
    show "x \<in> ideal_generated (S - {b})"
    proof (cases "x = b")
      case True
      obtain k where b_ak: "b = a * k" using a_dvd_b unfolding dvd_def by blast
      let ?f = "\<lambda>c. k"
      have "(\<Sum>i\<in>{a}. i * ?f i) = x" using True b_ak by auto
      moreover have "{a} \<subseteq> S - {b}" using a_not_b a by auto
      moreover have "finite {a}" by auto
      ultimately show ?thesis
        unfolding ideal_def
        by (metis True b_ak ideal_def ideal_generated_in ideal_ideal_generated insert_subset right_ideal_def)
    next
      case False
      then show ?thesis by (simp add: ideal_generated_in x)
    qed
  qed
  show "ideal_generated (S - {b}) \<subseteq> ideal_generated S" by (rule ideal_generated_subset, auto)
qed

lemma ideal_generated_dvd_eq_diff_set:
  assumes i_in_I: "i\<in>I" and i_in_J: "i \<notin> J" and i_dvd_j: "\<forall>j\<in>J. i dvd j"
  and f: "finite J"
  shows "ideal_generated I = ideal_generated (I - J)"
  using f i_in_J i_dvd_j i_in_I
  proof (induct J arbitrary: I)
  case empty
    then show ?case by auto
  next
    case (insert x J)
    have "ideal_generated I = ideal_generated (I-{x})"
      by (rule ideal_generated_dvd_eq[of i], insert insert.prems , auto)
    also have "... = ideal_generated ((I-{x}) - J)"
      by (rule insert.hyps, insert insert.prems insert.hyps, auto)
    also have "... = ideal_generated (I - insert x J)"
      using Diff_insert2[of I x J] by auto
    finally show ?case .
  qed

context comm_ring_1
begin

lemma ideal_generated_singleton_subset:
  assumes d: "d \<in> ideal_generated S" and fin_S: "finite S"
  shows "ideal_generated {d} \<subseteq> ideal_generated S"
proof
  fix x assume x: "x \<in> ideal_generated {d}"
  obtain k where x_kd: "x = k*d " using x using obtain_sum_ideal_generated[OF x]
    by (metis finite.emptyI finite.insertI sum_singleton)
  show "x \<in> ideal_generated S"
    using d ideal_eq_right_ideal ideal_ideal_generated right_ideal_def mult_commute x_kd by auto
qed

lemma ideal_generated_singleton_dvd:
  assumes i: "ideal_generated S = ideal_generated {d}" and x: "x \<in> S"
  shows "d dvd x"
  by (metis i x finite.intros dvd_ideal_generated_singleton
      ideal_generated_in ideal_generated_singleton_subset)

lemma ideal_generated_UNIV_insert:
  assumes "ideal_generated S = UNIV"
  shows "ideal_generated (insert a S) = UNIV" using assms
  using local.ideal_generated_subset by blast

lemma ideal_generated_UNIV_union:
  assumes "ideal_generated S = UNIV"
  shows "ideal_generated (A \<union> S) = UNIV"
  using assms local.ideal_generated_subset
  by (metis UNIV_I Un_subset_iff equalityI subsetI)

lemma ideal_explicit2:
  assumes "finite S"
  shows "ideal_generated S = {y. \<exists>f. (\<Sum>i\<in>S. f i * i) = y}"
  by (smt Collect_cong assms ideal_explicit obtain_sum_ideal_generated mem_Collect_eq subsetI)

lemma ideal_generated_unit:
  assumes u: "u dvd 1"
  shows "ideal_generated {u} = UNIV"
proof -
  have "x \<in> ideal_generated {u}" for x
  proof -
    obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
      using local.mult_ac(2) by blast
    have "x = x * inv_u * u" using inv_u by (simp add: local.mult_ac(1))
    also have "... \<in> {k * u |k. k \<in> UNIV}" by auto
    also have "... = ideal_generated {u}" unfolding ideal_generated_singleton by simp
    finally show ?thesis .
  qed
  thus ?thesis by auto
qed

lemma ideal_generated_dvd_subset:
  assumes x: "\<forall>x \<in> S. d dvd x" and S: "finite S"
  shows "ideal_generated S \<subseteq> ideal_generated {d}"
proof
  fix x assume "x\<in> ideal_generated S"
  from this obtain f where f: "(\<Sum>i\<in>S. f i * i) = x" using ideal_explicit2[OF S] by auto
  have "d dvd (\<Sum>i\<in>S. f i * i)" by (rule dvd_sum, insert x, auto)
  thus "x \<in> ideal_generated {d}"
    using f dvd_ideal_generated_singleton' ideal_generated_in singletonI by blast
qed

lemma ideal_generated_mult_unit:
  assumes f: "finite S" and u: "u dvd 1"
  shows "ideal_generated ((\<lambda>x. u*x)` S) = ideal_generated S"
  using f
proof (induct S)
  case empty
  then show ?case by auto
next
  case (insert x S)
  obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
    using mult_ac by blast
  have f: "finite (insert (u*x) ((\<lambda>x. u*x)` S))" using insert.hyps by auto
  have f2: "finite (insert x S)" by (simp add: insert(1))
  have f3: "finite S" by (simp add: insert)
  have f4: "finite ((*) u ` S)" by (simp add: insert)
  have inj_ux: "inj_on (\<lambda>x. u*x) S" unfolding inj_on_def
    by (auto, metis inv_u local.mult_1_left local.semiring_normalization_rules(18))
  have "ideal_generated ((\<lambda>x. u*x)` (insert x S)) = ideal_generated (insert (u*x) ((\<lambda>x. u*x)` S))"
    by auto
  also have "... = {y. \<exists>f. (\<Sum>i\<in>insert (u*x) ((\<lambda>x. u*x)` S). f i * i) = y}"
    using ideal_explicit2[OF f] by auto
  also have "... = {y. \<exists>f. (\<Sum>i\<in>(insert x S). f i * i) = y}" (is "?L = ?R")
  proof -
    have "a \<in> ?L"  if a: "a \<in> ?R" for a
    proof -
      obtain f where sum_rw: "(\<Sum>i\<in>(insert x S). f i * i) = a" using a by auto
      define b where "b=(\<Sum>i\<in>S. f i * i)"
      have "b \<in> ideal_generated S" unfolding b_def ideal_explicit2[OF f3] by auto
      hence "b \<in> ideal_generated ((*) u ` S)" using insert.hyps(3) by auto
      from this obtain g where "(\<Sum>i\<in>((*) u ` S). g i * i) = b"
        unfolding ideal_explicit2[OF f4] by auto
      hence sum_rw2: "(\<Sum>i\<in>S. f i * i) = (\<Sum>i\<in>((*) u ` S). g i * i)" unfolding b_def by auto
      let ?g = "\<lambda>i. if i = u*x then f x * inv_u else g i"
       have sum_rw3: "sum ((\<lambda>i. g i * i) \<circ> (\<lambda>x. u*x)) S = sum ((\<lambda>i. ?g i * i) \<circ> (\<lambda>x. u*x)) S"
        by (rule sum.cong, auto, metis inv_u local.insert(2) local.mult_1_right
              local.mult_ac(2) local.semiring_normalization_rules(18))
      have sum_rw4: "(\<Sum>i\<in>(\<lambda>x. u*x)` S. g i * i) = sum ((\<lambda>i. g i * i) \<circ> (\<lambda>x. u*x)) S"
        by (rule sum.reindex[OF inj_ux])
      have "a = f x * x + (\<Sum>i\<in>S. f i * i)"
        using sum_rw local.insert(1) local.insert(2) by auto
      also have "... = f x * x + (\<Sum>i\<in>(\<lambda>x. u*x)` S. g i * i)" using sum_rw2 by auto
      also have "... = ?g (u * x) * (u * x) + (\<Sum>i\<in>(\<lambda>x. u*x)` S. g i * i)"
        using inv_u by (smt local.mult_1_right local.mult_ac(1))
      also have "... =  ?g (u * x) * (u * x) + sum ((\<lambda>i. g i * i) \<circ> (\<lambda>x. u*x)) S"
        using sum_rw4 by auto
      also have "... = ((\<lambda>i. ?g i * i) \<circ> (\<lambda>x. u*x)) x + sum ((\<lambda>i. g i * i) \<circ> (\<lambda>x. u*x)) S" by auto
      also have "... = ((\<lambda>i. ?g i * i) \<circ> (\<lambda>x. u*x)) x + sum ((\<lambda>i. ?g i * i) \<circ> (\<lambda>x. u*x)) S"
        using sum_rw3 by auto
      also have "... = sum ((\<lambda>i. ?g i * i) \<circ> (\<lambda>x. u*x)) (insert x S)"
        by (rule sum.insert[symmetric], auto simp add: insert)
      also have "... = (\<Sum>i\<in>insert (u * x) ((\<lambda>x. u*x)` S). ?g i * i)"
        by (smt abel_semigroup.commute f2 image_insert inv_u mult.abel_semigroup_axioms mult_1_right
            semiring_normalization_rules(18) sum.reindex_nontrivial)
      also have "... = (\<Sum>i\<in>(\<lambda>x. u*x)` (insert x S). ?g i * i)" by auto
      finally show ?thesis by auto
    qed
    moreover have "a \<in> ?R" if a: "a \<in> ?L" for a
    proof -
      obtain f where sum_rw: "(\<Sum>i\<in>(insert (u * x) ((*) u ` S)). f i * i) = a" using a by auto
      have ux_notin: "u*x \<notin> ((*) u ` S)"
        by (metis UNIV_I inj_on_image_mem_iff inj_on_inverseI inv_u local.insert(2) local.mult_1_left
            local.semiring_normalization_rules(18) subsetI)
      let ?f = "(\<lambda>x. f x * x)"
      have "sum ?f ((*) u ` S) \<in> ideal_generated ((*) u ` S)"
        unfolding ideal_explicit2[OF f4] by auto
      from this obtain g where sum_rw1: "sum (\<lambda>i. g i * i) S = sum ?f (((*) u ` S))"
        using insert.hyps(3) unfolding ideal_explicit2[OF f3] by blast
      let ?g = "(\<lambda>i. if i = x  then (f (u*x) *u) * x else g i * i)"
      let ?g' = "\<lambda>i. if i = x  then f (u*x) * u else g i"
      have sum_rw2: "sum (\<lambda>i. g i * i) S = sum ?g S" by (rule sum.cong, insert inj_ux ux_notin, auto)
      have "a = (\<Sum>i\<in>(insert (u * x) ((*) u ` S)). f i * i)" using sum_rw by simp
      also have "... = ?f (u*x) +  sum ?f (((*) u ` S))"
        by (rule sum.insert[OF f4], insert inj_ux) (metis UNIV_I inj_on_image_mem_iff inj_on_inverseI
            inv_u local.insert(2) local.mult_1_left local.semiring_normalization_rules(18) subsetI)
      also have "... = ?f (u*x) + sum (\<lambda>i. g i * i) S" unfolding sum_rw1 by auto
      also have "... = ?g x + sum ?g S" unfolding sum_rw2 using mult.assoc by auto
      also have "... = sum ?g (insert x S)" by (rule sum.insert[symmetric, OF f3 insert.hyps(2)])
      also have "... = sum (\<lambda>i. ?g' i * i) (insert x S)" by (rule sum.cong, auto)
      finally show ?thesis by fast
    qed
    ultimately show ?thesis by blast
  qed
  also have "... = ideal_generated (insert x S)" using ideal_explicit2[OF f2] by auto
  finally show ?case by auto
qed

corollary ideal_generated_mult_unit2:
  assumes u: "u dvd 1"
  shows "ideal_generated {u*a,u*b} = ideal_generated {a,b}"
proof -
  let ?S = "{a,b}"
  have "ideal_generated {u*a,u*b} = ideal_generated ((\<lambda>x. u*x)` {a,b})" by auto
  also have "... = ideal_generated {a,b}" by (rule ideal_generated_mult_unit[OF _ u], simp)
  finally show ?thesis .
qed

lemma ideal_generated_1[simp]: "ideal_generated {1} = UNIV"
  by (metis ideal_generated_unit dvd_ideal_generated_singleton order_refl)

lemma ideal_generated_pair: "ideal_generated {a,b} = {p*a+q*b | p q. True}"
proof -
  have i: "ideal_generated {a,b} = {y. \<exists>f. (\<Sum>i\<in>{a,b}. f i * i) = y}" using ideal_explicit2 by auto
  show ?thesis
  proof (cases "a=b")
    case True
    show ?thesis using True i
      by (auto, metis mult_ac(2) semiring_normalization_rules)
      (metis (no_types, opaque_lifting) add_minus_cancel mult_ac ring_distribs semiring_normalization_rules)
  next
    case False
    have 1: "\<exists>p q. (\<Sum>i\<in>{a, b}. f i * i) = p * a + q * b" for f
      by (rule exI[of _ "f a"], rule exI[of _ "f b"], rule sum_two_elements[OF False])
    moreover have "\<exists>f. (\<Sum>i\<in>{a, b}. f i * i) = p * a + q * b" for p q
      by (rule exI[of _ "\<lambda>i. if i=a then p else q"],
          unfold sum_two_elements[OF False], insert False, auto)
    ultimately show ?thesis using i by auto
  qed
qed

lemma ideal_generated_pair_exists_pq1:
  assumes i: "ideal_generated {a,b} = (UNIV::'a set)"
  shows "\<exists>p q. p*a + q*b = 1"
  using i unfolding ideal_generated_pair
  by (smt iso_tuple_UNIV_I mem_Collect_eq)

lemma ideal_generated_pair_UNIV:
  assumes sa_tb_u: "s*a+t*b = u" and u: "u dvd 1"
  shows "ideal_generated {a,b} = UNIV"
proof -
  have f: "finite {a,b}" by simp
  obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
    by (metis mult.commute)
  have "x \<in> ideal_generated {a,b}" for x
  proof (cases "a = b")
    case True
    then show ?thesis
      by (metis UNIV_I dvd_def dvd_ideal_generated_singleton' ideal_generated_unit insert_absorb2
          mult.commute sa_tb_u semiring_normalization_rules(34) subsetI subset_antisym u)
  next
    case False note a_not_b = False
    let ?f = "\<lambda>y. if y = a then inv_u * x * s else inv_u * x * t"
    have "(\<Sum>i\<in>{a,b}. ?f i * i) = ?f a * a + ?f b * b" by (rule sum_two_elements[OF a_not_b])
    also have "... = x" using a_not_b sa_tb_u inv_u
      by (auto, metis mult_ac(1) mult_ac(2) ring_distribs(1) semiring_normalization_rules(12))
    finally show ?thesis unfolding ideal_explicit2[OF f] by auto
  qed
  thus ?thesis by auto
qed

lemma ideal_generated_pair_exists:
  assumes l: "(ideal_generated {a,b} = ideal_generated {d})"
  shows "(\<exists> p q. p*a+q*b = d)"
proof -
  have d: "d \<in> ideal_generated {d}" by (simp add: ideal_generated_in)
  hence "d \<in> ideal_generated {a,b}" using l by auto
  from this obtain p q where "d = p*a+q*b" using ideal_generated_pair[of a b] by auto
  thus ?thesis by auto
qed

lemma obtain_ideal_generated_pair:
  assumes "c \<in> ideal_generated {a,b}"
  obtains p q where "p*a+q*b=c"
proof -
  have "c \<in> {p * a + q * b |p q. True}" using assms ideal_generated_pair by auto
  thus ?thesis using that by auto
qed

lemma ideal_generated_pair_exists_UNIV:
  shows "(ideal_generated {a,b} = ideal_generated {1}) = (\<exists>p q. p*a+q*b = 1)" (is "?lhs = ?rhs")
proof
  assume r: ?rhs
  have "x \<in> ideal_generated {a,b}" for x
  proof (cases "a=b")
    case True
    then show ?thesis
      by (metis UNIV_I r dvd_ideal_generated_singleton finite.intros ideal_generated_1
          ideal_generated_pair_UNIV ideal_generated_singleton_subset)
  next
    case False
    have f: "finite {a,b}" by simp
    have 1: "1 \<in> ideal_generated {a,b}"
      using ideal_generated_pair_UNIV local.one_dvd r by blast
    hence i: "ideal_generated {a,b} = {y. \<exists>f. (\<Sum>i\<in>{a,b}. f i * i) = y}"
      using ideal_explicit2[of "{a,b}"] by auto
    from this obtain f where f: "f a * a + f b * b = 1" using sum_two_elements 1 False by auto
    let ?f = "\<lambda>y. if y = a then x * f a else x * f b"
    have "(\<Sum>i\<in>{a,b}. ?f i * i) = x" unfolding sum_two_elements[OF False] using f False
      using mult_ac(1) ring_distribs(1) semiring_normalization_rules(12) by force
    thus ?thesis unfolding i by auto
  qed
  thus ?lhs by auto
next
  assume ?lhs thus ?rhs using ideal_generated_pair_exists[of a b 1] by auto
qed

corollary ideal_generated_UNIV_obtain_pair:
  assumes "ideal_generated {a,b} = ideal_generated {1}"
  shows " (\<exists>p q. p*a+q*b = d)"
proof -
  obtain x y where "x*a+y*b = 1" using ideal_generated_pair_exists_UNIV assms by auto
  hence "d*x*a+d*y*b=d"
    using local.mult_ac(1) local.ring_distribs(1) local.semiring_normalization_rules(12) by force
  thus ?thesis by auto
qed

lemma sum_three_elements:
  shows "\<exists>x y z::'a. (\<Sum>i\<in>{a,b,c}. f i * i) = x * a + y * b + z * c"
proof (cases "a \<noteq> b \<and> b \<noteq> c \<and> a \<noteq> c")
  case True
  then show ?thesis by (auto, metis add.assoc)
next
  case False
  have 1: "\<exists>x y z. f c * c = x * c + y * c + z * c"
    by (rule exI[of _ 0],rule exI[of _ 0], rule exI[of _ "f c"], auto)
  have 2: "\<exists>x y z. f b * b + f c * c = x * b + y * b + z * c"
    by (rule exI[of _ 0],rule exI[of _ "f b"], rule exI[of _ "f c"], auto)
  have 3: "\<exists>x y z. f a * a + f c * c = x * a + y * c + z * c"
    by (rule exI[of _ "f a"],rule exI[of _ 0], rule exI[of _ "f c"], auto)
  have 4: "\<exists>x y z. (\<Sum>i\<in>{c, b, c}. f i * i) = x * c + y * b + z * c" if a: "a = c" and b: "b \<noteq> c"
    by (rule exI[of _ 0],rule exI[of _ "f b"], rule exI[of _ "f c"], insert a b,
        auto simp add: insert_commute)
  show ?thesis using False
    by (cases "b=c", cases "a=c", auto simp add: 1 2 3 4)
qed

lemma sum_three_elements':
  shows "\<exists>f::'a\<Rightarrow>'a. (\<Sum>i\<in>{a,b,c}. f i * i) = x * a + y * b + z * c"
proof (cases "a \<noteq> b \<and> b \<noteq> c \<and> a \<noteq> c")
  case True
  let ?f = "\<lambda>i. if i = a then x else if i = b then y else if i = c then z else 0"
  show ?thesis by (rule exI[of _ "?f"], insert True mult.assoc, auto simp add: local.add_ac)
next
  case False
  have 1: "\<exists>f. f c * c = x * c + y * c + z * c"
    by (rule exI[of _ "\<lambda>i. if i = c then x+y+z else 0"], auto simp add: local.ring_distribs)
  have 2: "\<exists>f. f a * a + f c * c = x * a + y * c + z * c" if bc: " b = c" and ac: "a \<noteq> c"
    by (rule exI[of _ "\<lambda>i. if i = a then x else y+z"], insert ac bc add_ac ring_distribs, auto)
  have 3: "\<exists>f. f b * b + f c * c = x * b + y * b + z * c" if bc: " b \<noteq> c" and ac: "a = b"
    by (rule exI[of _ "\<lambda>i. if i = a then x+y else z"], insert ac bc add_ac ring_distribs, auto)
  have 4: "\<exists>f. (\<Sum>i\<in>{c, b, c}. f i * i) = x * c + y * b + z * c" if a: "a = c" and b: "b \<noteq> c"
    by (rule exI[of _ "\<lambda>i. if i = c then x+z else y"], insert a b add_ac ring_distribs,
        auto simp add: insert_commute)
  show ?thesis using False
    by (cases "b=c", cases "a=c", auto simp add: 1 2 3 4)
qed

(*This is generalizable to arbitrary sets.*)
lemma ideal_generated_triple_pair_rewrite:
  assumes i1: "ideal_generated {a, b, c} = ideal_generated {d}"
    and i2: "ideal_generated {a, b} = ideal_generated {d'}"
  shows "ideal_generated{d',c} = ideal_generated {d}"
proof
  have d': "d' \<in> ideal_generated {a,b}" using i2 by (simp add: ideal_generated_in)
  show "ideal_generated {d', c} \<subseteq> ideal_generated {d}"
  proof
    fix x assume x: "x \<in> ideal_generated {d', c}"
    obtain f1 f2 where f: "f1*d' + f2*c = x" using obtain_ideal_generated_pair[OF x] by auto
    obtain g1 g2 where g: "g1*a + g2*b = d'" using obtain_ideal_generated_pair[OF d'] by blast
    have 1: "f1*g1*a + f1*g2*b + f2*c = x"
      using f g local.ring_distribs(1) local.semiring_normalization_rules(18) by auto
    have "x \<in> ideal_generated {a, b, c}"
    proof -
      obtain f where "(\<Sum>i\<in>{a,b,c}. f i * i) = f1*g1*a + f1*g2*b + f2*c"
        using sum_three_elements' 1 by blast
      moreover have "ideal_generated {a,b,c} = {y. \<exists>f. (\<Sum>i\<in>{a,b,c}. f i * i) = y}"
        using ideal_explicit2[of "{a,b,c}"] by simp
      ultimately show ?thesis using 1 by auto
    qed
    thus "x \<in> ideal_generated {d}" using i1 by auto
  qed
  show "ideal_generated {d} \<subseteq> ideal_generated {d', c}"
  proof (rule ideal_generated_singleton_subset)
    obtain f1 f2 f3 where f: "f1*a + f2*b + f3*c = d"
    proof -
      have "d \<in> ideal_generated {a,b,c}" using i1  by (simp add: ideal_generated_in)
      from this obtain f where d: "(\<Sum>i\<in>{a,b,c}. f i * i) = d"
        using ideal_explicit2[of "{a,b,c}"] by auto
      obtain x y z where "(\<Sum>i\<in>{a,b,c}. f i * i) = x * a + y * b + z * c"
        using sum_three_elements by blast
      thus ?thesis using d that by auto
    qed
    obtain k where k: "f1*a + f2*b = k*d'"
    proof -
      have "f1*a + f2*b \<in> ideal_generated{a,b}" using ideal_generated_pair by blast
      also have "... = ideal_generated {d'}" using i2 by simp
      also have "... = {k*d' |k. k\<in>UNIV}" using ideal_generated_singleton by auto
      finally show ?thesis using that by auto
    qed
    have "k*d'+f3*c=d" using f k by auto
    thus "d \<in> ideal_generated {d', c}"
      using ideal_generated_pair by blast
  qed (simp)
qed

lemma ideal_generated_dvd:
  assumes i: "ideal_generated {a,b::'a} = ideal_generated{d} "
  and a: "d' dvd a" and b: "d' dvd b"
shows "d' dvd d"
proof -
  obtain p q where "p*a+q*b = d"
    using i ideal_generated_pair_exists by blast
  thus ?thesis using a b by auto
qed

lemma ideal_generated_dvd2:
  assumes i: "ideal_generated S = ideal_generated{d::'a} "
  and "finite S"
  and x: "\<forall>x\<in>S. d' dvd x"
shows "d' dvd d"
  by (metis assms dvd_ideal_generated_singleton ideal_generated_dvd_subset)

end

subsection \<open>An equivalent characterization of B\'ezout rings\<close>

text \<open>The goal of this subsection is to prove that a ring is B\'ezout ring if and only if every
  finitely generated ideal is principal.\<close>

definition "finitely_generated_ideal I = (ideal I \<and> (\<exists>S. finite S \<and> ideal_generated S = I))"

context
  assumes "SORT_CONSTRAINT('a::comm_ring_1)"
begin

lemma sum_two_elements':
  fixes d::'a
  assumes s: "(\<Sum>i\<in>{a,b}. f i * i) = d"
  obtains p and q where "d = p * a + q * b"
proof (cases "a=b")
  case True
  then show ?thesis
    by (metis (no_types, lifting) add_diff_cancel_left' emptyE finite.emptyI insert_absorb2
        left_diff_distrib' s sum.insert sum_singleton that)
next
  case False
  show ?thesis using s unfolding sum_two_elements[OF False]
    using that by auto
qed

text \<open>This proof follows Theorem 6-3 in "First Course in Rings and Ideals" by Burton\<close>

lemma all_fin_gen_ideals_are_principal_imp_bezout:
  assumes all: "\<forall>I::'a set. finitely_generated_ideal I \<longrightarrow> principal_ideal I"
  shows "OFCLASS ('a, bezout_ring_class)"
proof (intro_classes)
  fix a b::'a
  obtain d where ideal_d: "ideal_generated {a,b} = ideal_generated {d}"
    using all unfolding finitely_generated_ideal_def
    by (metis finite.emptyI finite_insert ideal_ideal_generated principal_ideal_def)
  have a_in_d: "a \<in> ideal_generated {d}"
    using ideal_d ideal_generated_subset_generator by blast
  have b_in_d: "b \<in> ideal_generated {d}"
    using ideal_d ideal_generated_subset_generator by blast
  have d_in_ab: "d \<in> ideal_generated {a,b}"
    using ideal_d ideal_generated_subset_generator by auto
  obtain f where "(\<Sum>i\<in>{a,b}. f i * i) = d" using obtain_sum_ideal_generated[OF d_in_ab] by auto
  from this obtain p q where d_eq: "d = p*a + q*b" using sum_two_elements' by blast
  moreover have d_dvd_a: "d dvd a"
    by (metis dvd_ideal_generated_singleton ideal_d ideal_generated_subset insert_commute
        subset_insertI)
  moreover have "d dvd b"
    by (metis dvd_ideal_generated_singleton ideal_d ideal_generated_subset subset_insertI)
  moreover have "d' dvd d" if d'_dvd: "d' dvd a \<and> d' dvd b" for d'
  proof -
    obtain s1 s2 where s1_dvd: "a = s1*d'" and s2_dvd: "b = s2*d'"
      using mult.commute d'_dvd unfolding dvd_def by auto
    have "d = p*a + q*b" using d_eq .
    also have "...= p * s1 * d' + q * s2 *d'" unfolding s1_dvd s2_dvd by auto
    also have "... = (p * s1 + q * s2) * d'" by (simp add: ring_class.ring_distribs(2))
    finally show "d' dvd d" using mult.commute unfolding dvd_def by auto
  qed
  ultimately show "\<exists>p q d. p * a + q * b = d \<and> d dvd a \<and> d dvd b
  \<and> (\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd d)" by auto
qed
end

context bezout_ring
begin

lemma exists_bezout_extended:
  assumes S: "finite S" and ne: "S \<noteq> {}"
  shows "\<exists>f d. (\<Sum>a\<in>S. f a * a) = d \<and> (\<forall>a\<in>S. d dvd a) \<and> (\<forall>d'. (\<forall>a\<in>S. d' dvd a) \<longrightarrow> d' dvd d)"
  using S ne
proof (induct S)
  case empty
  then show ?case by auto
next
  case (insert x S)
  show ?case
  proof (cases  "S={}")
    case True
    let ?f = "\<lambda>x. 1"
    show ?thesis by (rule exI[of _ ?f], insert True, auto)
  next
    case False note ne = False
    note x_notin_S = insert.hyps(2)
    obtain f d where sum_eq_d: "(\<Sum>a\<in>S. f a * a) = d"
      and d_dvd_each_a: "(\<forall>a\<in>S. d dvd a)"
      and d_is_gcd: "(\<forall>d'. (\<forall>a\<in>S. d' dvd a) \<longrightarrow> d' dvd d)"
      using insert.hyps(3)[OF ne] by auto
    have "\<exists>p q d'. p * d + q * x = d' \<and> d' dvd d \<and> d' dvd x \<and> (\<forall>c. c dvd d \<and> c dvd x \<longrightarrow> c dvd d')"
      using exists_bezout by auto
    from this obtain p q d' where pd_qx_d': "p*d + q*x = d'"
      and d'_dvd_d: "d' dvd d" and d'_dvd_x: "d' dvd x"
      and d'_dvd: "\<forall>c. (c dvd d \<and> c dvd x) \<longrightarrow> c dvd d'" by blast
    let ?f = "\<lambda>a. if a = x then q else p * f a"
    have "(\<Sum>a\<in>insert x S. ?f a * a) = d'"
    proof -
      have "(\<Sum>a\<in>insert x S. ?f a * a) = (\<Sum>a\<in>S. ?f a * a) + ?f x * x"
        by (simp add: add_commute insert.hyps(1) insert.hyps(2))
      also have "... = p * (\<Sum>a\<in>S. f a * a) + q * x"
        unfolding sum_distrib_left
        by (auto, rule sum.cong, insert x_notin_S,
            auto simp add: mult.semigroup_axioms semigroup.assoc)
      finally show ?thesis using pd_qx_d' sum_eq_d by auto
    qed
    moreover have "(\<forall>a\<in>insert x S. d' dvd a)"
      by (metis d'_dvd_d d'_dvd_x d_dvd_each_a insert_iff local.dvdE local.dvd_mult_left)
    moreover have " (\<forall>c. (\<forall>a\<in>insert x S. c dvd a) \<longrightarrow> c dvd d')"
      by (simp add: d'_dvd d_is_gcd)
    ultimately show ?thesis by auto
  qed
qed

end

lemma ideal_generated_empty: "ideal_generated {} = {0}"
  unfolding ideal_generated_def using ideal_generated_0
  by (metis empty_subsetI ideal_generated_def ideal_generated_subset ideal_ideal_generated
      ideal_not_empty subset_singletonD)

lemma bezout_imp_all_fin_gen_ideals_are_principal:
  fixes I::"'a :: bezout_ring set"
  assumes fin: "finitely_generated_ideal I"
  shows "principal_ideal I"
proof -
  obtain S where fin_S: "finite S" and ideal_gen_S: "ideal_generated S = I"
    using fin unfolding finitely_generated_ideal_def by auto
  show ?thesis
  proof (cases "S = {}")
    case True
    then show ?thesis
      using ideal_gen_S unfolding True
      using ideal_generated_empty ideal_generated_0 principal_ideal_def by fastforce
  next
    case False note ne = False
    obtain d f where sum_S_d: "(\<Sum>i\<in>S. f i * i) = d"
    and d_dvd_a: "(\<forall>a\<in>S. d dvd a)" and d_is_gcd: "(\<forall>d'. (\<forall>a\<in>S. d' dvd a) \<longrightarrow> d' dvd d)"
      using exists_bezout_extended[OF fin_S ne] by auto
    have d_in_S: "d \<in> ideal_generated S"
      by (metis fin_S ideal_def ideal_generated_subset_generator
          ideal_ideal_generated sum_S_d sum_left_ideal)
    have "ideal_generated {d} \<subseteq> ideal_generated S"
      by (rule ideal_generated_singleton_subset[OF d_in_S fin_S])
    moreover have "ideal_generated S \<subseteq> ideal_generated {d}"
    proof
      fix x assume x_in_S: "x \<in> ideal_generated S"
      obtain f where sum_S_x: "(\<Sum>a\<in>S. f a * a) = x"
        using fin_S obtain_sum_ideal_generated x_in_S by blast
      have d_dvd_each_a: "\<exists>k. a = k * d" if "a \<in> S" for a
        by (metis d_dvd_a dvdE mult.commute that)
      let ?g = "\<lambda>a. SOME k. a = k*d"
      have "x = (\<Sum>a\<in>S. f a * a)" using sum_S_x by simp
      also have "... = (\<Sum>a\<in>S. f a * (?g a * d))"
      proof (rule sum.cong)
        fix a assume a_in_S: "a \<in> S"
        obtain k where a_kd: "a = k * d" using d_dvd_each_a a_in_S by auto
        have "a = ((SOME k. a = k * d) * d)" by (rule someI_ex, auto simp add: a_kd)
        thus "f a * a = f a * ((SOME k. a = k * d) * d)" by auto
      qed (simp)
      also have "... = (\<Sum>a\<in>S. f a * ?g a * d)" by (rule sum.cong, auto)
      also have "... = (\<Sum>a\<in>S. f a * ?g a)*d" using sum_distrib_right[of _ S d] by auto
      finally show "x \<in> ideal_generated {d}"
        by (meson contra_subsetD dvd_ideal_generated_singleton' dvd_triv_right
            ideal_generated_in singletonI)
    qed
    ultimately show ?thesis unfolding principal_ideal_def using ideal_gen_S by auto
  qed
qed

text \<open>Now we have the required lemmas to prove the theorem that states that
  a ring is B\'ezout ring if and only if every
  finitely generated ideal is principal. They are the following ones.

\begin{itemize}
\item @{text "all_fin_gen_ideals_are_principal_imp_bezout"}
\item @{text "bezout_imp_all_fin_gen_ideals_are_principal"}
\end{itemize}

However, in order to prove the final lemma, we need the lemmas with no type restrictions.
For instance, we need a version of theorem @{text "bezout_imp_all_fin_gen_ideals_are_principal"}
as

@{text "OFCLASS('a,bezout_ring) \<Longrightarrow>"} the theorem with generic types
  (i.e., @{text "'a"} with no type restrictions)

or as

@{text "class.bezout_ring _ _ _ _ \<Longrightarrow>"} the theorem with generic
  types (i.e., @{text "'a"} with no type restrictions)
\<close>

(*A possible workaround is to adapt the proof*)
(*
lemma bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory:
  assumes a1: "class.bezout_ring ( * ) (1::'a::comm_ring_1) (+) 0 (-) uminus" (*Me da igual esto que OFCLASS*)
  shows "\<forall>I::'a set. finitely_generated_ideal I \<longrightarrow> principal_ideal I"
proof (rule allI, rule impI)
  fix I::"'a set" assume fin: "finitely_generated_ideal I"
  interpret a: bezout_ring "( * )" "(1::'a)" "(+)" 0 "(-)" uminus using a1 .
  interpret dvd "( * )::'a\<Rightarrow>'a\<Rightarrow>'a" .
  interpret b: comm_monoid_add "(+)" "(0::'a)" using a1 by intro_locales
  have c: " class.comm_monoid_add (+) (0::'a)"  using a1 by intro_locales
  have [simp]: "(dvd.dvd ( * ) d a) = (d dvd a)" for d a::'a
    by (auto simp add: dvd.dvd_def dvd_def)
  have [simp]: "comm_monoid_add.sum (+) 0 (\<lambda>a. f a * a) S = sum (\<lambda>a. f a * a) S"
    for f and S::"'a set"
    unfolding sum_def unfolding comm_monoid_add.sum_def[OF c] ..
  obtain S where fin_S: "finite S" and ideal_gen_S: "ideal_generated S = I"
    using fin unfolding finitely_generated_ideal_def by auto
  show "principal_ideal I"
  proof (cases "S = {}")
    case True
    then show ?thesis
      using ideal_gen_S unfolding True
      using ideal_generated_empty ideal_generated_0 principal_ideal_def by fastforce
  next
    case False note ne = False
    obtain d f where sum_S_d: "(\<Sum>i\<in>S. f i * i) = d"
    and d_dvd_a: "(\<forall>a\<in>S. d dvd a)" and d_is_gcd: "(\<forall>d'. (\<forall>a\<in>S. d' dvd a) \<longrightarrow> d' dvd d)"
      using a.exists_bezout_extended[OF fin_S ne] by auto
    have d_in_S: "d \<in> ideal_generated S"
      by (metis fin_S ideal_def ideal_generated_subset_generator
          ideal_ideal_generated sum_S_d sum_left_ideal)
    have "ideal_generated {d} \<subseteq> ideal_generated S"
      by (rule ideal_generated_singleton_subset[OF d_in_S fin_S])
    moreover have "ideal_generated S \<subseteq> ideal_generated {d}"
    proof
      fix x assume x_in_S: "x \<in> ideal_generated S"
      obtain f where sum_S_x: "(\<Sum>a\<in>S. f a * a) = x"
        using fin_S obtain_sum_ideal_generated x_in_S by blast
      have d_dvd_each_a: "\<exists>k. a = k * d" if "a \<in> S" for a
        by (metis d_dvd_a dvdE mult.commute that)
      let ?g = "\<lambda>a. SOME k. a = k*d"
      have "x = (\<Sum>a\<in>S. f a * a)" using sum_S_x by simp
      also have "... = (\<Sum>a\<in>S. f a * (?g a * d))"
      proof (rule sum.cong)
        fix a assume a_in_S: "a \<in> S"
        obtain k where a_kd: "a = k * d" using d_dvd_each_a a_in_S by auto
        have "a = ((SOME k. a = k * d) * d)" by (rule someI_ex, auto simp add: a_kd)
        thus "f a * a = f a * ((SOME k. a = k * d) * d)" by auto
      qed (simp)
      also have "... = (\<Sum>a\<in>S. f a * ?g a * d)" by (rule sum.cong, auto)
      also have "... = (\<Sum>a\<in>S. f a * ?g a)*d" using sum_distrib_right[of _ S d] by auto
      finally show "x \<in> ideal_generated {d}"
        by (meson contra_subsetD dvd_ideal_generated_singleton' dvd_triv_right
            ideal_generated_in singletonI)
    qed
    ultimately show ?thesis unfolding principal_ideal_def using ideal_gen_S by auto
  qed
qed
*)

text \<open>Thanks to local type definitions, we can obtain it automatically by means
  of @{text "internalize-sort"}.\<close>

lemma bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory:
  assumes a1: "class.bezout_ring (*) (1::'b::comm_ring_1) (+) 0 (-) uminus" (*It is algo possible to prove it using OFCLASS*)
  shows "\<forall>I::'b set. finitely_generated_ideal I \<longrightarrow> principal_ideal I"
  using bezout_imp_all_fin_gen_ideals_are_principal[internalize_sort "'a::bezout_ring"]
  using a1 by auto

text \<open>The standard library does not connect @{text "OFCLASS"} and @{text "class.bezout_ring"}
in both directions. Here we show that @{text "OFCLASS \<Longrightarrow> class.bezout_ring"}. \<close>

lemma OFCLASS_bezout_ring_imp_class_bezout_ring:
  assumes "OFCLASS('a::comm_ring_1,bezout_ring_class)"
  shows "class.bezout_ring ((*)::'a\<Rightarrow>'a\<Rightarrow>'a) 1 (+) 0 (-) uminus"
  using assms
  unfolding bezout_ring_class_def class.bezout_ring_def
  using conjunctionD2[of "OFCLASS('a, comm_ring_1_class)"
                         "class.bezout_ring_axioms ((*)::'a\<Rightarrow>'a\<Rightarrow>'a) (+)"]
  by (auto, intro_locales)

text \<open>The other implication can be obtained
  by thm @{text "Rings2.class.Rings2.bezout_ring.of_class.intro"} \<close>
thm Rings2.class.Rings2.bezout_ring.of_class.intro

(*OFCLASS is a proposition (Prop), and then the following statement is not valid.*)

(*
lemma
  shows "(\<forall>I::'a::comm_ring_1 set. finitely_generated_ideal I \<longrightarrow> principal_ideal I)
    = OFCLASS('a, bezout_ring_class)"
*)

(*Thus, we use the meta-equality and the meta universal quantifier.*)
text \<open>Final theorem (with OFCLASS)\<close>
lemma bezout_ring_iff_fin_gen_principal_ideal:
    "(\<And>I::'a::comm_ring_1 set. finitely_generated_ideal I \<Longrightarrow> principal_ideal I)
    \<equiv> OFCLASS('a, bezout_ring_class)"
proof
  show "(\<And>I::'a::comm_ring_1 set. finitely_generated_ideal I \<Longrightarrow> principal_ideal I)
    \<Longrightarrow> OFCLASS('a, bezout_ring_class)"
    using all_fin_gen_ideals_are_principal_imp_bezout [where ?'a='a] by auto
  show "\<And>I::'a::comm_ring_1 set. OFCLASS('a, bezout_ring_class)
    \<Longrightarrow> finitely_generated_ideal I \<Longrightarrow> principal_ideal I"
    using bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory[where ?'b='a]
    using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a] by auto
qed

text \<open>Final theorem (with @{text "class.bezout_ring"})\<close>

lemma bezout_ring_iff_fin_gen_principal_ideal2:
    "(\<forall>I::'a::comm_ring_1 set. finitely_generated_ideal I \<longrightarrow> principal_ideal I)
    = (class.bezout_ring ((*)::'a\<Rightarrow>'a\<Rightarrow>'a) 1 (+) 0 (-) uminus)"
proof
  show "\<forall>I::'a::comm_ring_1 set. finitely_generated_ideal I \<longrightarrow> principal_ideal I
      \<Longrightarrow> class.bezout_ring (*) 1 (+) (0::'a) (-) uminus"
    using all_fin_gen_ideals_are_principal_imp_bezout[where ?'a='a]
    using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a]
    by auto
  show "class.bezout_ring (*) 1 (+) (0::'a) (-) uminus \<Longrightarrow> \<forall>I::'a set.
    finitely_generated_ideal I \<longrightarrow> principal_ideal I"
    using bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory by auto
qed

end


theory BDD_subtype_defs
  imports Main BDD_basic BDD_select
begin

datatype Relatedness = Subtype | Disjoint | MayIntersect

type_synonym TR = "nat \<Rightarrow> nat \<Rightarrow> Relatedness"

fun well_formed_tr3 :: "TR \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "well_formed_tr3 tr i j 0 =
    ((tr j i = Subtype \<longrightarrow> tr 0 j = Subtype \<longrightarrow> tr 0 i = Subtype) \<and>
     (tr j i = Subtype \<longrightarrow> tr 0 j = MayIntersect \<longrightarrow> tr 0 i \<noteq> Disjoint) \<and>
     (tr j i = Disjoint \<longrightarrow> tr 0 j = Subtype \<longrightarrow> tr 0 i = Disjoint) \<and>
     (tr j i = Disjoint \<longrightarrow> tr 0 j = MayIntersect \<longrightarrow> tr 0 i \<noteq> Subtype))" |
  "well_formed_tr3 tr i j k =
    ((tr j i = Subtype \<longrightarrow> tr k j = Subtype \<longrightarrow> tr k i = Subtype) \<and>
     (tr j i = Subtype \<longrightarrow> tr k j = MayIntersect \<longrightarrow> tr k i \<noteq> Disjoint) \<and>
     (tr j i = Disjoint \<longrightarrow> tr k j = Subtype \<longrightarrow> tr k i = Disjoint) \<and>
     (tr j i = Disjoint \<longrightarrow> tr k j = MayIntersect \<longrightarrow> tr k i \<noteq> Subtype) \<and>
     well_formed_tr3 tr i j (k-1))"

fun well_formed_tr2 :: "TR \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "well_formed_tr2 tr i 0 = ((tr i 0 = tr 0 i) \<and> well_formed_tr3 tr i 0 0)" |
  "well_formed_tr2 tr i j = ((tr i j = tr j i) \<and> well_formed_tr3 tr i j j \<and> well_formed_tr2 tr i (j-1))"

fun well_formed_tr :: "nat \<Rightarrow> TR \<Rightarrow> bool" where
  "well_formed_tr 0 tr = (tr 0 0 = Subtype)" |
  "well_formed_tr i tr = (tr i i = Subtype \<and> well_formed_tr2 tr i i \<and> well_formed_tr (i-1) tr)"

fun test_tr :: TR where
  "test_tr a b = (
     if a = b then Subtype
     else
       let aa = max a b in
       let bb = min a b in
       if bb = 0 then MayIntersect
       else let g = gcd aa bb in
            if g = 1 then Disjoint
            else if g = bb then Subtype
            else MayIntersect)"

lemma wftr_weaken: "well_formed_tr n tr \<Longrightarrow> m \<le> n \<Longrightarrow> well_formed_tr m tr"
  apply (induction n arbitrary: m)
  apply clarsimp
  apply (case_tac "m = Suc n")
  by auto

lemma wftr2_weaken: "well_formed_tr2 tr i j \<Longrightarrow> jj \<le> j \<Longrightarrow> well_formed_tr2 tr i jj"
  apply (induction j arbitrary: i jj)
  apply clarsimp
  apply (case_tac "jj = Suc j")
  by auto

lemma wftr3_weaken: "well_formed_tr3 tr i j k \<Longrightarrow> kk \<le> k \<Longrightarrow> well_formed_tr3 tr i j kk"
  apply (induction k arbitrary: i j kk)
  apply clarsimp
  apply (case_tac "kk = Suc k")
  by auto

lemma wftr_wftr2: "well_formed_tr i tr \<Longrightarrow> j \<le> i \<Longrightarrow> well_formed_tr2 tr i j"
  apply (case_tac i)
  apply clarsimp
  by (meson Suc_le_eq well_formed_tr.simps(2) wftr2_weaken wftr_weaken)

lemma wftr2_wftr3: "well_formed_tr2 tr i j \<Longrightarrow> j \<le> i \<Longrightarrow> k \<le> j \<Longrightarrow> well_formed_tr3 tr i j k"
  apply (case_tac j)
  apply clarsimp
  by (meson well_formed_tr2.simps(2) wftr3_weaken)

lemma wftr_wftr3: "well_formed_tr i tr \<Longrightarrow> j \<le> i \<Longrightarrow> k \<le> j \<Longrightarrow> well_formed_tr3 tr i j k"
  by (meson wftr2_wftr3 wftr_wftr2)

lemma wftr_symm: "well_formed_tr n tr \<Longrightarrow> tr n n = Subtype"
  apply (induction n)
  by auto

lemma wftr_refl0: "well_formed_tr a tr \<Longrightarrow> b \<le> a \<Longrightarrow> tr a b = tr b a"
  apply (induction a)
  apply clarsimp
  apply clarsimp
  by (metis (no_types, lifting) le_0_eq le_SucE well_formed_tr2.simps(1) well_formed_tr2.simps(2) wftr2_weaken zero_induct)

lemma wftr3_trans: "well_formed_tr3 tr i j k \<Longrightarrow> j \<le> i \<Longrightarrow> k \<le> j \<Longrightarrow> tr j i = Subtype \<Longrightarrow> tr k j = Subtype \<Longrightarrow> tr k i = Subtype"
  apply (induction k)
  by auto

lemma wftr_trans: "well_formed_tr (Suc i) tr \<Longrightarrow> j \<le> i \<Longrightarrow> k \<le> j \<Longrightarrow> tr j i = Subtype \<Longrightarrow> tr k j = Subtype \<Longrightarrow> tr k i = Subtype"
  by (metis diff_Suc_1 well_formed_tr.simps(2) wftr3_trans wftr_wftr3)

lemma wftr3_sub_disj:
    "well_formed_tr3 tr i j k \<Longrightarrow> j \<le> i \<Longrightarrow> k \<le> i \<Longrightarrow>
     tr j i = Subtype \<Longrightarrow> tr k i = Disjoint \<Longrightarrow> tr k j = Disjoint"
  apply (induction k)
  using Relatedness.exhaust by auto

lemma wftr_sub_disj: "well_formed_tr n tr \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> i \<Longrightarrow> k \<le> n \<Longrightarrow> tr j i = Subtype \<Longrightarrow> tr k i = Disjoint \<Longrightarrow> tr k j = Disjoint"
  apply (case_tac "k \<le> i")
  apply (smt (verit, ccfv_SIG) Relatedness.exhaust bot_nat_0.extremum_uniqueI le_SucE linear well_formed_tr3.simps(1) well_formed_tr3.simps(2) wftr_refl0 wftr_weaken wftr_wftr3 zero_induct)
  by (smt (verit, best) linear well_formed_tr.elims(1) well_formed_tr3.simps(1) well_formed_tr3.simps(2) wftr_refl0 wftr_weaken wftr_wftr3)

inductive sub_free :: "nat \<Rightarrow> TR \<Rightarrow> BDD \<Rightarrow> bool" where
  sub_free_sel: "tr i n \<noteq> Subtype \<Longrightarrow> sub_free n tr t \<Longrightarrow> sub_free n tr e \<Longrightarrow> sub_free n tr (Select i t e)" |
  sub_free_top: "sub_free n tr Top" | sub_free_nothing: "sub_free n tr Nothing"

declare sub_free.intros[simp, intro]

inductive disj_free :: "nat \<Rightarrow> TR \<Rightarrow> BDD \<Rightarrow> bool" where
  disj_free_sel: "tr i n \<noteq> Disjoint \<Longrightarrow> disj_free n tr t \<Longrightarrow> disj_free n tr e \<Longrightarrow> disj_free n tr (Select i t e)" |
  disj_free_top: "disj_free n tr Top" | disj_free_nothing: "disj_free n tr Nothing"

declare disj_free.intros[simp, intro]

lemma select_sf_preserve: "sub_free n tr t \<Longrightarrow> sub_free n tr e \<Longrightarrow> tr i n \<noteq> Subtype \<Longrightarrow> sub_free n tr (select i t e)"
  using select_def by simp

lemma select_df_preserve: "disj_free n tr t \<Longrightarrow> disj_free n tr e \<Longrightarrow> tr i n \<noteq> Disjoint \<Longrightarrow> disj_free n tr (select i t e)"
  using select_def by simp

fun erase_subtypes :: "nat \<Rightarrow> TR \<Rightarrow> BDD \<Rightarrow> BDD" where
  "erase_subtypes n tr (Select i t e) =
     (if tr i n = Subtype then
        erase_subtypes n tr e
      else
        select i (erase_subtypes n tr t) (erase_subtypes n tr e))" |
  "erase_subtypes n tr leaf = leaf"

fun erase_disjoints :: "nat \<Rightarrow> TR \<Rightarrow> BDD \<Rightarrow> BDD" where
  "erase_disjoints n tr (Select i t e) =
     (if tr i n = Disjoint then
        erase_disjoints n tr e
      else
        select i (erase_disjoints n tr t) (erase_disjoints n tr e))" |
  "erase_disjoints n tr leaf = leaf"

lemma erase_subtypes_sub_free: "sub_free n tr (erase_subtypes n tr a)"
  apply (induction a)
  by (simp_all add: select_def)

lemma erase_subtypes_sf_preserve: "sub_free n tr a \<Longrightarrow> sub_free n tr (erase_subtypes m tr a)"
  apply (induction a)
  apply (auto simp add: select_def)
  using sub_free.cases apply auto[1]
  using sub_free.cases apply auto[1]
  apply (rule sub_free_sel)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) sub_free.cases)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) sub_free.cases)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) sub_free.cases)
  done

lemma erase_subtypes_sf_noop: "norm n a \<Longrightarrow> sub_free n tr a \<Longrightarrow> erase_subtypes n tr a = a"
  apply (induction a)
  apply (auto simp add: select_def)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) norm.cases norm_widen sub_free.simps)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) sub_free.simps)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) norm.cases norm_widen sub_free.simps)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) norm.cases norm_widen sub_free.simps)
  done

lemma erase_subtypes_df_preserve: "disj_free n tr a \<Longrightarrow> disj_free n tr (erase_subtypes m tr a)"
  apply (induction a)
  apply (auto simp add: select_def)
  using disj_free.cases apply auto[1]
  using disj_free.cases apply auto[1]
  apply (rule disj_free_sel)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) disj_free.cases)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) disj_free.cases)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) disj_free.cases)
  done

lemma erase_disj_disj_free: "disj_free n tr (erase_disjoints n tr a)"
  apply (induction a)
  by (simp_all add: select_def)

lemma erase_disj_sf_preserve: "sub_free n tr a \<Longrightarrow> sub_free n tr (erase_disjoints m tr a)"
  apply (induction a)
  apply (auto simp add: select_def)
  using sub_free.cases apply auto[1]
  using sub_free.cases apply auto[1]
  apply (rule sub_free_sel)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) sub_free.cases)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) sub_free.cases)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) sub_free.cases)
  done

lemma erase_disj_df_preserve: "disj_free n tr a \<Longrightarrow> disj_free n tr (erase_disjoints m tr a)"
  apply (induction a)
  apply (auto simp add: select_def)
  using disj_free.cases apply auto[1]
  using disj_free.cases apply auto[1]
  apply (rule disj_free_sel)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) disj_free.cases)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) disj_free.cases)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) disj_free.cases)
  done

lemma erase_disj_df_noop: "norm n a \<Longrightarrow> disj_free n tr a \<Longrightarrow> erase_disjoints n tr a = a"
  apply (induction a)
  apply (auto simp add: select_def)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) disj_free.simps norm.cases norm_widen)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) disj_free.simps)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) disj_free.simps norm.cases norm_widen)
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) disj_free.simps norm.cases norm_widen)
  done

definition select' :: "nat \<Rightarrow> BDD option \<Rightarrow> BDD option \<Rightarrow> BDD option" where
  "select' i t e = (case (t, e) of (Some t, Some e) \<Rightarrow> Some (select i t e) | _ \<Rightarrow> None)"

inductive sub_free_opt:: "nat \<Rightarrow> TR \<Rightarrow> BDD option \<Rightarrow> bool" where
  sub_free_none[simp, intro]: "sub_free_opt n tr None" |
  sub_free_some[simp, intro]: "sub_free n tr s \<Longrightarrow> sub_free_opt n tr (Some s)"

lemma select'_sf_preserve: "sub_free_opt n tr t \<Longrightarrow> sub_free_opt n tr e \<Longrightarrow> tr i n \<noteq> Subtype \<Longrightarrow> sub_free_opt n tr (select' i t e)"
  apply (auto simp add: select'_def split: option.splits)
  by (metis option.discI option.inject select_sf_preserve sub_free_opt.simps)

inductive disj_free_opt:: "nat \<Rightarrow> TR \<Rightarrow> BDD option \<Rightarrow> bool" where
  disj_free_none[simp, intro]: "disj_free_opt n tr None" |
  disj_free_some[simp, intro]: "disj_free n tr s \<Longrightarrow> disj_free_opt n tr (Some s)"

lemma select'_df_preserve: "disj_free_opt n tr t \<Longrightarrow> disj_free_opt n tr e \<Longrightarrow> tr i n \<noteq> Disjoint \<Longrightarrow> disj_free_opt n tr (select' i t e)"
  apply (auto simp add: select'_def split: option.splits)
  by (metis option.discI option.inject select_df_preserve disj_free_opt.simps)

fun common:: "nat \<Rightarrow> nat \<Rightarrow> TR \<Rightarrow> BDD \<Rightarrow> BDD \<Rightarrow> BDD option" where
  "common _ c tr Top Nothing = None" |
  "common _ c tr Nothing Top = None" |
  "common _ c tr Top Top = Some Top" |
  "common _ c tr Nothing Nothing = Some Nothing" |
  "common n c tr (Select it tt et) (Select ie te ee) =
     (if n \<le> it \<or> n \<le> ie then
        None
      else if it > ie then
        (case tr it c of
           Subtype \<Rightarrow> select' it (Some tt) (common it c tr et (Select ie te ee)) |
           _ \<Rightarrow> select' it (common it c tr tt (erase_disjoints it tr (Select ie te ee)))
                           (common it c tr et (erase_subtypes it tr (Select ie te ee))))
      else if it = ie then
        select' it (common it c tr tt te) (common it c tr et ee)
      else
        (case tr ie c of
           Disjoint \<Rightarrow> select' ie (Some te) (common ie c tr (Select it tt et) ee) |
           _ \<Rightarrow> select' ie (common ie c tr (erase_disjoints ie tr (Select it tt et)) te)
                           (common ie c tr (erase_subtypes ie tr (Select it tt et)) ee)))" |
  "common n c tr (Select it tt et) e =
     (if n \<le> it then
        None
      else
        (case tr it c of
           Subtype \<Rightarrow> select' it (Some tt) (common it c tr et e) |
           _ \<Rightarrow> select' it (common it c tr tt (erase_disjoints it tr e))
                           (common it c tr et (erase_subtypes it tr e))))" |
  "common n c tr t (Select ie te ee) =
     (if n \<le> ie then
        None
      else
        (case tr ie c of
           Disjoint \<Rightarrow> select' ie (Some te) (common ie c tr t ee) |
           _ \<Rightarrow> select' ie (common ie c tr (erase_disjoints ie tr t) te)
                           (common ie c tr (erase_subtypes ie tr t) ee)))"

inductive pwfbdd :: "nat \<Rightarrow> TR \<Rightarrow> BDD \<Rightarrow> bool" where
  pwfbdd_sel[simp]: "n > i \<Longrightarrow> t \<noteq> e \<Longrightarrow>
               sub_free i tr e \<Longrightarrow> disj_free i tr t \<Longrightarrow>
               pwfbdd i tr t \<Longrightarrow> pwfbdd i tr e \<Longrightarrow>
               pwfbdd n tr (Select i t e)" |
  pwfbdd_top[simp]: "pwfbdd n tr Top" | pwfbdd_nothing[simp]: "pwfbdd n tr Nothing"

lemma pwf_is_norm: "pwfbdd n tr b \<Longrightarrow> norm n b"
  by (induction n tr b rule: pwfbdd.induct) auto

lemma pwf_weaken: "pwfbdd n tr b \<Longrightarrow> m \<ge> n \<Longrightarrow> pwfbdd m tr b"
  by (induction n tr b arbitrary: m rule: pwfbdd.induct) auto

theorem erase_subtypes_pwf[simp]: "pwfbdd n tr b \<Longrightarrow> i \<ge> n \<Longrightarrow> pwfbdd n tr (erase_subtypes i tr b)"
  apply (induction n tr b rule: pwfbdd.induct)
  apply (auto simp add: select_def)
  apply (meson less_le_not_le pwf_weaken)
  apply (meson less_le_not_le pwf_weaken)
  apply (rule pwfbdd_sel)
  apply simp_all
  using erase_subtypes_sf_preserve apply blast
  by (meson erase_subtypes_df_preserve)

theorem erase_disjoints_pwf[simp]: "pwfbdd n tr b \<Longrightarrow> i \<ge> n \<Longrightarrow> pwfbdd n tr (erase_disjoints i tr b)"
  apply (induction n tr b rule: pwfbdd.induct)
  apply (auto simp add: select_def)
  apply (meson less_le_not_le pwf_weaken)
  apply (meson less_le_not_le pwf_weaken)
  apply (rule pwfbdd_sel)
  apply simp_all
  using erase_disj_sf_preserve apply blast
  by (meson erase_disj_df_preserve)

lemma select_pwf[simp]: "pwfbdd i tr t \<Longrightarrow> pwfbdd i tr e \<Longrightarrow> i < n \<Longrightarrow> sub_free i tr e \<Longrightarrow> disj_free i tr t \<Longrightarrow> pwfbdd n tr (select i t e)"
  apply (simp add: select_def)
  apply auto
  by (meson le_eq_less_or_eq pwf_weaken)

inductive pwf_opt :: "nat \<Rightarrow> TR \<Rightarrow> BDD option \<Rightarrow> bool" where
  pwf_opt_none[simp, intro]: "pwf_opt n tr None" |
  pwf_opt_some[simp, intro]: "pwfbdd n tr s \<Longrightarrow> pwf_opt n tr (Some s)"

lemma select'_pwf[simp]: "pwf_opt i tr t \<Longrightarrow> pwf_opt i tr e \<Longrightarrow> i < n \<Longrightarrow> sub_free_opt i tr e \<Longrightarrow> disj_free_opt i tr t \<Longrightarrow> pwf_opt n tr (select' i t e)"
  apply (auto simp add: select'_def split: option.split)
  apply (rule pwf_opt_some)
  apply (rule select_pwf)
  apply (simp_all add: pwf_opt.simps sub_free_opt.simps disj_free_opt.simps)
  done

lemma select'_none_u[simp]: "select' i None e = None"
  by (auto simp add: select'_def)

lemma select'_u_none[simp]: "select' i t None = None"
  by (metis option.case_eq_if prod.simps(2) select'_def)

lemma select'_some_some_some[simp]: "select' i (Some t) (Some e) = Some (select i t e)"
  by (auto simp add: select'_def)

lemma select'_some_none_none: "select' i (Some t) e = None \<Longrightarrow> e = None"
  apply (case_tac "e")
  apply (auto simp add: select'_def)
  done

lemma select'_none_some_none: "select' i t (Some e) = None \<Longrightarrow> t = None"
  apply (case_tac "t")
  apply (auto simp add: select'_def)
  done

lemma select'_some: "select' i t e = Some r \<Longrightarrow> \<exists>tt ee. t = Some tt \<and> e = Some ee \<and> r = select i tt ee"
  by (metis (no_types, lifting) is_none_code(1) is_none_code(2) option.inject option.split_sel prod.simps(2) select'_def select'_some_some_some)

inductive erasures :: "nat \<Rightarrow> TR \<Rightarrow> BDD \<Rightarrow> BDD \<Rightarrow> BDD \<Rightarrow> bool" for c tr where
  erase_nothing[simp, intro]: "erasures c tr Nothing Nothing Nothing" |
  erase_top[simp, intro]: "erasures c tr Top Top Top" |
  erase_sel_mi_nn[simp]: "tr i c = MayIntersect \<Longrightarrow> td \<noteq> ed \<Longrightarrow> ts \<noteq> es \<Longrightarrow>
      erasures c tr t td ts \<Longrightarrow> erasures c tr e ed es \<Longrightarrow>
      erasures c tr (Select i t e) (Select i td ed) (Select i ts es)" |
  erase_sel_mi_en[simp]: "tr i c = MayIntersect \<Longrightarrow> ts \<noteq> es \<Longrightarrow>
      erasures c tr t d ts \<Longrightarrow> erasures c tr e d es \<Longrightarrow>
      erasures c tr (Select i t e) d (Select i ts es)" |
  erase_sel_mi_ne[simp]: "tr i c = MayIntersect \<Longrightarrow> td \<noteq> ed \<Longrightarrow>
      erasures c tr t td s \<Longrightarrow> erasures c tr e ed s \<Longrightarrow>
      erasures c tr (Select i t e) (Select i td ed) s" |
  erase_sel_mi_ee[simp]: "tr i c = MayIntersect \<Longrightarrow>
      erasures c tr t d s \<Longrightarrow> erasures c tr e d s \<Longrightarrow>
      erasures c tr (Select i t e) d s" |
  erase_sel_disj_n[simp]: "tr i c = Disjoint \<Longrightarrow> ts \<noteq> es \<Longrightarrow>
      erasures c tr t td ts \<Longrightarrow> erasures c tr e ed es \<Longrightarrow>
      erasures c tr (Select i t e) ed (Select i ts es)" |
  erase_sel_disj_e[simp]: "tr i c = Disjoint \<Longrightarrow>
      erasures c tr t td s \<Longrightarrow> erasures c tr e ed s \<Longrightarrow>
      erasures c tr (Select i t e) ed s" |
  erase_sel_sub_n[simp]: "tr i c = Subtype \<Longrightarrow> td \<noteq> ed \<Longrightarrow>
      erasures c tr t td ts \<Longrightarrow> erasures c tr e ed es \<Longrightarrow>
      erasures c tr (Select i t e) (Select i td ed) es" |
  erase_sel_sub_e[simp]: "tr i c = Subtype \<Longrightarrow>
      erasures c tr t d ts \<Longrightarrow> erasures c tr e d es \<Longrightarrow>
      erasures c tr (Select i t e) d es"

lemma erasures_erase:
  "erasures c tr t d s \<Longrightarrow> (d = erase_disjoints c tr t \<and> s = erase_subtypes c tr t)"
  apply (induction rule: erasures.induct)
  by (auto simp add: select_def)

lemma erase_erasures:
  "d = erase_disjoints c tr t \<Longrightarrow> s = erase_subtypes c tr t \<Longrightarrow> erasures c tr t d s"
  apply (induction t arbitrary: s d)
  apply (auto simp add: select_def)
  apply (meson Relatedness.exhaust erase_sel_mi_ee erase_sel_sub_e)
  apply (meson Relatedness.exhaust erase_sel_mi_en)
  apply (meson Relatedness.exhaust erase_sel_mi_ne erase_sel_sub_n)
  by (meson Relatedness.exhaust erase_sel_mi_nn)

fun contains_exact :: "TR \<Rightarrow> BDD \<Rightarrow> nat \<Rightarrow> bool" where
  "contains_exact tr Nothing _ = False" |
  "contains_exact tr Top _ = True" |
  "contains_exact tr (Select i t e) n =
     (if n \<le> i \<and> tr n i = Subtype then contains_exact tr t n else contains_exact tr e n)"

lemma contains_exact_select[simp]:
  "contains_exact tr (select i t e) n = contains_exact tr (Select i t e) n"
  apply (case_tac "t = e")
  using select_def apply auto
  done

fun fv :: "BDD \<Rightarrow> nat set" where
  "fv (Select i t e) = { i } \<union> fv t \<union> fv e" |
  "fv _ = {}"

lemma pwfbdd_fv: "pwfbdd c tr t \<Longrightarrow> i \<in> fv t \<Longrightarrow> i < c"
  apply (induction t)
  apply simp_all
  apply (rename_tac v t e)
  apply (subgoal_tac "pwfbdd c tr t")
  prefer 2
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject less_or_eq_imp_le pwf_weaken pwfbdd.cases)
  apply (subgoal_tac "pwfbdd c tr e")
  prefer 2
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject less_or_eq_imp_le pwf_weaken pwfbdd.cases)
  apply clarsimp
  using pwfbdd.cases apply auto
  done

theorem erase_disjoints_sem[simp]:
  "well_formed_tr c tr \<Longrightarrow> pwfbdd c tr t \<Longrightarrow> i \<le> c \<Longrightarrow>
   tr i c = Subtype \<Longrightarrow>
   contains_exact tr (erase_disjoints c tr t) i = contains_exact tr t i"
  apply (induction t; clarsimp)
  apply (rename_tac v t e)
  apply (subgoal_tac "pwfbdd c tr t")
  prefer 2
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject less_or_eq_imp_le pwf_weaken pwfbdd.cases)
  apply (subgoal_tac "pwfbdd c tr e")
  prefer 2
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject less_or_eq_imp_le pwf_weaken pwfbdd.cases)
  apply clarsimp
  apply (thin_tac "contains_exact tr (erase_disjoints c tr _) _ = _")
  apply (thin_tac "contains_exact tr (erase_disjoints c tr _) _ = _")
  apply (case_tac "v < i"; clarsimp)
  apply (metis BDD.distinct(3) BDD.distinct(5) BDD.inject Relatedness.distinct(1) leI less_or_eq_imp_le pwfbdd.cases wftr_refl0 wftr_sub_disj)
  done

theorem erase_subtypes_sem[simp]:
  "well_formed_tr c tr \<Longrightarrow> pwfbdd c tr t \<Longrightarrow>
   i > c \<or> tr i c \<noteq> Subtype \<Longrightarrow>
   (contains_exact tr (erase_subtypes c tr t) i) = (contains_exact tr t i)"
  apply (induction t)
  apply simp_all
  apply (rename_tac v t e)
  apply (subgoal_tac "pwfbdd c tr t")
  prefer 2
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) less_or_eq_imp_le pwf_weaken pwfbdd.cases)
  apply (subgoal_tac "pwfbdd c tr e")
  prefer 2
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) less_or_eq_imp_le pwf_weaken pwfbdd.cases)
  apply simp
  apply (case_tac "tr i v")
  apply simp_all
  apply (case_tac "i \<le> v")
  apply simp_all
  apply (case_tac "v \<le> c")
  apply simp_all
  using wftr3_trans wftr_weaken wftr_wftr3 apply blast
  apply (metis BDD.inject BDD.simps(5) BDD.simps(7) order.order_iff_strict pwfbdd.simps)
  done

end


theory tia_learns_lsar
  imports Main

begin

(* ------------------- PROPOSITIONAL LOGIC in sematicscholar.org ------------------- *)
lemma "A ⟶ A"
proof (rule impI)
  assume a: "A"
  show "A" by (rule a)
qed

lemma "A ⟶ A ∧ A"
proof
  assume "A"
  show "A ∧ A"
    by (simp add: ‹A›)
qed

lemma "A ∧ B ⟶ B ∧ A"
proof
  assume AB: "A ∧ B"
  show "B ∧ A"
  proof (rule conjE[OF AB]) (* conjE[OF AB]: ([A; B] ⟹ ?R) ⟹ ?R *)
    assume "A" and "B"
    show ?thesis (* ?thesis stands for current goal, i.e. the enclosing show (or have) statement *)
      by (simp add: AB)
  qed
qed

lemma "A ∧ B ⟶ B ∧ A"
proof
  assume AB: "A ∧ B"
  from AB show "B ∧ A"
  proof
    assume "A" and "B"
    show ?thesis
      by (simp add: AB)
  qed
qed

(* forward reasoning *)
lemma "A ∧ B ⟶ B ∧ A"
proof
  assume ab: "A ∧ B"
  from ab have a: "A" ..
  from ab have b: "B" ..
  from b a show "B ∧ A" ..
qed

(* ------------------- PREDICATE LOGIC in sematicscholar.org ------------------- *)

(*
The command fix introduces new local variables into a proof.
The pair fix-show corresponds to ⋀ (the universal quantifier at the meta-level)
  just like assume-show corresponds to ⟹.
*)

lemma assumes P: "∀x. P x" shows "∀x. P(f x)"
proof  (* allI: (⋀x. ?P x) ⟹ ∀x. ?P x *)
  fix a
  from P show "P(f a)"  (* allE: ⟦∀x. ?P x; ?P ?x ⟹ ?R⟧ ⟹ ?R *)
    by simp
qed

lemma assumes Pf: "∃x. P(f x)" shows "∃y. P y"
proof -
  from Pf show ?thesis
  proof  (* exE: [∃x. ?P x; ⋀x. ?P x ⟹ ?Q] ⟹ ?Q *)
    fix x
    assume "P(f x)"
    show ?thesis
      using ‹P (f x)› by auto  (* exI: ?P ?x ⟹ ∃x. ?P x *)
  qed
qed

lemma assumes Pf: "∃x. P(f x)" shows "∃y. P y"
proof -
  from Pf obtain x where "P(f x)" ..
      (* obtain provides a more appealing form of generalised existence reasoning *)
  thus "∃y. P y" ..
qed

lemma assumes ex: "∃x. ∀y. P x y" shows "∀y. ∃x. P x y"
proof
  fix y
  from ex obtain x where "∀y. P x y" ..
  hence "P x y" ..
  thus "∃x. P x y" ..
qed

(* ------------------- CANTOR'S THEOREM in sematicscholar.org ------------------- *)

(* CANTOR'S THEOREM: there is no surjective function from a set to its powerset. *)
theorem Cantor: "∃S. S ∉ range (f :: 'a ⇒ 'a set)"
proof
  let ?S = "{x. x ∉ f x}"  (* let introduces an abbreviation of a term *)
  show "?S ∉ range f"
  proof
    assume "?S ∈ range f"
    then obtain y where "?S = f y" ..
    show False
    proof cases
      assume "y ∈ S"
      with `?S = f y` show False by blast
    next
      assume "y ∉ S"
      with `?S = f y` show False by blast
    qed
  qed
qed

(* detailed version without blasting *)
theorem Cantor_Long: "∃S. S ∉ range (f :: 'a ⇒ 'a set)"
proof
  let ?S = "{x. x ∉ f x}"  (* let introduces an abbreviation of a term *)
  show "?S ∉ range f"
  proof
    assume "?S ∈ range f"
    then obtain y where "?S = f y" ..
    show False
    proof cases
      assume "y ∈ ?S"
      hence "y ∉ f y" by simp
      hence "y ∉ ?S"
        by (simp add: `?S = f y`)
      thus False
        using ‹y ∈ {x. x ∉ f x}› by auto
    next
      assume "y ∉ ?S"
      hence "y ∈ f y" by simp
      hence "y ∈ ?S"
        by (simp add: `?S = f y`)
      thus False
        using ‹y ∉ {x. x ∉ f x}› by auto
    qed
  qed
qed

end