(*
    Title:      Rings2.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Rings\<close>

theory Rings2
imports
   "HOL-Analysis.Analysis"
   "HOL-Computational_Algebra.Polynomial_Factorial"
begin

subsection\<open>Previous lemmas and results\<close>

context Rings.ring
begin

lemma sum_add:
  assumes A: "finite A"
  and B: "finite B"
  shows "sum f A + sum g B = sum f (A - B) + sum g (B - A) + sum (\<lambda>x. f x + g x) (A \<inter> B)"
proof -
  have 1: "sum f A = sum f (A - B) + sum f (A \<inter> B)"
    by (metis A Int_Diff_disjoint Un_Diff_Int finite_Diff finite_Int inf_sup_aci(1) local.sum.union_disjoint)
  have 2: "sum g B = sum g (B - A) + sum g (A \<inter> B)"
    by (metis B Int_Diff_disjoint Int_commute Un_Diff_Int finite_Diff finite_Int local.sum.union_disjoint)
  have 3: "sum f (A \<inter> B) + sum g (A \<inter> B) = sum (\<lambda>x. f x + g x) (A \<inter> B)"
    by (simp add: sum.distrib)
  show ?thesis
    by (simp add: "1" "2" "3" add.assoc add.left_commute)
qed

text\<open>This lemma is presented in the library but for additive abelian groups\<close>

lemma sum_negf:
  "sum (%x. - (f x)::'a) A = - sum f A"
proof (cases "finite A")
  case True thus ?thesis by (induct set: finite) auto
next
  case False thus ?thesis by simp
qed

text\<open>The following lemmas are presented in the library but for other type classes (semiring\_0)\<close>

lemma sum_distrib_left:
  shows "r * sum f A = sum (%n. r * f n) A"
proof (cases "finite A")
  case True
  thus ?thesis
  proof induct
    case empty thus ?case by simp
  next
    case (insert x A) thus ?case by (simp add: distrib_left)
  qed
next
  case False thus ?thesis by simp
qed

lemma sum_distrib_right:
  "sum f A * r = (\<Sum>n\<in>A. f n * r)"
proof (cases "finite A")
  case True
  then show ?thesis
  proof induct
    case empty thus ?case by simp
  next
    case (insert x A) thus ?case by (simp add: distrib_right)
  qed
next
  case False thus ?thesis by simp
qed

end

context comm_monoid_add
begin

lemma sum_two_elements:
  assumes "a \<noteq> b"
  shows "sum f {a,b} = f a + f b"
  by (metis Diff_cancel assms empty_Diff finite.emptyI infinite_remove add_0_right
    sum.empty sum.insert sum.insert_remove singletonD)

lemma sum_singleton: "sum f {x} = f x"
  by simp

end

subsection\<open>Subgroups\<close>

context group_add
begin
definition "subgroup A \<equiv> (0 \<in> A \<and> (\<forall>a\<in>A. \<forall>b \<in> A. a + b \<in> A) \<and> (\<forall>a\<in>A. -a \<in> A))"

lemma subgroup_0: "subgroup {0}"
  unfolding subgroup_def by auto

lemma subgroup_UNIV: "subgroup (UNIV)"
  unfolding subgroup_def by auto

lemma subgroup_inter:
  assumes "subgroup A" and "subgroup B"
  shows "subgroup (A \<inter> B)"
  using assms unfolding subgroup_def by blast

lemma subgroup_Inter:
  assumes "\<forall>I\<in>S. subgroup I"
  shows "subgroup (\<Inter>S)"
  using assms unfolding subgroup_def by auto

lemma subgroup_Union:
  fixes I::"nat => 'a set"
  defines S: "S\<equiv>{I n|n. n\<in>UNIV}"
  assumes all_subgroup: "\<forall>A\<in>S. subgroup A"
  and inc: "\<forall>n. I(n) \<subseteq> I(n+1)"
  shows "subgroup (\<Union>S)"
unfolding subgroup_def
proof (safe; (unfold Union_iff)?)
  show "\<exists>X\<in>S. 0 \<in> X"
  proof (rule bexI[of _ "I 0"])
    show "I 0 \<in> S" unfolding S by auto
    thus "0 \<in> I 0" using all_subgroup unfolding subgroup_def by auto
  qed
  fix y a ya b assume y: "y \<in> S" and a: "a \<in> y" and ya: "ya \<in> S" and b: "b \<in> ya"
  obtain n m where In: "y=I n" and Im: "ya = I m" using y ya S by auto
  have In_I_max:"I n \<subseteq> I (max n m)" using chain_le[OF inc] by auto
  have Im_I_max:"I m \<subseteq> I (max n m)" using chain_le[OF inc] by auto
  show "\<exists>x\<in>S. a + b \<in> x"
  proof (rule bexI[of _ "I (max n m)"])
    show "a + b \<in> I (max n m)"
      by (metis Im Im_I_max In In_I_max a all_subgroup b in_mono max_def subgroup_def y ya)
    show "I (max n m) \<in> S" using S by auto
  qed
  show "\<exists>x\<in>S. - a \<in> x"
  proof (rule bexI[of _ "I (max n m)"])
    show "- a \<in> I (max n m)" by (metis In In_I_max a all_subgroup in_mono subgroup_def y)
    show "I (max n m) \<in> S" using S by auto
  qed
qed

end

subsection\<open>Ideals\<close>

context Rings.ring
begin

lemma subgroup_left_principal_ideal: "subgroup {r*a|r. r\<in>UNIV}"
proof (unfold subgroup_def, auto)
  show "\<exists>r. 0 = r * a" by (rule exI[of _ 0], simp)
  fix r ra show "\<exists>rb. r * a + ra * a = rb * a"
    by (metis add_0_right combine_common_factor)
  show "\<exists>ra. - (r * a) = ra * a" by (metis minus_mult_left)
qed

definition "left_ideal I = (subgroup I \<and> (\<forall>x\<in>I. \<forall>r. r*x \<in> I))"
definition "right_ideal I = (subgroup I \<and> (\<forall>x\<in>I. \<forall>r. x*r \<in> I))"
definition "ideal I= (left_ideal I \<and> right_ideal I)"

definition "left_ideal_generated S = \<Inter>{I. left_ideal I \<and> S \<subseteq> I}"
definition "right_ideal_generated S = \<Inter>{I. right_ideal I \<and> S \<subseteq> I}"
definition "ideal_generated S = \<Inter>{I. ideal I \<and> S \<subseteq> I}"

definition "left_principal_ideal S =  (\<exists>a. left_ideal_generated {a} = S)"
definition "right_principal_ideal S = (right_ideal S \<and> (\<exists>a. right_ideal_generated {a} = S))"
definition "principal_ideal S = (\<exists>a. ideal_generated {a} = S)"

lemma ideal_inter:
  assumes "ideal I" and "ideal J" shows "ideal (I \<inter> J)"
  using assms
  unfolding ideal_def left_ideal_def right_ideal_def subgroup_def
  by auto

lemma ideal_Inter:
  assumes "\<forall>I\<in>S. ideal I"
  shows "ideal (\<Inter>S)"
proof (unfold ideal_def left_ideal_def right_ideal_def, auto)
  show "subgroup (\<Inter>S)" and "subgroup (\<Inter>S)"
    using subgroup_Inter assms
    unfolding ideal_def left_ideal_def by auto
  fix x r xa assume X: "\<forall>X\<in>S. x \<in> X" and xa: "xa \<in> S"
  show "r * x \<in> xa" by (metis X assms ideal_def left_ideal_def xa)
next
  fix x r xa assume X: "\<forall>X\<in>S. x \<in> X" and xa: "xa \<in> S"
  show "x * r \<in> xa" by (metis X assms ideal_def right_ideal_def xa)
qed

lemma ideal_Union:
  fixes I::"nat => 'a set"
  defines S: "S\<equiv>{I n|n. n\<in>UNIV}"
  assumes all_ideal: "\<forall>A\<in>S. ideal A"
  and inc: "\<forall>n. I(n) \<subseteq> I(n+1)"
  shows "ideal (\<Union>S)"
unfolding ideal_def left_ideal_def right_ideal_def
proof (safe; (unfold Union_iff)?)
  fix y x r
  assume y: "y \<in> S" and x: "x \<in> y"
  obtain n where n: "y=I n" using y S by auto
  show "\<exists>xa\<in>S. r * x \<in> xa"
  proof (rule bexI[of _ "I n"])
    show "r * x \<in> I n" by (metis n assms(2) ideal_def left_ideal_def x y)
    show "I n \<in> S" by (metis n y)
  qed
  show "\<exists>xa\<in>S. x * r \<in> xa"
  proof (rule bexI[of _ "I n"])
    show "x * r \<in> I n" by (metis n assms(2) ideal_def right_ideal_def x y)
    show "I n \<in> S" by (metis n y)
  qed
next
  show "subgroup (\<Union>S)" and "subgroup (\<Union>S)"
    using subgroup_Union
    by (metis (mono_tags) S all_ideal ideal_def inc right_ideal_def)+
qed

lemma ideal_not_empty:
  assumes "ideal I"
  shows "I \<noteq> {}"
  using assms unfolding ideal_def left_ideal_def subgroup_def by auto

lemma ideal_0: "ideal {0}"
  unfolding ideal_def left_ideal_def right_ideal_def using subgroup_0 by auto

lemma ideal_UNIV: "ideal UNIV"
  unfolding ideal_def left_ideal_def right_ideal_def using subgroup_UNIV by auto

lemma ideal_generated_0: "ideal_generated {0} = {0}"
  unfolding ideal_generated_def using ideal_0 by auto

lemma ideal_generated_subset_generator:
  assumes "ideal_generated A = I"
  shows "A \<subseteq> I"
  using assms unfolding ideal_generated_def by auto

lemma left_ideal_minus:
  assumes "left_ideal I"
  and "a\<in>I" and "b\<in>I"
  shows "a - b \<in> I"
  by (metis assms(1) assms(2) assms(3) diff_minus_eq_add left_ideal_def minus_minus subgroup_def)

lemma right_ideal_minus:
  assumes "right_ideal I"
  and "a\<in>I" and "b\<in>I"
  shows "a - b \<in> I"
  by (metis assms(1) assms(2) assms(3) diff_minus_eq_add minus_minus right_ideal_def subgroup_def)

lemma ideal_minus:
  assumes "ideal I"
  and "a\<in>I" and "b\<in>I"
  shows "a - b \<in> I"
  by (metis assms(1) assms(2) assms(3) ideal_def right_ideal_minus)

lemma ideal_ideal_generated: "ideal (ideal_generated S)"
  unfolding ideal_generated_def
  unfolding ideal_def left_ideal_def subgroup_def right_ideal_def
  by blast

lemma sum_left_ideal:
  assumes li_X: "left_ideal X"
  and U_X: "U \<subseteq> X" and U: "finite U"
  shows "(\<Sum>i\<in>U. f i * i) \<in> X"
  using U U_X
proof (induct U)
  case empty show ?case using li_X by (simp add:  left_ideal_def subgroup_def)
next
  case (insert x U)
  have x_in_X: "x \<in> X" using insert.prems by simp
  have fx_x_X: "f x * x \<in> X" using li_X x_in_X unfolding left_ideal_def by simp
  have sum_in_X: "(\<Sum>i\<in>U. f i * i) \<in> X" using insert.prems insert.hyps(3) by simp
  have "(\<Sum>i\<in>(insert x U). f i * i) = f x * x + (\<Sum>i\<in>U. f i * i)"
    by (simp add: insert.hyps(1) insert.hyps(2))
  also have "... \<in> X" using li_X fx_x_X sum_in_X unfolding left_ideal_def subgroup_def by auto
  finally show "(\<Sum>i\<in>(insert x U). f i * i) \<in> X" .
qed

lemma sum_right_ideal:
  assumes li_X: "right_ideal X"
  and U_X: "U \<subseteq> X" and U: "finite U"
  shows "(\<Sum>i\<in>U. i * f i) \<in> X"
  using U U_X
proof (induct U)
  case empty show ?case using li_X by (simp add: right_ideal_def subgroup_def)
next
  case (insert x U)
  have x_in_X: "x \<in> X" using insert.prems by simp
  have fx_x_X: "x * f x \<in> X" using li_X x_in_X unfolding right_ideal_def by simp
  have sum_in_X: "(\<Sum>i\<in>U. i * f i) \<in> X" using insert.prems insert.hyps(3) by simp
  have "(\<Sum>i\<in>(insert x U). i * f i) =  x * f x + (\<Sum>i\<in>U. i * f i)"
    by (simp add: insert.hyps(1) insert.hyps(2))
  also have "... \<in> X" using li_X fx_x_X sum_in_X unfolding right_ideal_def subgroup_def by auto
  finally show "(\<Sum>i\<in>(insert x U). i * f i) \<in> X" .
qed

lemma right_ideal_generated_subset:
  assumes "S \<subseteq> T"
  shows "right_ideal_generated S \<subseteq> right_ideal_generated T"
  unfolding right_ideal_generated_def using assms by auto

lemma ideal_generated_subset:
  assumes "S \<subseteq> T"
  shows "ideal_generated S \<subseteq> ideal_generated T"
  unfolding ideal_generated_def using assms by auto

lemma ideal_generated_in:
  assumes "a \<in> A"
  shows "a \<in> ideal_generated A"
  unfolding ideal_generated_def using assms by auto

lemma ideal_generated_repeated: "ideal_generated {a,a} = ideal_generated {a}"
  unfolding ideal_generated_def by auto

end

context ring_1
begin

lemma left_ideal_explicit:
  "left_ideal_generated S = {y. \<exists>f U. finite U \<and> U \<subseteq> S \<and> sum (\<lambda>i. f i * i) U = y}" (is "?S = ?B")
proof
  have S_in_B: "S \<subseteq> ?B"
  proof (auto)
    fix x assume x: "x\<in>S"
    show "\<exists>f U. finite U \<and> U \<subseteq> S \<and> (\<Sum>i\<in>U. f i * i) = x"
      by (rule exI[of _ "\<lambda>i. 1"], rule exI[of _ "{x}"], simp add: x)
  qed
  have left_ideal_B: "left_ideal ?B"
  proof (unfold left_ideal_def, auto)
    show "subgroup ?B"
    proof (unfold subgroup_def, auto)
      show "\<exists>f U. finite U \<and> U \<subseteq> S \<and> (\<Sum>i\<in>U. f i * i) = 0"
        by (rule exI[of _ "id"], rule exI[of _ "{}"], auto)
      fix f A assume A: "finite A" and AS: "A \<subseteq> S"
      show"\<exists>fa Ua. finite Ua \<and> Ua \<subseteq> S \<and> (\<Sum>i\<in>Ua. fa i * i) = - (\<Sum>i\<in>A. f i * i)"
        by (rule exI[of _ "\<lambda>i. - f i"], rule exI[of _ A],
            auto simp add: A AS sum_negf[of "\<lambda>i. f i * i" A])
      fix fa B assume B: "finite B" and BS: "B \<subseteq> S"
      let ?g="\<lambda>i. if i \<in> A - B then f i else if i \<in> B - A then fa i else f i + fa i"
      show "\<exists>fb Ub. finite Ub \<and> Ub \<subseteq> S \<and> (\<Sum>i\<in>Ub. fb i * i)
        = (\<Sum>i\<in>A. f i * i) + (\<Sum>i\<in>B. fa i * i)"
      proof (rule exI[of _ ?g], rule exI[of _ "A \<union> B"], simp add: A B AS BS)
        let ?g2 = "(\<lambda>i. (if i \<in> A \<and> i \<notin> B then f i else
          if i \<in> B - A then fa i else f i + fa i) * i)"
        have "(\<Sum>i\<in>A. f i * i) + (\<Sum>i\<in>B. fa i * i)
          = (\<Sum>i\<in>A - B. f i * i) + (\<Sum>i\<in>B - A. fa i * i) + (\<Sum>i\<in>A\<inter>B. (f i * i) + (fa i * i))"
          by (rule sum_add[OF A B])
        also have "... = (\<Sum>i\<in>A - B. f i * i) + (\<Sum>i\<in>B - A. fa i * i)
          + (\<Sum>i\<in>A \<inter> B. (f i + fa i) * i)"
          by (simp add: distrib_right)
        also have "... =  sum ?g2 (A - B) + sum ?g2 (B - A) + sum ?g2 (A \<inter> B)" by auto
        also have "... = sum ?g2 (A \<union> B)" by (rule sum.union_diff2[OF A B, symmetric])
        finally show "sum ?g2 (A \<union> B) = (\<Sum>i\<in>A. f i * i) + (\<Sum>i\<in>B. fa i * i)" ..
      qed
    qed
    fix f U r assume U: "finite U" and U_in_S: "U \<subseteq> S"
    show "\<exists>fa Ua. finite Ua \<and> Ua \<subseteq> S \<and> (\<Sum>i\<in>Ua. fa i * i) = r * (\<Sum>i\<in>U. f i * i)"
      by (rule exI[of _ "\<lambda>i. r * f i"], rule exI[of _ U])
    (simp add: U U_in_S sum_distrib_left mult_assoc)
  qed
  thus "?S \<subseteq> ?B" using S_in_B unfolding left_ideal_generated_def by auto
next
  show "?B \<subseteq> ?S"
  proof (unfold left_ideal_generated_def, auto)
    fix X f U
    assume li_X: "left_ideal X" and S_X: "S \<subseteq> X" and U: "finite U" and U_in_S: "U \<subseteq> S"
    have U_in_X: "U \<subseteq> X" using U_in_S S_X by simp
    show "(\<Sum>i\<in>U. f i * i) \<in> X"
      by (rule sum_left_ideal[OF li_X U_in_X U])
  qed
qed

lemma right_ideal_explicit:
  "right_ideal_generated S = {y. \<exists>f U. finite U \<and> U \<subseteq> S \<and> sum (\<lambda>i. i * f i) U = y}" (is "?S = ?B")
proof
  have S_in_B: "S \<subseteq> ?B"
  proof (auto)
    fix x assume x: "x\<in>S"
    show "\<exists>f U. finite U \<and> U \<subseteq> S \<and> (\<Sum>i\<in>U. i * f i) = x"
      by (rule exI[of _ "\<lambda>i. 1"], rule exI[of _ "{x}"], simp add: x)
  qed
  have right_ideal_B: "right_ideal ?B"
  proof (unfold right_ideal_def, auto)
    show "subgroup ?B"
    proof (unfold subgroup_def, auto)
      show "\<exists>f U. finite U \<and> U \<subseteq> S \<and> (\<Sum>i\<in>U. i * f i) = 0"
        by (rule exI[of _ "id"], rule exI[of _ "{}"], auto)
      fix f A assume A: "finite A" and AS: "A \<subseteq> S"
      show"\<exists>fa Ua. finite Ua \<and> Ua \<subseteq> S \<and> (\<Sum>i\<in>Ua.  i * fa i) = - (\<Sum>i\<in>A.  i * f i)"
        by (rule exI[of _ "\<lambda>i. - f i"], rule exI[of _ A],
            auto simp add: A AS sum_negf[of "\<lambda>i. i * f i" A])
      fix fa B assume B: "finite B" and BS: "B \<subseteq> S"
      let ?g="\<lambda>i. if i \<in> A - B then f i else if i \<in> B - A then fa i else f i + fa i"
      show "\<exists>fb Ub. finite Ub \<and> Ub \<subseteq> S \<and> (\<Sum>i\<in>Ub. i * fb i)
        = (\<Sum>i\<in>A. i * f i) + (\<Sum>i\<in>B. i * fa i)"
      proof (rule exI[of _ ?g], rule exI[of _ "A \<union> B"], simp add: A B AS BS)
        let ?g2 = "(\<lambda>i. i * (if i \<in> A \<and> i \<notin> B then f i else
          if i \<in> B - A then fa i else f i + fa i))"
        have "(\<Sum>i\<in>A.  i * f i) + (\<Sum>i\<in>B.  i * fa i)
          = (\<Sum>i\<in>A - B.  i * f i) + (\<Sum>i\<in>B - A.  i * fa i) + (\<Sum>i\<in>A\<inter>B. (i * f i) + (i * fa i))"
          by (rule sum_add[OF A B])
        also have "... = (\<Sum>i\<in>A - B. i * f i) + (\<Sum>i\<in>B - A.  i * fa i)
          + (\<Sum>i\<in>A \<inter> B. i * (f i + fa i))"
          by (simp add: distrib_left)
        also have "... =  sum ?g2 (A - B) + sum ?g2 (B - A) + sum ?g2 (A \<inter> B)" by auto
        also have "... = sum ?g2 (A \<union> B)" by (rule sum.union_diff2[OF A B, symmetric])
        finally show "sum ?g2 (A \<union> B) = (\<Sum>i\<in>A. i * f i) + (\<Sum>i\<in>B. i * fa i)" ..
      qed
    qed
    fix f U r assume U: "finite U" and U_in_S: "U \<subseteq> S"
    show "\<exists>fa Ua. finite Ua \<and> Ua \<subseteq> S \<and> (\<Sum>i\<in>Ua. i * fa i) = (\<Sum>i\<in>U. i * f i) * r"
      by (rule exI[of _ "\<lambda>i. f i * r"], rule exI[of _ U])
    (simp add: U U_in_S sum_distrib_right mult_assoc)
  qed
  thus "?S \<subseteq> ?B" using S_in_B unfolding right_ideal_generated_def by auto
next
  show "?B \<subseteq> ?S"
  proof (unfold right_ideal_generated_def, auto)
    fix X f U
    assume li_X: "right_ideal X" and S_X: "S \<subseteq> X" and U: "finite U" and U_in_S: "U \<subseteq> S"
    have U_in_X: "U \<subseteq> X" using U_in_S S_X by simp
    show "(\<Sum>i\<in>U. i * f i) \<in> X"
      by (rule sum_right_ideal[OF li_X U_in_X U])
  qed
qed

end

context comm_ring
begin

corollary ideal_eq_left_ideal: "ideal I = left_ideal I"
  by (metis ideal_def left_ideal_eq_right_ideal)

lemma ideal_eq_right_ideal: "ideal I = right_ideal I"
  by (metis ideal_def left_ideal_eq_right_ideal)

lemma principal_ideal_eq_left:
  "principal_ideal S = (\<exists>a. left_ideal_generated {a} = S)"
  unfolding principal_ideal_def ideal_generated_def left_ideal_generated_def
  unfolding ideal_eq_left_ideal ..

end

context comm_ring_1
begin

lemma ideal_generated_eq_left_ideal: "ideal_generated A = left_ideal_generated A"
  unfolding ideal_generated_def ideal_def
  by (metis (no_types, lifting) Collect_cong left_ideal_eq_right_ideal left_ideal_generated_def)

lemma ideal_generated_eq_right_ideal: "ideal_generated A = right_ideal_generated A"
  unfolding ideal_generated_def ideal_def
  by (metis (no_types, lifting) Collect_cong left_ideal_eq_right_ideal right_ideal_generated_def)

lemma obtain_sum_ideal_generated:
  assumes a: "a \<in> ideal_generated A" and A: "finite A"
  obtains f where "sum (\<lambda>i. f i * i) A = a"
proof -
  obtain g U where g: "sum (\<lambda>i. g i * i) U = a" and UA: "U \<subseteq> A" and U: "finite U"
    using a unfolding ideal_generated_eq_left_ideal
    unfolding left_ideal_explicit by blast
  let ?f="\<lambda>i. if i \<in> A - U then 0 else g i"
  have A_union: "A = (A - U) \<union> U" using UA by auto
  have "sum (\<lambda>i. ?f i * i) A = sum (\<lambda>i. ?f i * i) ((A - U) \<union> U)" using A_union by simp
  also have "... = sum (\<lambda>i. ?f i * i) (A - U) + sum (\<lambda>i. ?f i * i) U"
    by (rule sum.union_disjoint[OF _ U], auto simp add: A U UA)
  also have "... = sum (\<lambda>i. ?f i * i) U" by auto
  also have "... = a" using g by auto
  finally have "sum (\<lambda>i. ?f i * i) A = a" .
  with that show ?thesis .
qed

lemma dvd_ideal_generated_singleton:
  assumes subset: "ideal_generated {a} \<subseteq> ideal_generated {b}"
  shows "b dvd a"
proof -
 have "a \<in> ideal_generated {a}" by (simp add: ideal_generated_in)
 hence a: "a \<in> ideal_generated {b}" by (metis subset subsetCE)
 obtain f where "sum (\<lambda>i. f i * i) {b} = a" by (rule obtain_sum_ideal_generated[OF a], simp)
 hence fb_b_a: "f b * b = a" unfolding sum_singleton .
 show ?thesis unfolding dvd_def by (rule exI[of _ "f b"], metis fb_b_a mult_commute)
qed

lemma ideal_generated_singleton: "ideal_generated {a} = {k*a|k. k \<in> UNIV}"
proof (auto simp add: ideal_generated_eq_left_ideal left_ideal_explicit)
  fix f U
  assume U: "finite U" and U_in_a: "U \<subseteq> {a}"
  show "\<exists>k. (\<Sum>i\<in>U. f i * i) = k * a"
  proof (cases "U={}")
    case True show ?thesis by (rule exI[of _ 0], simp add: True)
  next
    case False
    hence Ua: "U = {a}" using U_in_a by auto
    show ?thesis by (rule exI[of _ "f a"]) (simp add: Ua sum_singleton)
  qed
next
  fix k
  show " \<exists>f U. finite U \<and> U \<subseteq> {a} \<and> (\<Sum>i\<in>U. f i * i) = k * a"
    by (rule exI[of _ "\<lambda>i. k"], rule exI[of _ "{a}"], simp)
qed

lemma dvd_ideal_generated_singleton':
  assumes b_dvd_a: "b dvd a"
  shows "ideal_generated {a} \<subseteq> ideal_generated {b}"
  apply (simp only: ideal_generated_singleton)
  using assms unfolding dvd_def
  apply auto
  apply (simp_all only: mult_commute)
  unfolding mult_assoc[symmetric]
  apply blast
  done

lemma ideal_generated_subset2:
  assumes ac: "ideal_generated {a} \<subseteq> ideal_generated {c}"
  and bc: "ideal_generated {b} \<subseteq> ideal_generated {c}"
  shows "ideal_generated {a,b} \<subseteq> ideal_generated {c}"
proof
  fix x
  assume x: "x \<in> ideal_generated {a, b}"
  show " x \<in> ideal_generated {c}"
  proof (cases "a=b")
    case True
    show ?thesis using x bc unfolding True ideal_generated_repeated by fast
  next
    case False
    obtain k where k: "a = c * k"
      using dvd_ideal_generated_singleton[OF ac] unfolding dvd_def by auto
    obtain k' where k': "b = c * k'"
      using dvd_ideal_generated_singleton[OF bc] unfolding dvd_def by auto
    obtain f where f: "sum (\<lambda>i. f i * i) {a,b} = x"
      by (rule obtain_sum_ideal_generated[OF x], simp)
    hence "x = f a * a + f b * b " unfolding sum_two_elements[OF False] by simp
    also have "... = f a * (c * k) + f b * (c * k')" unfolding k k' by simp
    also have "... = (f a * k) * c + (f b * k') * c"
      by (simp only: mult_assoc) (simp only: mult_commute)
    also have "... = (f a * k +  f b * k') * c"
      by (simp only: mult_commute) (simp only: distrib_left)
    finally have "x = (f a * k + f b * k') * c" .
    thus ?thesis unfolding ideal_generated_singleton by auto
  qed
qed

end

lemma ideal_kZ: "ideal {k*x|x. x\<in>(UNIV::int set)}"
  unfolding ideal_def left_ideal_def right_ideal_def subgroup_def
  apply auto
  apply (metis int_distrib(2))
  apply (metis minus_mult_right)
  apply (metis int_distrib(2))
  apply (metis minus_mult_right)
  done

subsection\<open>GCD Rings and Bezout Domains\<close>

text\<open>To define GCD rings and Bezout rings, there are at least two options:
fix the operation gcd or just assume its existence. We have chosen the second one in order to be
able to use subclasses (if we fix a gcd in the bezout ring class, then we couln't prove that
principal ideal rings are a subclass of bezout rings).\<close>

class GCD_ring = comm_ring_1
  + assumes exists_gcd: "\<exists>d. d dvd a \<and> d dvd b \<and> (\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd d)"
begin

text\<open>In this structure, there is always a gcd for each pair of elements, but maybe not unique.
The following definition essentially says if a function satisfies the condition to be a gcd.\<close>

definition is_gcd :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "is_gcd (gcd') = (\<forall>a b. (gcd' a b dvd a)
                          \<and> (gcd' a b dvd b)
                          \<and> (\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd gcd' a b))"

lemma gcd'_dvd1:
  assumes "is_gcd gcd'" shows "gcd' a b dvd a" using assms unfolding is_gcd_def by auto

lemma gcd'_dvd2:
  assumes "is_gcd gcd'" shows "gcd' a b dvd b"
  using assms unfolding is_gcd_def by auto

lemma gcd'_greatest:
  assumes "is_gcd gcd'" and "l dvd a" and "l dvd b"
  shows "l dvd gcd' a b"
  using assms unfolding is_gcd_def by auto

lemma gcd'_zero [simp]:
  assumes "is_gcd gcd'"
  shows "gcd' x y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (metis dvd_0_left dvd_refl gcd'_dvd1 gcd'_dvd2 gcd'_greatest assms)+

end

class GCD_domain = GCD_ring + idom

class bezout_ring = comm_ring_1 +
        assumes exists_bezout: "\<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)"
begin

subclass GCD_ring
proof
  fix a b
  show "\<exists>d. d dvd a \<and> d dvd b \<and> (\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd d)"
    using exists_bezout[of a b] by auto
qed

text\<open>In this structure, there is always a bezout decomposition for each pair of elements, but it is
not unique. The following definition essentially says if a function satisfies the condition to be a
bezout decomposition.\<close>

definition is_bezout :: "('a \<Rightarrow>'a \<Rightarrow> ('a \<times> 'a \<times> 'a)) \<Rightarrow> bool"
  where "is_bezout (bezout) = (\<forall>a b. let (p, q, gcd_a_b) = bezout a b
                                      in
                                        p * a + q * b = gcd_a_b
                                        \<and> (gcd_a_b dvd a)
                                        \<and> (gcd_a_b dvd b)
                                        \<and> (\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd gcd_a_b))"

text\<open>The following definition is similar to the previous one, and checks if the input is a
function that given two parameters \<open>a b\<close> returns 5 elements \<open>(p,q,u,v,d)\<close>
where \<open>d\<close> is a gcd of \<open>a\<close> and \<open>b\<close>, \<open>p\<close> and \<open>q\<close> are the
bezout coefficients such that \<open>p*a+q*b=d\<close>, \<open>d*u = -b\<close> and \<open>d*v= a\<close>.
The elements \<open>u\<close> and \<open>v\<close> are useful for defining the bezout matrix.\<close>

definition is_bezout_ext :: "('a \<Rightarrow>'a \<Rightarrow> ('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a)) \<Rightarrow> bool"
  where "is_bezout_ext (bezout) = (\<forall>a b. let (p, q, u, v, gcd_a_b) = bezout a b
                                          in
                                            p * a + q * b = gcd_a_b
                                            \<and> (gcd_a_b dvd a)
                                            \<and> (gcd_a_b dvd b)
                                            \<and> (\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd gcd_a_b)
                                            \<and> gcd_a_b * u = -b
                                            \<and> gcd_a_b * v = a)"

lemma is_gcd_is_bezout_ext:
  assumes "is_bezout_ext bezout"
  shows "is_gcd (\<lambda>a b. case bezout a b of (x, xa,u,v, gcd') \<Rightarrow> gcd')"
  unfolding is_gcd_def using assms unfolding is_bezout_ext_def Let_def by (simp add: split_beta)

lemma is_bezout_ext_is_bezout:
  assumes "is_bezout_ext bezout"
  shows "is_bezout (\<lambda>a b. case bezout a b of (x,xa,u,v, gcd') \<Rightarrow> (x,xa,gcd'))"
  unfolding is_bezout_def using assms unfolding is_bezout_ext_def Let_def by (simp add: split_beta)

lemma is_gcd_is_bezout:
  assumes "is_bezout bezout"
  shows "is_gcd (\<lambda>a b. (case bezout a b of (_, _, gcd') \<Rightarrow> (gcd')))"
  unfolding is_gcd_def using assms unfolding is_bezout_def Let_def by (simp add: split_beta)

text\<open>The assumptions of the Bezout rings say that there exists a bezout operation.
  Now we will show that there also exists an operation satisfying \<open>is_bezout_ext\<close>\<close>

lemma exists_bezout_ext_aux:
  fixes a and b
  shows "\<exists>p q u v 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) \<and> d * u = -b \<and> d * v = a"
proof -
  obtain p q d where prems01: "(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)"
                    using exists_bezout [of a b] by fastforce
  hence db: "d dvd b" and da: "d dvd a" by blast+
  obtain u v where prems02: "d * u = -b" and prems03: "d * v = a" using db and da
    by (metis local.dvdE local.minus_mult_right)
  show ?thesis using exI [of _ "(p,q,u,v,d)"] prems01 prems02 prems03
  by metis
qed

lemma exists_bezout_ext: "\<exists>bezout_ext. is_bezout_ext bezout_ext"
proof -
  define bezout_ext where "bezout_ext a b = (SOME (p,q,u,v,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) \<and> d * u = -b \<and> d * v = a)"
    for a b
  show ?thesis
  proof (rule exI [of _ bezout_ext], unfold is_bezout_ext_def, rule+)
    fix a b
    obtain p q u v d where foo: "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) \<and>
              d * u = - b \<and> d * v = a" using exists_bezout_ext_aux [of a b] by fastforce
    show "let (p, q, u, v, gcd_a_b) = bezout_ext a b
           in p * a + q * b = gcd_a_b \<and>
              gcd_a_b dvd a \<and>
              gcd_a_b dvd b \<and>
              (\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd gcd_a_b) \<and>
              gcd_a_b * u = - b \<and> gcd_a_b * v = a"
      by (unfold bezout_ext_def Let_def, rule someI [of _ "(p,q,u,v,d)"], clarify, rule foo)
   qed
qed

end

class bezout_domain = bezout_ring + idom

subclass (in bezout_domain) GCD_domain
proof
qed

class bezout_ring_div = bezout_ring + euclidean_semiring
class bezout_domain_div = bezout_domain + euclidean_semiring

subclass (in bezout_ring_div) bezout_domain_div
proof qed

subsection\<open>Principal Ideal Domains\<close>

class pir = comm_ring_1 + assumes all_ideal_is_principal: "ideal I \<Longrightarrow> principal_ideal I"
class pid = idom + pir

text\<open>Thanks to the following proof, we will show that there exist bezout and gcd operations
in principal ideal rings for each pair of elements.\<close>

subclass (in pir) bezout_ring
proof
  fix a b
  define S where "S = ideal_generated {a,b}"
  have ideal_S: "ideal S" using ideal_ideal_generated unfolding S_def by simp
  obtain d where d: "ideal_generated {d} = S" using all_ideal_is_principal[OF ideal_S]
    unfolding principal_ideal_def by blast
  have ideal_d: "ideal (ideal_generated {d})" using ideal_ideal_generated by simp
  have a_subset_d: "ideal_generated {a} \<subseteq> ideal_generated {d}"
    by (metis S_def d insertI1 ideal_generated_subset singletonD subsetI)
  have b_subset_d: "ideal_generated {b} \<subseteq> ideal_generated {d}"
    by (metis S_def d insert_iff ideal_generated_subset subsetI)
  have d_in_S: "d \<in> S" by (metis d insert_subset ideal_generated_subset_generator)
  obtain f U where U: "U \<subseteq> {a,b}" and f: "sum (\<lambda>i. f i * i) U = d"
    using left_ideal_explicit[of "{a,b}"] d_in_S unfolding S_def ideal_generated_eq_left_ideal
    by auto
  define g where "g i = (if i \<in> U then f i else 0)" for i
  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)"
  proof (cases "a = b")
    case True
    show ?thesis
    proof (rule exI[of _ "g a"], rule exI[of _ "0"], rule exI[of _ d], auto)
      show ga_a_d: "g a * a = d"
        unfolding g_def
      proof auto
        assume "a \<in> U"
        hence Ua: "U = {a}" using U True by auto
        show "f a * a = d" using f unfolding Ua
          unfolding sum_singleton .
      next
        assume "a \<notin> U"
        hence U_empty: "U = {}" using U True by auto
        show "0 = d" using f unfolding U_empty by auto
      qed
      show "d dvd a" by (rule dvd_ideal_generated_singleton[OF a_subset_d])
      show "d dvd b" by (rule dvd_ideal_generated_singleton[OF b_subset_d])
      fix d' assume d'_dvd_a: "d' dvd a" and d'_dvd_b: "d' dvd b"
      show "d' dvd d" by (metis ga_a_d d'_dvd_a dvd_mult2 mult_commute)
    qed
  next
    case False
    show ?thesis
    proof (rule exI[of _ "g a"], rule exI[of _ "g b"], rule exI[of _ d], auto)
      show "g a * a + g b * b = d"
      proof (auto simp add: g_def)
        assume a: "a \<in> U" and b: "b \<in> U"
        hence U_ab: "U = {a,b}" using U by auto
        show "f a * a + f b * b = d"  using f unfolding U_ab sum_two_elements[OF False] .
      next
        assume a: "a \<in> U" and b: "b \<notin> U"
        hence U_a: "U = {a}" using U by auto
        show "f a * a = d" using f unfolding U_a sum_singleton .
      next
        assume a: "a \<notin> U" and b: "b \<in> U"
        hence U_b: "U = {b}" using U by auto
        show "f b * b = d" using f unfolding U_b sum_singleton .
      next
        assume a: "a \<notin> U" and b: "b \<notin> U"
        hence "U = {}" using U by auto
        thus "0 = d" using f by auto
      qed
      show "d dvd a" by (rule dvd_ideal_generated_singleton[OF a_subset_d])
      show "d dvd b" by (rule dvd_ideal_generated_singleton[OF b_subset_d])
      fix d' assume d'a: "d' dvd a" and d'b: "d' dvd b"
      have ad': "ideal_generated {a} \<subseteq> ideal_generated {d'}"
        by (rule dvd_ideal_generated_singleton'[OF d'a])
      have bd': "ideal_generated {b} \<subseteq> ideal_generated {d'}"
        by (rule dvd_ideal_generated_singleton'[OF d'b])
      have abd': "ideal_generated {a,b} \<subseteq> ideal_generated {d'}"
        by (rule ideal_generated_subset2[OF ad' bd'])
      hence dd': "ideal_generated {d} \<subseteq> ideal_generated {d'}"
        by (simp add: S_def d)
      show "d' dvd d" by (rule dvd_ideal_generated_singleton[OF dd'])
    qed
  qed
qed

subclass (in pid) bezout_domain
proof
qed

context pir
begin

lemma ascending_chain_condition:
  fixes I::"nat=>'a set"
  assumes all_ideal: "\<forall>n. ideal (I(n))"
  and inc: "\<forall>n. I(n) \<subseteq> I(n+1)"
  shows "\<exists>n. I(n)=I(n+1)"
proof -
  let ?I = "\<Union>{I(n)|n. n\<in>(UNIV::nat set)}"
  have "ideal ?I" using ideal_Union[of I] all_ideal inc by fast
  from this obtain a where a: "ideal_generated {a} = ?I"
    using all_ideal_is_principal
    unfolding principal_ideal_def by fastforce
  have "a \<in> ?I" using a ideal_generated_subset_generator[of "{a}" "?I"] by simp
  from this obtain k where a_Ik: "a \<in> I(k)" using Union_iff[of a "{I n |n. n \<in> UNIV}"] by auto
  show ?thesis
  proof (rule exI[of _ k], rule)
    show "I k \<subseteq> I (k + 1)" using inc by simp
    show "I (k + 1) \<subseteq> I k"
    proof (auto)
      fix x assume x: "x \<in> I (Suc k)"
      have "ideal_generated {a} = I k"
      proof
        have ideal_Ik: "ideal (I (k))" using all_ideal by simp
        show "I k \<subseteq> ideal_generated {a}" using a by auto
        show "ideal_generated {a} \<subseteq> I k"
          by (metis (lifting) a_Ik all_ideal ideal_generated_def
            le_Inf_iff mem_Collect_eq singleton_iff subsetI)
      qed
      thus "x \<in> I k" using x unfolding a by auto
    qed
  qed
qed

lemma ascending_chain_condition2:
  "\<nexists>I::(nat \<Rightarrow> 'a set). (\<forall>n. ideal (I n) \<and> I n \<subset> I (n + 1))"
proof (rule ccontr, auto)
  fix I assume a: "\<forall>n. ideal (I n) \<and> I n \<subset> I (Suc n)"
  hence "\<forall>n. ideal (I n)" "\<forall>n. I n \<subseteq> I (Suc n)" by auto
  hence "\<exists>n. I(n)=I(n+1)" using ascending_chain_condition by auto
  thus False using a by auto
qed

end

class pir_div = pir + euclidean_semiring
class pid_div = pid + euclidean_semiring

subclass (in pir_div) pid_div
proof qed

subclass (in pir_div) bezout_ring_div
proof qed

subclass (in pid_div) bezout_domain_div
proof qed

subsection\<open>Euclidean Domains\<close>

text\<open>We make use of the euclidean ring (domain) class developed by Manuel Eberl.\<close>

subclass (in euclidean_ring) pid
proof
  fix I assume I: "ideal I"
  show "principal_ideal I"
  proof (cases "I={0}")
    case True show ?thesis unfolding principal_ideal_def True
      using ideal_generated_0 ideal_0 by auto
  next
    case False
    have fI_not_empty: "(euclidean_size` (I-{0}))\<noteq>{}" using False ideal_not_empty[OF I] by auto
    from this obtain d where fd: "euclidean_size d
      = Least (\<lambda>i. i \<in> (euclidean_size`(I-{0})))" and d: "d\<in>(I-{0})"
      by (metis (lifting, mono_tags) LeastI_ex imageE ex_in_conv)
    have d_not_0: "d\<noteq>0" using d by simp
    have fd_le: "\<forall>x\<in>I-{0}. euclidean_size d \<le> euclidean_size x"
      by (metis (mono_tags) Least_le fd image_eqI)
    show "principal_ideal I"
    proof (unfold principal_ideal_def, rule exI[of _ d], auto)
      fix x assume x:"x \<in> ideal_generated {d}" show "x \<in> I"
        using x unfolding ideal_generated_def
        by (auto, metis Diff_iff I d)
    next
      fix a assume a: "a \<in> I"
      obtain q r where "a = q * d + r"
        and fr_fd: "euclidean_size r < euclidean_size d"
        using div_mult_mod_eq [of a d, symmetric] d_not_0 mod_size_less
        by blast
      show "a \<in> ideal_generated {d}"
      proof (cases "r=0")
        case True hence "a = q * d" using \<open>a = q * d + r\<close>
          by auto
        then show ?thesis unfolding ideal_generated_def
          unfolding ideal_def right_ideal_def
          by (simp add: ac_simps)
      next
        case False
        hence r_noteq_0: "r \<noteq> 0" by simp
        have "r = a - d * q" using \<open>a = q * d + r\<close>
          by (simp add: algebra_simps)
        also have "... \<in> I"
        proof (rule left_ideal_minus)
          show "left_ideal I" using I unfolding ideal_def by simp
          show "a \<in> I" using a .
          show "d * q \<in> I" using d I unfolding ideal_def right_ideal_def by simp
        qed
        finally have "r \<in> I-{0}" using r_noteq_0 by auto
        hence "euclidean_size d \<le> euclidean_size r" using fd_le by auto
        thus ?thesis using fr_fd by auto
      qed
    qed
  qed
qed

context euclidean_ring_gcd
begin

text\<open>This is similar to the \<open>euclid_ext\<close> operation, but involving two more parameters
to satisfy that \<open>is_bezout_ext euclid_ext2\<close>\<close>

definition euclid_ext2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a"
  where "euclid_ext2 a b =
   (fst (bezout_coefficients a b), snd (bezout_coefficients a b), - b div gcd a b, a div gcd a b, gcd a b)"

lemma is_bezout_ext_euclid_ext2: "is_bezout_ext (euclid_ext2)"
proof (unfold is_bezout_ext_def Let_def, clarify, intro conjI)
  fix a b p q u v d
  assume e: "euclid_ext2 a b = (p, q, u, v, d)"
  then have "bezout_coefficients a b = (p, q)" and "gcd a b = d"
    by (auto simp add: euclid_ext2_def)
  then show "p * a + q * b = d"
    by (simp add: bezout_coefficients)
  from \<open>gcd a b = d\<close> show "d dvd a" and "d dvd b"
    by auto
  from \<open>gcd a b = d\<close> show "\<forall>d'. d' dvd a \<and> d' dvd b \<longrightarrow> d' dvd d"
    by auto
  have "a div d = v" and "-b div d = u"
    using e by (auto simp add: euclid_ext2_def)
  then show "d * v = a" and "d * u = - b"
    using \<open>d dvd a\<close> and \<open>d dvd b\<close> by auto
qed

lemma is_bezout_euclid_ext: "is_bezout (\<lambda>a b. (fst (bezout_coefficients a b), snd (bezout_coefficients a b), gcd a b))"
  by (auto simp add: is_bezout_def bezout_coefficients)

end

subclass (in euclidean_ring) pid_div ..

subsection\<open>More gcd structures\<close>

text\<open>The following classes represent structures where there exists a gcd
  for each pair of elements and the operation is fixed.\<close>

class pir_gcd = pir + semiring_gcd
class pid_gcd = pid + pir_gcd

subclass (in euclidean_ring_gcd) pid_gcd ..

subsection\<open>Field\<close>

text\<open>Proving that any field is a euclidean domain. There are alternatives to do this,
see @{url "https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2014-October/msg00034.html"}\<close>

(* TODO Remove *)
class field_euclidean = field + euclidean_ring +
  assumes "euclidean_size = (\<lambda>i. if i = 0 then 0 else 1::nat)"
  and "normalisation_factor = id"

end

(*********** Possible future work: ***********)
(*
  - Prime elements, irreducible elements...
  - Prufer Domain, Noetherian...
*)


theory ConcreteSemantics9_1_Ex4
  imports "~~/src/HOL/IMP/Star" Complex_Main
begin

section "A Typed Language"

theory Types imports Star Complex_Main begin

text \<open>We build on \<^theory>\<open>Complex_Main\<close> instead of \<^theory>\<open>Main\<close> to access
the real numbers.\<close>

subsection "Arithmetic Expressions"

datatype val = Iv int | Bv bool

type_synonym vname = string
type_synonym state = "vname \<Rightarrow> val"

text_raw\<open>\snip{aexptDef}{0}{2}{%\<close>
datatype exp =  Ic int | V vname | Plus exp exp | Bc bool | Not exp | And exp exp | Less exp exp
text_raw\<open>}%endsnip\<close>

inductive eval :: "exp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"eval (Ic i) s (Iv i)" |
"eval (V x) s (s x)" |
"eval a1 s (Iv i1) \<Longrightarrow> eval a2 s (Iv i2)
 \<Longrightarrow> eval (Plus a1 a2) s (Iv(i1+i2))" |
"eval (Bc v) s (Bv v)" |
"eval b s (Bv v) \<Longrightarrow> eval (Not b) s (Bv (\<not> v))" |
"eval b1 s (Bv v1) \<Longrightarrow> eval b2 s (Bv v2) \<Longrightarrow> eval (And b1 b2) s (Bv (v1 & v2))" |
"eval a1 s (Iv i1) \<Longrightarrow> eval a2 s (Iv i2) \<Longrightarrow> eval (Less a1 a2) s (Bv (i1 < i2))"

inductive_cases [elim!]:
  "eval (Ic i) s v"
  "eval (V x) s v"
  "eval (Plus a1 a2) s v"
  "eval (Bc b) s v"
  "eval (Not b) s v"
  "eval (And a1 a2) s v"
  "eval (Less a1 a2) s v"

subsection "Syntax of Commands"
(* a copy of Com.thy - keep in sync! *)

datatype
  com = SKIP
      | Assign vname exp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;; _"  [60, 61] 60)
      | If     exp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  exp com         ("WHILE _ DO _"  [0, 61] 61)

subsection "Small-Step Semantics of Commands"

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "eval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |

IfTrue:  "eval b s (Bv True) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
IfFalse: "eval b s (Bv False) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

subsection "The Type System"

datatype ty = Ity | Bty

type_synonym tyenv = "vname \<Rightarrow> ty"

inductive typing :: "tyenv \<Rightarrow> exp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
where
Ic_ty: "\<Gamma> \<turnstile> Ic i : Ity" |
V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
Plus_ty: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : Ity" |
B_ty: "\<Gamma> \<turnstile> Bc v: Bty" |
Not_ty: "\<Gamma> \<turnstile> b:Bty \<Longrightarrow> \<Gamma> \<turnstile> Not b:Bty" |
And_ty: "\<Gamma> \<turnstile> b1:Bty \<Longrightarrow> \<Gamma> \<turnstile> b2:Bty \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2:Bty" |
Less_ty: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2:Bty"

declare typing.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> V x : \<tau>" "\<Gamma> \<turnstile> Ic i : \<tau>" "\<Gamma> \<turnstile> Plus a1 a2 : \<tau>"
 "\<Gamma> \<turnstile> Not b:Bty" "\<Gamma> \<turnstile> And b1 b2:Bty" "\<Gamma> \<turnstile> Less a1 a2:Bty"

text\<open>Warning: the ``:'' notation leads to syntactic ambiguities,
i.e. multiple parse trees, because ``:'' also stands for set membership.
In most situations Isabelle's type system will reject all but one parse tree,
but will still inform you of the potential ambiguity.\<close>

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
Skip_ty: "\<Gamma> \<turnstile> SKIP" |
Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;;c2" |
If_ty: "\<Gamma> \<turnstile> b:Bty \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
While_ty: "\<Gamma> \<turnstile> b:Bty \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c"

declare ctyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
  "\<Gamma> \<turnstile> WHILE b DO c"

subsection "Well-typed Programs Do Not Get Stuck"

fun type :: "val \<Rightarrow> ty" where
"type (Iv i) = Ity" |
"type (Bv b) = Bty"

lemma type_eq_Ity[simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
by (cases v) simp_all

lemma type_eq_Bty[simp]: "type v = Bty \<longleftrightarrow> (\<exists>r. v = Bv r)"
by (cases v) simp_all

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
where "\<Gamma> \<turnstile> s  \<longleftrightarrow>  (\<forall>x. type (s x) = \<Gamma> x)"

lemma apreservation:
  "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> eval a s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
apply(induction arbitrary: v rule: typing.induct)
apply (fastforce simp: styping_def)+
done

lemma aprogress: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. eval a s v"
proof(induction rule: typing.induct)
  case (Ic_ty \<Gamma> i)
  then show ?case by (auto intro: eval.intros)
next
  case (V_ty \<Gamma> x)
  then show ?case  by (auto intro: eval.intros)
next
  case (Plus_ty \<Gamma> a1 a2)
  then obtain v1 v2 where v: "eval a1 s v1" "eval a2 s v2" by blast
  show ?case
  proof (cases v1)
    case Iv
    with Plus_ty v show ?thesis
      by (metis apreservation eval.intros(3) ty.distinct(1) type.cases type.simps(2))
  next
    case Bv
    with Plus_ty v show ?thesis
      using apreservation by fastforce
  qed
next
  case (B_ty \<Gamma> v)
  then show ?case
    using eval.intros(4) by auto
next
  case (Not_ty \<Gamma> b)
  then show ?case
    by (metis apreservation eval.intros(5) type_eq_Bty)
next
  case (And_ty \<Gamma> b1 b2)
  then show ?case
    by (metis apreservation eval.intros(6) type_eq_Bty)
next
  case (Less_ty \<Gamma> a1 a2)
  then show ?case
    by (metis (full_types) apreservation eval.intros(7) type_eq_Ity)
qed

theorem progress:
  "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
proof(induction rule: ctyping.induct)
  case Skip_ty thus ?case by simp
next
  case Assign_ty
  thus ?case by (metis Assign aprogress)
next
  case Seq_ty thus ?case by simp (metis Seq1 Seq2)
next
  case While_ty show ?case by (metis While)
next
  case (If_ty \<Gamma> b c1 c2)
  then obtain bv where bv_def: "eval b s bv" by (metis aprogress)
  then have "type bv = Bty" using apreservation If_ty by blast
  then show ?case sledgehammer
    by (metis (full_types) IfFalse IfTrue bv_def type_eq_Bty)
qed

theorem styping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
proof(induction rule: small_step_induct)
  case Assign thus ?case
    by (auto simp: styping_def) (metis Assign(1,3) apreservation)
qed auto

theorem ctyping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
by (induct rule: small_step_induct) (auto simp: ctyping.intros)

abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

theorem type_sound:
  "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
   \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
apply(induction rule:star_induct)
apply (metis progress)
  by (metis styping_preservation ctyping_preservation)

end


theory ETCS_Nat
  imports ETCS_Func
begin

section \<open>Axiom 10: Natural Number Object\<close>

axiomatization
  natural_numbers :: "cset" ("\<nat>\<^sub>c") and
  zero :: "cfunc" and
  successor :: "cfunc"
  where
  zero_type[type_rule]: "zero \<in>\<^sub>c \<nat>\<^sub>c" and
  successor_type[type_rule]: "successor: \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c" and
  natural_number_object_property:
  "q : one \<rightarrow> X \<Longrightarrow> f: X \<rightarrow> X \<Longrightarrow>
   (\<exists>!u. u: \<nat>\<^sub>c \<rightarrow> X \<and>
   triangle_commutes one \<nat>\<^sub>c X zero u q \<and>
   square_commutes \<nat>\<^sub>c X \<nat>\<^sub>c X u f successor u)"

lemma natural_number_object_property2:
  assumes "q : one \<rightarrow> X" "f: X \<rightarrow> X"
  shows "\<exists>!u. u: \<nat>\<^sub>c \<rightarrow> X \<and> u \<circ>\<^sub>c zero = q \<and> f \<circ>\<^sub>c u = u \<circ>\<^sub>c successor"
  using assms natural_number_object_property[where q=q, where f=f, where X=X]
  unfolding triangle_commutes_def square_commutes_def
  by auto

lemma natural_number_object_func_unique:
  assumes u_type: "u : \<nat>\<^sub>c \<rightarrow> X" and v_type: "v : \<nat>\<^sub>c \<rightarrow> X" and f_type: "f: X \<rightarrow> X"
  assumes zeros_eq: "u \<circ>\<^sub>c zero = v \<circ>\<^sub>c zero"
  assumes u_successor_eq: "u \<circ>\<^sub>c successor = f \<circ>\<^sub>c u"
  assumes v_successor_eq: "v \<circ>\<^sub>c successor = f \<circ>\<^sub>c v"
  shows "u = v"
proof -
  have u_zero_type: "u \<circ>\<^sub>c zero : one \<rightarrow> X"
    using u_type zero_type comp_type by auto
  have triangle_commutes_u: "triangle_commutes one \<nat>\<^sub>c X zero u (u \<circ>\<^sub>c zero)"
    by (simp add: triangle_commutes_def u_type u_zero_type zero_type)
  have square_commutes_u: "square_commutes \<nat>\<^sub>c X \<nat>\<^sub>c X u f successor u"
    by (simp add: f_type square_commutes_def successor_type u_successor_eq u_type)
  have uniqueness: "\<And> w. w: \<nat>\<^sub>c \<rightarrow> X \<and>
   triangle_commutes one \<nat>\<^sub>c X zero w (u \<circ>\<^sub>c zero) \<and>
   square_commutes \<nat>\<^sub>c X \<nat>\<^sub>c X w f successor w \<Longrightarrow> w = u"
    using u_zero_type triangle_commutes_u square_commutes_u
    using natural_number_object_property square_commutes_def by blast

  have v_zero_type: "v \<circ>\<^sub>c zero : one \<rightarrow> X"
    using v_type zero_type comp_type by auto
  have triangle_commutes_v: "triangle_commutes one \<nat>\<^sub>c X zero v (u \<circ>\<^sub>c zero)"
    by (simp add: triangle_commutes_def v_type v_zero_type zero_type zeros_eq)
  have square_commutes_v: "square_commutes \<nat>\<^sub>c X \<nat>\<^sub>c X v f successor v"
    by (simp add: f_type square_commutes_def successor_type v_successor_eq v_type)

  from uniqueness show "u = v"
    using square_commutes_v triangle_commutes_v v_type by blast
qed

definition is_NNO :: "cset \<Rightarrow> cfunc \<Rightarrow> cfunc \<Rightarrow> bool"  where
   "is_NNO Y z s \<longleftrightarrow>(\<forall> X f q. ((q : one \<rightarrow> X) \<and> (f: X \<rightarrow> X))\<longrightarrow>
   (\<exists>!u. u: Y \<rightarrow> X \<and>
   triangle_commutes one Y X z u q \<and>
   square_commutes Y X Y X u f s u))"

lemma N_is_a_NNO:
    "is_NNO \<nat>\<^sub>c zero successor"
  by (simp add: is_NNO_def natural_number_object_property)

(* Exercise 2.6.5 *)
lemma NNOs_are_iso_N:
  assumes "is_NNO N z s"
  shows "N \<cong> \<nat>\<^sub>c"
proof-
  have z_and_s_type: "(z : one \<rightarrow>  N) \<and> (s:  N \<rightarrow>  N)"
    using assms is_NNO_def square_commutes_def successor_type triangle_commutes_def zero_type by auto
  then obtain u where u_type: "(u: \<nat>\<^sub>c \<rightarrow> N \<and>
   triangle_commutes one \<nat>\<^sub>c N zero u z \<and>
   square_commutes \<nat>\<^sub>c N \<nat>\<^sub>c N u s successor u)"
      proof -
         assume "\<And>u. u : \<nat>\<^sub>c \<rightarrow> N \<and> triangle_commutes one \<nat>\<^sub>c N zero u z \<and> square_commutes \<nat>\<^sub>c N \<nat>\<^sub>c N u s successor u \<Longrightarrow> thesis"
         then show ?thesis
           using z_and_s_type natural_number_object_property by blast
      qed
  then obtain v where v_type: "(v: N \<rightarrow> \<nat>\<^sub>c \<and>
   triangle_commutes one N  \<nat>\<^sub>c z v zero \<and>
   square_commutes N  \<nat>\<^sub>c N  \<nat>\<^sub>c v successor s v)"
     using assms is_NNO_def successor_type zero_type by blast
  then have vuzeroEqzero: "v \<circ>\<^sub>c (u \<circ>\<^sub>c zero) = zero"
     using  u_type triangle_commutes_def by auto
  have id_facts1: "(id(\<nat>\<^sub>c): \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c)\<and>
          (triangle_commutes one \<nat>\<^sub>c \<nat>\<^sub>c zero (id(\<nat>\<^sub>c)) zero)\<and>
          (square_commutes \<nat>\<^sub>c \<nat>\<^sub>c \<nat>\<^sub>c \<nat>\<^sub>c (id(\<nat>\<^sub>c)) successor successor (id(\<nat>\<^sub>c)))"
     by (metis cfunc_type_def id_left_unit id_right_unit id_type square_commutes_def successor_type triangle_commutes_def zero_type)
  then have vu_facts: "((v \<circ>\<^sub>c u): \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c)\<and>
          (triangle_commutes one \<nat>\<^sub>c \<nat>\<^sub>c zero (v \<circ>\<^sub>c u) zero)\<and>
          (square_commutes \<nat>\<^sub>c \<nat>\<^sub>c \<nat>\<^sub>c \<nat>\<^sub>c (v \<circ>\<^sub>c u) successor successor (v \<circ>\<^sub>c u))"
  proof auto
    show vu_type: "v \<circ>\<^sub>c u : \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c"
      using comp_type u_type v_type by blast
    show "triangle_commutes one \<nat>\<^sub>c \<nat>\<^sub>c zero (v \<circ>\<^sub>c u) zero"
      using comp_associative2 comp_type triangle_commutes_def u_type v_type by auto
    show "square_commutes \<nat>\<^sub>c \<nat>\<^sub>c \<nat>\<^sub>c \<nat>\<^sub>c (v \<circ>\<^sub>c u) successor successor (v \<circ>\<^sub>c u)"
      by (metis vu_type cfunc_type_def comp_associative square_commutes_def u_type v_type)
  qed
  then have half_isomorphism: "(v \<circ>\<^sub>c u) = id(\<nat>\<^sub>c)"
      using id_facts1 natural_number_object_property successor_type zero_type by blast
  have uvzEqz: "u \<circ>\<^sub>c (v \<circ>\<^sub>c z) = z"
    using triangle_commutes_def u_type v_type by auto
  have id_facts2: "(id(N): N \<rightarrow> N)\<and>
          (triangle_commutes one N N z (id(N)) z)\<and>
          (square_commutes N N N N (id(N)) s s (id(N)))"
    by (metis cfunc_type_def id_left_unit id_right_unit id_type square_commutes_def triangle_commutes_def z_and_s_type)
  then have uv_facts: "((u \<circ>\<^sub>c v): N \<rightarrow> N)\<and>
          (triangle_commutes one N N z (u \<circ>\<^sub>c v) z)\<and>
          (square_commutes N N N N (u \<circ>\<^sub>c v) s s (u \<circ>\<^sub>c v))"
    proof -
      have "u \<circ>\<^sub>c v : N \<rightarrow> N"
        using cfunc_type_def codomain_comp domain_comp u_type v_type by presburger
      then show ?thesis
        by (metis cfunc_type_def comp_associative triangle_commutes_def square_commutes_def u_type v_type)
    qed
  then have half_isomorphism2: "(u \<circ>\<^sub>c v) = id(N)"
    using assms id_facts2 is_NNO_def z_and_s_type by blast
  then show "N \<cong> \<nat>\<^sub>c"
    using cfunc_type_def half_isomorphism is_isomorphic_def isomorphism_def u_type v_type by fastforce
qed

(* Converse to Exercise 2.6.5 *)
lemma Iso_to_N_is_NNO:
  assumes "N \<cong> \<nat>\<^sub>c"
  shows "\<exists> z s. is_NNO N z s"
proof -
  obtain i where i_type: "i: N \<rightarrow> \<nat>\<^sub>c \<and> isomorphism(i)"
    using assms is_isomorphic_def by auto
  obtain j where j_type: "j: \<nat>\<^sub>c \<rightarrow> N \<and> isomorphism(j) \<and> i \<circ>\<^sub>c j = id(\<nat>\<^sub>c) \<and> j \<circ>\<^sub>c i = id(N)"
    using cfunc_type_def i_type isomorphism_def by fastforce
  obtain z where z_form: "z = j \<circ>\<^sub>c zero"
    by simp
  obtain s where s_form: "s = (j \<circ>\<^sub>c successor)  \<circ>\<^sub>c i"
    by simp
  have z_type: "z: one \<rightarrow> N"
    using comp_type j_type z_form zero_type by blast
  have s_type: "s: N \<rightarrow> N"
    using cfunc_type_def codomain_comp domain_comp i_type j_type s_form successor_type by auto
  have "is_NNO N z s"
    unfolding is_NNO_def
  proof auto
    fix X q f
    assume q_type: "q: one \<rightarrow> X"
    assume f_type: "f:   X \<rightarrow> X"

    obtain u where u_properties: "
     (u: \<nat>\<^sub>c \<rightarrow> X \<and>
   triangle_commutes one \<nat>\<^sub>c X zero u q \<and>
   square_commutes \<nat>\<^sub>c X \<nat>\<^sub>c X u f successor u)"
      using f_type natural_number_object_property q_type by blast
    obtain v where v_Eqs_ui: "v = u \<circ>\<^sub>c i"
      by simp
    then have v_type: "v: N \<rightarrow> X"
      using comp_type i_type u_properties by blast
    then have D2_triangle: "v \<circ>\<^sub>c z = q"
      by (metis cfunc_type_def comp_associative i_type id_right_unit2 j_type triangle_commutes_def u_properties v_Eqs_ui z_form)

    have D2_square: "v \<circ>\<^sub>c s = f \<circ>\<^sub>c v"
      by (metis cfunc_type_def codomain_comp comp_associative i_type id_right_unit2 j_type s_form
          square_commutes_def u_properties v_Eqs_ui v_type)

    show unique_v: "\<And> w y. w : N \<rightarrow> X \<Longrightarrow> y : N \<rightarrow> X \<Longrightarrow>
       triangle_commutes one N X z w q \<Longrightarrow> square_commutes N X N X w f s w \<Longrightarrow>
       triangle_commutes one N X z y q \<Longrightarrow> square_commutes N X N X y f s y \<Longrightarrow> w = y"
    proof -
      fix w y
      assume w_type: "w: N \<rightarrow> X"
      assume "square_commutes N X N X w f s w"
      then have w_square:"w \<circ>\<^sub>c s = f \<circ>\<^sub>c w"
        by (simp add: square_commutes_def)
      assume "triangle_commutes one N X z w q"
      then have w_triangle: "q = w \<circ>\<^sub>c z"
        by (simp add: triangle_commutes_def)

      assume y_type: "y: N \<rightarrow> X"
      assume "square_commutes N X N X y f s y"
      then have y_square:"y \<circ>\<^sub>c s = f \<circ>\<^sub>c y"
        by (simp add: square_commutes_def)
      assume "triangle_commutes one N X z y q"
      then have y_triangle: "q = y \<circ>\<^sub>c z"
        by (simp add: triangle_commutes_def)

      have "\<And> w. w: N \<rightarrow> X \<Longrightarrow> w \<circ>\<^sub>c s = f \<circ>\<^sub>c w \<Longrightarrow> q = w \<circ>\<^sub>c z \<Longrightarrow> w = v"
      proof -
        fix w
        assume w_type: "w: N \<rightarrow> X"
        assume w_square:"w \<circ>\<^sub>c s = f \<circ>\<^sub>c w"
        assume w_triangle: "q = w \<circ>\<^sub>c z"

        have fact1: "(w \<circ>\<^sub>c j): \<nat>\<^sub>c \<rightarrow> X"
          by (meson comp_type j_type w_type)
        then have fact2: "triangle_commutes one \<nat>\<^sub>c X zero (w \<circ>\<^sub>c j) q"
          using comp_associative2 j_type q_type triangle_commutes_def w_triangle w_type z_form zero_type by auto
        then have fact3: "square_commutes \<nat>\<^sub>c X \<nat>\<^sub>c X (w \<circ>\<^sub>c j) f successor (w \<circ>\<^sub>c j)"
        proof -
          have "successor = successor \<circ>\<^sub>c i \<circ>\<^sub>c j"
            by (metis (no_types) cfunc_type_def id_right_unit j_type successor_type)
          then show ?thesis
            by (metis cfunc_type_def codomain_comp comp_associative domain_comp f_type i_type j_type s_form square_commutes_def successor_type w_square w_type)
        qed
        then have fact4: "(w \<circ>\<^sub>c j)\<circ>\<^sub>c successor = (f \<circ>\<^sub>c w) \<circ>\<^sub>c j"
          using comp_associative2 j_type square_commutes_def w_type by auto
        then have wj_Eqs_u: "w \<circ>\<^sub>c j = u"
          using f_type fact1 fact2 fact3 natural_number_object_property q_type u_properties by blast
        then show "w = v"
          by (smt comp_associative2 i_type id_right_unit2 j_type v_Eqs_ui w_type)
      qed
      then show "w = y"
        using w_square w_triangle w_type y_square y_triangle y_type by blast
    qed
    show "\<exists>u. u : N \<rightarrow> X \<and> triangle_commutes one N X z u q \<and> square_commutes N X N X u f s u"
      using D2_square D2_triangle f_type q_type s_type square_commutes_def triangle_commutes_def v_type z_type by auto
  qed
  then show "\<exists>z s. is_NNO N z s"
    by auto
qed

lemma zero_is_not_successor:
  assumes "n \<in>\<^sub>c \<nat>\<^sub>c"
  shows "zero \<noteq> successor \<circ>\<^sub>c n"
proof (rule ccontr, auto)
  assume for_contradiction: "zero = successor \<circ>\<^sub>c n"
  have "\<exists>!u. u: \<nat>\<^sub>c \<rightarrow> \<Omega> \<and> u \<circ>\<^sub>c zero = \<t> \<and> (\<f> \<circ>\<^sub>c \<beta>\<^bsub>\<Omega>\<^esub>) \<circ>\<^sub>c u = u \<circ>\<^sub>c successor"
    by (typecheck_cfuncs, rule natural_number_object_property2)
  then obtain u where  u_type:  "u: \<nat>\<^sub>c \<rightarrow> \<Omega>" and
                       u_triangle: "u \<circ>\<^sub>c zero = \<t>" and
                       u_square: "(\<f> \<circ>\<^sub>c \<beta>\<^bsub>\<Omega>\<^esub>) \<circ>\<^sub>c u = u \<circ>\<^sub>c successor"
    by auto
  have "\<t> = \<f>"
  proof -
    have "\<t> = u  \<circ>\<^sub>c zero"
      by (simp add: u_triangle)
    also have "... = u \<circ>\<^sub>c successor \<circ>\<^sub>c n"
      by (simp add: for_contradiction)
    also have "... = (\<f> \<circ>\<^sub>c \<beta>\<^bsub>\<Omega>\<^esub>) \<circ>\<^sub>c u \<circ>\<^sub>c n"
      using assms u_type by (typecheck_cfuncs, simp add:  comp_associative2 u_square)
    also have "... = \<f>"
      using assms u_type by (typecheck_cfuncs, metis cfunc_type_def comp_associative id_right_unit2 id_type terminal_func_comp terminal_func_unique)
    then show ?thesis using calculation by auto
  qed
  then show False
    using true_false_distinct by blast
qed

(* Proposition 2.6.6 *)
lemma  oneUN_iso_N_isomorphism:
 "isomorphism(zero \<amalg> successor)"
proof -
 have iso_type: "zero \<amalg> successor : one \<Coprod> \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c"
   by (simp add: cfunc_coprod_type successor_type zero_type)
  obtain i0 where coproj0:  "i0 = left_coproj one \<nat>\<^sub>c"
    by simp
  obtain i1 where coproj1:  "i1 = right_coproj one \<nat>\<^sub>c"
    by simp
  have i1zUi1s_type: "(i1 \<circ>\<^sub>c zero) \<amalg> (i1 \<circ>\<^sub>c successor) : one \<Coprod> \<nat>\<^sub>c \<rightarrow> one \<Coprod> \<nat>\<^sub>c"
    using cfunc_coprod_type coproj1 right_proj_type successor_type zero_type comp_type by auto
  have i1z_type: "i1 \<circ>\<^sub>c zero : one \<rightarrow>  one \<Coprod> \<nat>\<^sub>c"
    using coproj1 right_proj_type zero_type comp_type by auto
  obtain g where g_type: "g: \<nat>\<^sub>c \<rightarrow> (one \<Coprod> \<nat>\<^sub>c)" and
   g_triangle: "triangle_commutes one \<nat>\<^sub>c (one \<Coprod> \<nat>\<^sub>c) zero g i0" and
   g_square: "square_commutes \<nat>\<^sub>c \<nat>\<^sub>c (one \<Coprod> \<nat>\<^sub>c)  (one \<Coprod> \<nat>\<^sub>c) successor g g ((i1 \<circ>\<^sub>c zero) \<amalg> (i1 \<circ>\<^sub>c successor))"
    by (metis coproj0 i1zUi1s_type left_proj_type natural_number_object_property square_commutes_def)
  then have second_diagram1: "g\<circ>\<^sub>c zero = i0"
    by (simp add: triangle_commutes_def)
  have second_diagram2: "g \<circ>\<^sub>c successor =   ((i1 \<circ>\<^sub>c zero) \<amalg> (i1 \<circ>\<^sub>c successor)) \<circ>\<^sub>c g"
    using g_square unfolding square_commutes_def by auto
  then have second_diagram3: "g \<circ>\<^sub>c (successor \<circ>\<^sub>c zero)  = (i1 \<circ>\<^sub>c zero)"
    using g_type i1z_type
    by (typecheck_cfuncs, smt cfunc_coprod_comp comp_associative2 coproj0 coproj1 i1zUi1s_type
        iso_type left_coproj_cfunc_coprod left_proj_type right_proj_type second_diagram1 second_diagram2)
  then have g_s_s_Eqs_i1zUi1s_g_s:
    "(g \<circ>\<^sub>c successor) \<circ>\<^sub>c successor = ((i1 \<circ>\<^sub>c zero) \<amalg> (i1 \<circ>\<^sub>c successor)) \<circ>\<^sub>c (g \<circ>\<^sub>c successor)"
    using comp_associative2 g_type i1zUi1s_type second_diagram2 successor_type by fastforce
  then have g_s_s_zEqs_i1zUi1s_i1z: "((g \<circ>\<^sub>c successor) \<circ>\<^sub>c successor)\<circ>\<^sub>c zero =
    ((i1 \<circ>\<^sub>c zero) \<amalg> (i1 \<circ>\<^sub>c successor)) \<circ>\<^sub>c (i1 \<circ>\<^sub>c zero)"
    by (smt cfunc_type_def codomain_comp comp_associative domain_comp g_type i1zUi1s_type second_diagram3 successor_type zero_type)

  then have i1_sEqs_i1zUi1s_i1: "i1 \<circ>\<^sub>c successor =
    ((i1 \<circ>\<^sub>c zero) \<amalg> (i1 \<circ>\<^sub>c successor)) \<circ>\<^sub>c i1"
    by (metis comp_type coproj1 i1z_type right_coproj_cfunc_coprod right_proj_type successor_type)
  then obtain u where u_type: "(u: \<nat>\<^sub>c \<rightarrow> (one \<Coprod> \<nat>\<^sub>c))" and
      u_triangle: "(triangle_commutes one \<nat>\<^sub>c (one \<Coprod> \<nat>\<^sub>c) zero u (i1 \<circ>\<^sub>c zero))" and
      u_square: "(square_commutes \<nat>\<^sub>c \<nat>\<^sub>c (one \<Coprod> \<nat>\<^sub>c)  (one \<Coprod> \<nat>\<^sub>c) successor u u ((i1 \<circ>\<^sub>c zero) \<amalg> (i1 \<circ>\<^sub>c successor)))"
    using comp_type coproj1 i1zUi1s_type right_proj_type square_commutes_def successor_type triangle_commutes_def zero_type by fastforce
  then have u_Eqs_i1: "u=i1"
    by (metis coproj1 i1_sEqs_i1zUi1s_i1 natural_number_object_property right_proj_type square_commutes_def triangle_commutes_def)
  then have g_s_type: "g\<circ>\<^sub>c successor: \<nat>\<^sub>c \<rightarrow> (one \<Coprod> \<nat>\<^sub>c)"
    using comp_type g_type successor_type by blast
  then have g_s_triangle:
  "triangle_commutes one \<nat>\<^sub>c (one \<Coprod> \<nat>\<^sub>c) zero (g\<circ>\<^sub>c successor) ( (i1 \<circ>\<^sub>c zero))"
    using comp_associative2 g_type i1z_type second_diagram3 successor_type triangle_commutes_def zero_type by auto
  then have g_s_square:
"square_commutes \<nat>\<^sub>c \<nat>\<^sub>c (one \<Coprod> \<nat>\<^sub>c)  (one \<Coprod> \<nat>\<^sub>c) successor  (g\<circ>\<^sub>c successor)  (g\<circ>\<^sub>c successor) ((i1 \<circ>\<^sub>c zero) \<amalg> (i1 \<circ>\<^sub>c successor))"
    by (simp add: g_s_s_Eqs_i1zUi1s_g_s g_s_type i1zUi1s_type square_commutes_def successor_type)
  then have u_Eqs_g_s: "u=(g\<circ>\<^sub>c successor)"
    using g_s_s_Eqs_i1zUi1s_g_s g_s_triangle i1_sEqs_i1zUi1s_i1 i1zUi1s_type natural_number_object_func_unique triangle_commutes_def u_Eqs_i1 u_type by blast
  then have g_sEqs_i1: "(g\<circ>\<^sub>c successor) = i1"
    using u_Eqs_i1 by blast
  then have eq1: "(zero \<amalg> successor) \<circ>\<^sub>c g = id(\<nat>\<^sub>c)"
  proof -
    have firstCenteredEqn1: "(zero \<amalg> successor) \<circ>\<^sub>c (g \<circ>\<^sub>c zero) =
                            (zero \<amalg> successor) \<circ>\<^sub>c i0"
      using second_diagram1 by auto
    also have firstCenteredEqn2:  "... = zero"
      using coproj0 left_coproj_cfunc_coprod successor_type zero_type by auto
    then have firstCenteredEqn: "(zero \<amalg> successor) \<circ>\<^sub>c (g \<circ>\<^sub>c zero) = zero"
      by (simp add: firstCenteredEqn1)
    have secondCenteredEqn1: "(zero \<amalg> successor) \<circ>\<^sub>c (g \<circ>\<^sub>c successor) =
                            (zero \<amalg> successor) \<circ>\<^sub>c i1"
      using g_sEqs_i1 by blast
    have secondCenteredEqn: "(zero \<amalg> successor) \<circ>\<^sub>c (g \<circ>\<^sub>c successor) = successor"
      using coproj1 right_coproj_cfunc_coprod secondCenteredEqn1 successor_type zero_type by auto
    then show "(zero \<amalg> successor) \<circ>\<^sub>c g = id(\<nat>\<^sub>c)"
    proof -
        have f1: "\<forall>c ca cb. (c : ca \<rightarrow> cb) = (domain c = ca \<and> codomain c = cb)"
           using cfunc_type_def by blast
        then have f2: "domain successor = \<nat>\<^sub>c \<and> codomain successor = \<nat>\<^sub>c"
           using successor_type by presburger
        have f3: "domain successor = \<nat>\<^sub>c \<and> codomain successor = \<nat>\<^sub>c"
           using f1 successor_type by presburger
        have f5: "domain i1 = \<nat>\<^sub>c \<and> codomain i1 = one \<Coprod> \<nat>\<^sub>c"
           using f1 g_sEqs_i1 g_s_type by presburger
        have "i1 \<circ>\<^sub>c zero \<amalg> successor \<circ>\<^sub>c g = (i1 \<circ>\<^sub>c zero) \<amalg> (i1 \<circ>\<^sub>c successor) \<circ>\<^sub>c g"
          using cfunc_coprod_comp comp_associative f1 g_sEqs_i1 g_s_type g_type iso_type successor_type zero_type by auto
        then have "i1 \<circ>\<^sub>c zero \<amalg> successor \<circ>\<^sub>c g = i1 \<circ>\<^sub>c id\<^sub>c \<nat>\<^sub>c"
          by (metis f5 g_sEqs_i1 id_right_unit second_diagram2)
        then show ?thesis
          by (smt cfunc_type_def comp_type coproj1 f5 g_type id_codomain iso_type monomorphism_def right_coproj_are_monomorphisms)
    qed
  qed
  then have eq2: "g \<circ>\<^sub>c (zero \<amalg> successor) = id(one \<Coprod> \<nat>\<^sub>c)"
  proof -
    have ThirdCenteredEqn1: "g \<circ>\<^sub>c ((zero \<amalg> successor)  \<circ>\<^sub>c i0) = g \<circ>\<^sub>c zero"
      using coproj0 left_coproj_cfunc_coprod successor_type zero_type by auto
    also have ThirdCenteredEqn2: "... = i0"
      by (simp add: second_diagram1)
    then have ThirdCenteredEqn: "g \<circ>\<^sub>c ((zero \<amalg> successor)  \<circ>\<^sub>c i0) = i0"
      by (simp add: calculation)
    have ForthCenteredEqn1: "g \<circ>\<^sub>c ((zero \<amalg> successor)  \<circ>\<^sub>c i1) = g \<circ>\<^sub>c successor"
      using coproj1 right_coproj_cfunc_coprod successor_type zero_type by auto
    have ForthCenteredEqn2: "... = i1"
      using g_sEqs_i1 by blast
    then have ForthCenteredEqn: "g \<circ>\<^sub>c ((zero \<amalg> successor)  \<circ>\<^sub>c i1) = i1"
      using ForthCenteredEqn1 by blast
    then show "g \<circ>\<^sub>c (zero \<amalg> successor) = id(one \<Coprod> \<nat>\<^sub>c)"
      using g_type by (typecheck_cfuncs, smt cfunc_coprod_comp cfunc_coprod_unique coproj0 coproj1
          id_left_unit2 left_proj_type second_diagram1 u_Eqs_g_s u_Eqs_i1 u_type)
  qed
  show "isomorphism(zero \<amalg> successor)"
    using eq1 eq2 cfunc_type_def g_type iso_type isomorphism_def by auto
qed

lemma zUs_epic:
 "epimorphism(zero \<amalg> successor)"
  by (simp add: iso_imp_epi_and_monic oneUN_iso_N_isomorphism)

lemma zUs_surj:
 "surjective(zero \<amalg> successor)"
  by (simp add: cfunc_type_def epi_is_surj zUs_epic)

definition predecessor :: "cfunc" where
  "predecessor = (THE f. f : \<nat>\<^sub>c \<rightarrow> one \<Coprod> \<nat>\<^sub>c
    \<and> f \<circ>\<^sub>c (zero \<amalg> successor) = id (one \<Coprod> \<nat>\<^sub>c) \<and>  (zero \<amalg> successor) \<circ>\<^sub>c f = id \<nat>\<^sub>c)"

lemma predecessor_def2:
  "predecessor : \<nat>\<^sub>c \<rightarrow> one \<Coprod> \<nat>\<^sub>c \<and> predecessor \<circ>\<^sub>c (zero \<amalg> successor) = id (one \<Coprod> \<nat>\<^sub>c)
    \<and> (zero \<amalg> successor) \<circ>\<^sub>c predecessor = id \<nat>\<^sub>c"
proof (unfold predecessor_def, rule theI', auto)
  show "\<exists>x. x : \<nat>\<^sub>c \<rightarrow> one \<Coprod> \<nat>\<^sub>c \<and>
        x \<circ>\<^sub>c zero \<amalg> successor = id\<^sub>c (one \<Coprod> \<nat>\<^sub>c) \<and> zero \<amalg> successor \<circ>\<^sub>c x = id\<^sub>c \<nat>\<^sub>c"
    using oneUN_iso_N_isomorphism by (typecheck_cfuncs, unfold isomorphism_def cfunc_type_def, auto)
next
  fix x y
  assume x_type[type_rule]: "x : \<nat>\<^sub>c \<rightarrow> one \<Coprod> \<nat>\<^sub>c" and y_type[type_rule]: "y : \<nat>\<^sub>c \<rightarrow> one \<Coprod> \<nat>\<^sub>c"
  assume x_left_inv: "zero \<amalg> successor \<circ>\<^sub>c x = id\<^sub>c \<nat>\<^sub>c"
  assume "x \<circ>\<^sub>c zero \<amalg> successor = id\<^sub>c (one \<Coprod> \<nat>\<^sub>c)" "y \<circ>\<^sub>c zero \<amalg> successor = id\<^sub>c (one \<Coprod> \<nat>\<^sub>c)"
  then have "x \<circ>\<^sub>c zero \<amalg> successor = y \<circ>\<^sub>c zero \<amalg> successor"
    by auto
  then have "x \<circ>\<^sub>c zero \<amalg> successor \<circ>\<^sub>c x = y \<circ>\<^sub>c zero \<amalg> successor \<circ>\<^sub>c x"
    by (typecheck_cfuncs, auto simp add: comp_associative2)
  then show "x = y"
    using id_right_unit2 x_left_inv x_type y_type by auto
qed

lemma predecessor_type[type_rule]:
  "predecessor : \<nat>\<^sub>c \<rightarrow> one \<Coprod> \<nat>\<^sub>c"
  by (simp add: predecessor_def2)

lemma predecessor_left_inv:
  "(zero \<amalg> successor) \<circ>\<^sub>c predecessor = id \<nat>\<^sub>c"
  by (simp add: predecessor_def2)

lemma predecessor_right_inv:
  "predecessor \<circ>\<^sub>c (zero \<amalg> successor) = id (one \<Coprod> \<nat>\<^sub>c)"
  by (simp add: predecessor_def2)

lemma predecessor_successor:
  "predecessor \<circ>\<^sub>c successor = right_coproj one \<nat>\<^sub>c"
proof -
  have "predecessor \<circ>\<^sub>c successor = predecessor \<circ>\<^sub>c (zero \<amalg> successor) \<circ>\<^sub>c right_coproj one \<nat>\<^sub>c"
    using right_coproj_cfunc_coprod by (typecheck_cfuncs, auto)
  also have "... = (predecessor \<circ>\<^sub>c (zero \<amalg> successor)) \<circ>\<^sub>c right_coproj one \<nat>\<^sub>c"
    by (typecheck_cfuncs, auto simp add: comp_associative2)
  also have "... = right_coproj one \<nat>\<^sub>c"
    by (typecheck_cfuncs, simp add: id_left_unit2 predecessor_def2)
  then show ?thesis
    using calculation by auto
qed

lemma predecessor_zero:
  "predecessor \<circ>\<^sub>c zero = left_coproj one \<nat>\<^sub>c"
proof -
  have "predecessor \<circ>\<^sub>c zero = predecessor \<circ>\<^sub>c (zero \<amalg> successor) \<circ>\<^sub>c left_coproj one \<nat>\<^sub>c"
    using left_coproj_cfunc_coprod by (typecheck_cfuncs, auto)
  also have "... = (predecessor \<circ>\<^sub>c (zero \<amalg> successor)) \<circ>\<^sub>c left_coproj one \<nat>\<^sub>c"
    by (typecheck_cfuncs, auto simp add: comp_associative2)
  also have "... = left_coproj one \<nat>\<^sub>c"
    by (typecheck_cfuncs, simp add: id_left_unit2 predecessor_def2)
  then show ?thesis
    using calculation by auto
qed

lemma nonzero_is_succ_pre:
  assumes "x \<in>\<^sub>c  (one \<Coprod> \<nat>\<^sub>c)"
  shows "(x = (left_coproj one \<nat>\<^sub>c) \<circ>\<^sub>c id one) \<or>
         (\<exists>n. (n \<in>\<^sub>c \<nat>\<^sub>c) \<and> (x = (right_coproj one \<nat>\<^sub>c) \<circ>\<^sub>c n ))"
proof(auto)
  assume not_this: "\<forall> n. n \<in>\<^sub>c  \<nat>\<^sub>c  \<longrightarrow>  x \<noteq> right_coproj one \<nat>\<^sub>c \<circ>\<^sub>c n"
  show "x = left_coproj one \<nat>\<^sub>c  \<circ>\<^sub>c  id one"
    using assms not_this coprojs_jointly_surj one_unique_element by (typecheck_cfuncs, blast)
qed

lemma nonzero_is_succ:
  assumes "k \<in>\<^sub>c \<nat>\<^sub>c"
  assumes "k \<noteq> zero"
  shows "\<exists>n.(n\<in>\<^sub>c \<nat>\<^sub>c \<and> k = successor \<circ>\<^sub>c n)"
proof -
  have x_exists: "\<exists>x. ((x \<in>\<^sub>c one \<Coprod> \<nat>\<^sub>c) \<and> (zero \<amalg> successor \<circ>\<^sub>c x = k))"
    using assms cfunc_type_def surjective_def zUs_surj by (typecheck_cfuncs, auto)
  obtain x where x_def: "((x \<in>\<^sub>c one \<Coprod> \<nat>\<^sub>c) \<and> (zero \<amalg> successor \<circ>\<^sub>c x = k))"
    using x_exists by blast
  have cases:  "(x = (left_coproj one \<nat>\<^sub>c) \<circ>\<^sub>c id one) \<or>
                (\<exists>n. (n \<in>\<^sub>c \<nat>\<^sub>c \<and> x = (right_coproj one \<nat>\<^sub>c) \<circ>\<^sub>c n))"
    by (simp add: nonzero_is_succ_pre x_def)
  have not_case_1: "x \<noteq> (left_coproj one \<nat>\<^sub>c) \<circ>\<^sub>c id one"
  proof(rule ccontr,auto)
    assume bwoc: "x = left_coproj one \<nat>\<^sub>c \<circ>\<^sub>c id\<^sub>c one"
    have contradiction: "k = zero"
      by (metis bwoc id_right_unit2 left_coproj_cfunc_coprod left_proj_type successor_type x_def zero_type)
    show False
      using contradiction assms(2) by force
  qed
  then obtain n where n_def: "n \<in>\<^sub>c \<nat>\<^sub>c \<and> x = (right_coproj one \<nat>\<^sub>c) \<circ>\<^sub>c n"
    using cases by blast
  then have "k = zero \<amalg> successor \<circ>\<^sub>c x"
    using x_def by blast
  also have "... = zero \<amalg> successor \<circ>\<^sub>c  right_coproj one \<nat>\<^sub>c \<circ>\<^sub>c n"
    by (simp add: n_def)
  also have "... =  (zero \<amalg> successor \<circ>\<^sub>c  right_coproj one \<nat>\<^sub>c) \<circ>\<^sub>c n"
    using cfunc_coprod_type cfunc_type_def comp_associative n_def right_proj_type successor_type zero_type by auto
  also have "... = successor \<circ>\<^sub>c n"
    using right_coproj_cfunc_coprod successor_type zero_type by auto
  then show ?thesis
    using   calculation n_def by auto
qed

(* Corollary *)
lemma oneUN_iso_N:
  "one \<Coprod> \<nat>\<^sub>c \<cong> \<nat>\<^sub>c"
  using cfunc_coprod_type is_isomorphic_def oneUN_iso_N_isomorphism successor_type zero_type by blast

lemma NUone_iso_N:
  "\<nat>\<^sub>c \<Coprod> one \<cong> \<nat>\<^sub>c"
  using coproduct_commutes isomorphic_is_transitive oneUN_iso_N by blast

(* Proposition 2.6.7 *)
lemma Peano's_Axioms:
 "injective(successor) \<and> \<not>surjective(successor)"
proof -
  have i1_mono: "monomorphism(right_coproj one \<nat>\<^sub>c)"
    by (simp add: right_coproj_are_monomorphisms)
  have zUs_iso: "isomorphism(zero \<amalg> successor)"
    using oneUN_iso_N_isomorphism by blast
  have zUsi1EqsS: "(zero \<amalg> successor) \<circ>\<^sub>c (right_coproj one \<nat>\<^sub>c) = successor"
    using right_coproj_cfunc_coprod successor_type zero_type by auto
  then have succ_mono: "monomorphism(successor)"
    by (metis cfunc_coprod_type cfunc_type_def composition_of_monic_pair_is_monic i1_mono iso_imp_epi_and_monic oneUN_iso_N_isomorphism right_proj_type successor_type zero_type)
  have f_fact: "(\<f>\<circ>\<^sub>c\<beta>\<^bsub>\<Omega>\<^esub>): \<Omega> \<rightarrow> \<Omega>"
    using comp_type false_func_type terminal_func_type by blast
  then obtain u where u_form: "(u:  \<nat>\<^sub>c  \<rightarrow> \<Omega>) \<and>
   (triangle_commutes one  \<nat>\<^sub>c \<Omega> zero u \<t>) \<and>
   (square_commutes \<nat>\<^sub>c \<Omega> \<nat>\<^sub>c \<Omega> u (\<f>\<circ>\<^sub>c\<beta>\<^bsub>\<Omega>\<^esub>) successor u)"
    using natural_number_object_property true_func_type by blast
  have s_not_surj: "\<not>(surjective(successor))"
    proof (rule ccontr, auto)
      assume BWOC : "surjective(successor)"
      obtain n where snEqz: "successor \<circ>\<^sub>c n = zero" and n_type: "n : one \<rightarrow> \<nat>\<^sub>c"
        using BWOC cfunc_type_def successor_type surjective_def zero_type by auto
      then show False
        by (metis zero_is_not_successor)
    qed
  then show "injective successor \<and> \<not> surjective successor"
    using monomorphism_imp_injective succ_mono by blast
qed

lemma succ_inject:
  assumes "n \<in>\<^sub>c \<nat>\<^sub>c" "m \<in>\<^sub>c \<nat>\<^sub>c"
  shows "successor \<circ>\<^sub>c n = successor \<circ>\<^sub>c m \<Longrightarrow> n=m"
  by (metis Peano's_Axioms assms cfunc_type_def injective_def successor_type)

(* Definition 2.6.9 is in Countable.thy *)

(* Exercise 2.6.11 is in Countable.thy *)

(* Definition 2.6.12 *)
definition fixed_point :: "cfunc \<Rightarrow> cfunc \<Rightarrow> bool" where
  "fixed_point a g \<longleftrightarrow> (\<exists> A. g : A \<rightarrow> A \<and> a \<in>\<^sub>c A \<and> g \<circ>\<^sub>c a = g)"
definition has_fixed_point :: "cfunc \<Rightarrow> bool" where
  "has_fixed_point g \<longleftrightarrow> (\<exists> a. fixed_point a g)"
definition fixed_point_property :: "cset \<Rightarrow> bool" where
  "fixed_point_property A \<longleftrightarrow> (\<forall> g. g : A \<rightarrow> A \<longrightarrow> has_fixed_point g)"

(* Exercise 2.6.15 *)
lemma inject_into_powerset:
  "(\<exists> f.((f : X \<rightarrow> \<P> X) \<and> injective(f)))"
proof -
  obtain \<delta> where delta_def: "\<delta> = diagonal(X)"
    by simp
  have \<delta>_type: "\<delta> : X \<rightarrow> X \<times>\<^sub>c X"
    by (simp add: cfunc_prod_type delta_def diagonal_def id_type)
  have \<delta>_mono: "monomorphism(\<delta>)"
    by (metis \<delta>_type cfunc_type_def comp_monic_imp_monic delta_def diagonal_def id_isomorphism id_type iso_imp_epi_and_monic right_cart_proj_cfunc_prod right_cart_proj_type)
  obtain \<chi>\<^sub>\<delta> where chi_delta_def: "is_pullback X one (X \<times>\<^sub>c X) \<Omega> (\<beta>\<^bsub>X\<^esub>) \<t> \<delta> \<chi>\<^sub>\<delta>"
    using \<delta>_mono \<delta>_type characteristic_function_exists by blast
  have helpful_fact: "\<forall> x y. (x\<in>\<^sub>c X \<and> y\<in>\<^sub>c X \<longrightarrow> (x=y \<longleftrightarrow> \<chi>\<^sub>\<delta> \<circ>\<^sub>c \<langle>x,y\<rangle> = \<t>))"
  proof (auto)
    fix y
    assume y_type: "y \<in>\<^sub>c X"
    have "\<chi>\<^sub>\<delta> \<circ>\<^sub>c \<langle>y,y\<rangle> = \<chi>\<^sub>\<delta> \<circ>\<^sub>c (\<delta> \<circ>\<^sub>c y)"
      by (simp add: delta_def diag_on_elements y_type)
    also have "... =  \<t> \<circ>\<^sub>c (\<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c y)"
      using y_type \<delta>_type chi_delta_def comp_associative2 is_pullback_def square_commutes_def
      by (typecheck_cfuncs, auto)
    also have "... = \<t>"
      by (metis cfunc_type_def comp_type id_right_unit id_type one_unique_element terminal_func_type true_func_type y_type)
    then show "\<chi>\<^sub>\<delta> \<circ>\<^sub>c \<langle>y,y\<rangle> = \<t>"
      by (simp add: calculation)
  next
    fix x y
    assume x_type: "x\<in>\<^sub>c X"
    assume y_type: "y\<in>\<^sub>c X"
    assume chi_xxEq_t: "\<chi>\<^sub>\<delta> \<circ>\<^sub>c \<langle>x,y\<rangle> = \<t>"

    have xy_prod_type: "\<langle>x,y\<rangle> : one \<rightarrow> X \<times>\<^sub>c X"
          by (simp add: cfunc_prod_type x_type y_type)
    have pullbackProp: "is_pullback X one (X \<times>\<^sub>c X) \<Omega> (\<beta>\<^bsub>X\<^esub>) \<t> \<delta> \<chi>\<^sub>\<delta>"
      using chi_delta_def by blast
    then obtain k where k_type: "k : one \<rightarrow> X \<and> \<delta> \<circ>\<^sub>c k = \<langle>x,y\<rangle>"
      unfolding is_pullback_def
      by (metis chi_xxEq_t id_right_unit2 id_type true_func_type xy_prod_type)
    then have "x = (left_cart_proj X X) \<circ>\<^sub>c \<langle>x,y\<rangle>"
          using left_cart_proj_cfunc_prod x_type y_type by auto
    also have "... = (left_cart_proj X X) \<circ>\<^sub>c (\<delta> \<circ>\<^sub>c k)"
          using k_type by auto
    also have "... = ((left_cart_proj X X) \<circ>\<^sub>c \<langle>id(X),id(X)\<rangle>) \<circ>\<^sub>c k"
      using \<delta>_type comp_associative2 delta_def diagonal_def k_type left_cart_proj_type by fastforce
    also have "... = id(X) \<circ>\<^sub>c k"
          by (metis id_type left_cart_proj_cfunc_prod)
    also have "... = y"
          by (metis calculation cfunc_prod_comp cfunc_type_def delta_def diagonal_def id_left_unit id_type k_type right_cart_proj_cfunc_prod y_type)
    then show "x = y"
         using calculation by blast
    qed

  have  \<chi>\<^sub>\<delta>sharp_type: "\<chi>\<^sub>\<delta>\<^sup>\<sharp> : X \<rightarrow> \<Omega>\<^bsup>X\<^esup>"
    using chi_delta_def is_pullback_def square_commutes_def transpose_func_type by auto
  have \<chi>\<^sub>\<delta>sharp_injective: "injective(\<chi>\<^sub>\<delta>\<^sup>\<sharp>)"
      unfolding injective_def
  proof (auto)
      fix x y
      assume "x \<in>\<^sub>c domain (\<chi>\<^sub>\<delta>\<^sup>\<sharp>)"
      then have x_type: "x \<in>\<^sub>c X"
        using \<chi>\<^sub>\<delta>sharp_type cfunc_type_def by auto
      assume "y \<in>\<^sub>c domain (\<chi>\<^sub>\<delta>\<^sup>\<sharp>)"
      then have y_type: "y \<in>\<^sub>c X"
        using \<chi>\<^sub>\<delta>sharp_type cfunc_type_def by auto
      assume chixEqschiy: "\<chi>\<^sub>\<delta>\<^sup>\<sharp> \<circ>\<^sub>c x = \<chi>\<^sub>\<delta>\<^sup>\<sharp> \<circ>\<^sub>c y"

      have "\<chi>\<^sub>\<delta> \<circ>\<^sub>c \<langle>x,x\<rangle> = ((eval_func \<Omega> X) \<circ>\<^sub>c (id(X) \<times>\<^sub>f \<chi>\<^sub>\<delta>\<^sup>\<sharp>)) \<circ>\<^sub>c \<langle>x,x\<rangle>"
        using chi_delta_def is_pullback_def square_commutes_def transpose_func_def by auto
      also have "... = (eval_func \<Omega> X) \<circ>\<^sub>c ((id(X) \<times>\<^sub>f \<chi>\<^sub>\<delta>\<^sup>\<sharp>) \<circ>\<^sub>c \<langle>x,x\<rangle>)"
        using \<chi>\<^sub>\<delta>sharp_type x_type by (typecheck_cfuncs, simp add: comp_associative2)
      also have "... = (eval_func \<Omega> X) \<circ>\<^sub>c \<langle>id(X) \<circ>\<^sub>c x, \<chi>\<^sub>\<delta>\<^sup>\<sharp> \<circ>\<^sub>c x\<rangle>"
        using \<chi>\<^sub>\<delta>sharp_type cfunc_cross_prod_comp_cfunc_prod cfunc_type_def id_type x_type by auto
      also have "... = (eval_func \<Omega> X) \<circ>\<^sub>c \<langle>id(X) \<circ>\<^sub>c x, \<chi>\<^sub>\<delta>\<^sup>\<sharp> \<circ>\<^sub>c y\<rangle>"
        using chixEqschiy by auto
      also have "... =  (eval_func \<Omega> X) \<circ>\<^sub>c ((id(X) \<times>\<^sub>f \<chi>\<^sub>\<delta>\<^sup>\<sharp>) \<circ>\<^sub>c \<langle>x,y\<rangle>)"
        using \<chi>\<^sub>\<delta>sharp_type cfunc_cross_prod_comp_cfunc_prod cfunc_type_def id_type x_type y_type by auto
      also have "... = \<chi>\<^sub>\<delta> \<circ>\<^sub>c \<langle>x,y\<rangle>"
        using \<chi>\<^sub>\<delta>sharp_type x_type y_type chi_delta_def comp_associative2 is_pullback_def
          square_commutes_def transpose_func_def by (typecheck_cfuncs, auto)
      then have computation: "\<chi>\<^sub>\<delta> \<circ>\<^sub>c \<langle>x,x\<rangle> = \<chi>\<^sub>\<delta> \<circ>\<^sub>c \<langle>x,y\<rangle>"
        by (simp add: calculation)
      then show "x=y"
        using \<chi>\<^sub>\<delta>sharp_type cfunc_type_def helpful_fact x_type y_type by fastforce
    qed
  then show "(\<exists> f.((f : X \<rightarrow> \<P> X) \<and> injective(f)))"
    using \<chi>\<^sub>\<delta>sharp_type powerset_def by auto
qed

end