(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Characteristic Polynomial\<close>

text \<open>We define eigenvalues, eigenvectors, and the characteristic polynomial. We further prove
  that the eigenvalues are exactly the roots of the characteristic polynomial.
  Finally, we apply the fundamental theorem of algebra to show that the characteristic polynomial
  of a complex matrix can always be represented as product of linear factors $x - a$.\<close>

theory Char_Poly
imports
  Polynomial_Factorization.Fundamental_Theorem_Algebra_Factorized
  Polynomial_Interpolation.Missing_Polynomial
  Polynomial_Interpolation.Ring_Hom_Poly
  Determinant
  Complex_Main
begin

definition eigenvector :: "'a :: comm_ring_1 mat \<Rightarrow> 'a vec \<Rightarrow> 'a \<Rightarrow> bool" where
  "eigenvector A v k = (v \<in> carrier_vec (dim_row A) \<and> v \<noteq> 0\<^sub>v (dim_row A) \<and> A *\<^sub>v v = k \<cdot>\<^sub>v v)"

lemma eigenvector_pow: assumes A: "A \<in> carrier_mat n n"
  and ev: "eigenvector A v (k :: 'a :: comm_ring_1)"
  shows "A ^\<^sub>m i *\<^sub>v v = k^i \<cdot>\<^sub>v v"
proof -
  let ?G = "monoid_vec TYPE ('a) n"
  from A have dim: "dim_row A = n" by auto
  from ev[unfolded eigenvector_def dim]
  have v: "v \<in> carrier_vec n" and Av: "A *\<^sub>v v = k \<cdot>\<^sub>v v" by auto
  interpret v: comm_group ?G by (rule comm_group_vec)
  show ?thesis
  proof (induct i)
    case 0
    show ?case using v dim by simp
  next
    case (Suc i)
    define P where "P = A ^\<^sub>m i"
    have P: "P \<in> carrier_mat n n" using A unfolding P_def by simp
    have "A ^\<^sub>m Suc i = P * A" unfolding P_def by simp
    also have "\<dots> *\<^sub>v v = P *\<^sub>v (A *\<^sub>v v)" using P A v by simp
    also have "A *\<^sub>v v = k \<cdot>\<^sub>v v" by (rule Av)
    also have "P *\<^sub>v (k \<cdot>\<^sub>v v) = k \<cdot>\<^sub>v (P *\<^sub>v v)"
      by (rule eq_vecI, insert v P, auto)
    also have "(P *\<^sub>v v) = (k ^ i) \<cdot>\<^sub>v v" unfolding P_def by (rule Suc)
    also have "k \<cdot>\<^sub>v ((k ^ i) \<cdot>\<^sub>v v) = (k * k ^ i) \<cdot>\<^sub>v v"
      by (rule eq_vecI, insert v, auto)
    also have "k * k ^ i = k ^ (Suc i)" by auto
    finally show ?case .
  qed
qed

definition eigenvalue :: "'a :: comm_ring_1 mat \<Rightarrow> 'a \<Rightarrow> bool" where
  "eigenvalue A k = (\<exists> v. eigenvector A v k)"

definition char_matrix :: "'a :: field mat \<Rightarrow> 'a \<Rightarrow> 'a mat" where
  "char_matrix A e = A + ((-e) \<cdot>\<^sub>m (1\<^sub>m (dim_row A)))"

lemma eigenvector_char_matrix: assumes A: "(A :: 'a :: field mat) \<in> carrier_mat n n"
  shows "eigenvector A v e = (v \<in> carrier_vec n \<and> v \<noteq> 0\<^sub>v n \<and> char_matrix A e *\<^sub>v v = 0\<^sub>v n)"
proof -
  from A have dim: "dim_row A = n" "dim_col A = n" by auto
  {
    assume v: "v \<in> carrier_vec n"
    hence dimv: "dim_vec v = n" by auto
    have "(A *\<^sub>v v = e \<cdot>\<^sub>v v) = (A *\<^sub>v v + (-e) \<cdot>\<^sub>v v = 0\<^sub>v n)" (is "?id1 = ?id2")
    proof
      assume ?id1
      from arg_cong[OF this, of "\<lambda> w. w + (-e) \<cdot>\<^sub>v v"]
      show ?id2 using A v by auto
    next
      assume ?id2
      have "A *\<^sub>v v + - e \<cdot>\<^sub>v v + e \<cdot>\<^sub>v v = A *\<^sub>v v" using A v by auto
      from arg_cong[OF \<open>?id2\<close>, of "\<lambda> w. w + e \<cdot>\<^sub>v v", unfolded this]
      show ?id1 using A v by simp
    qed
    also have "(A *\<^sub>v v + (-e) \<cdot>\<^sub>v v) = char_matrix A e *\<^sub>v v" unfolding char_matrix_def
      by (rule eq_vecI, insert v A dim, auto simp: add_scalar_prod_distrib[of _ n])
    finally have "(A *\<^sub>v v = e \<cdot>\<^sub>v v) = (char_matrix A e *\<^sub>v v = 0\<^sub>v n)" .
  }
  thus ?thesis unfolding eigenvector_def dim by blast
qed

lemma eigenvalue_char_matrix: assumes A: "(A :: 'a :: field mat) \<in> carrier_mat n n"
  shows "eigenvalue A e = (\<exists> v. v \<in> carrier_vec n \<and> v \<noteq> 0\<^sub>v n \<and> char_matrix A e *\<^sub>v v = 0\<^sub>v n)"
  unfolding eigenvalue_def eigenvector_char_matrix[OF A] ..

definition find_eigenvector :: "'a::field mat \<Rightarrow> 'a \<Rightarrow> 'a vec" where
  "find_eigenvector A e =
    find_base_vector (fst (gauss_jordan (char_matrix A e) (0\<^sub>m (dim_row A) 0)))"

lemma find_eigenvector: assumes A: "A \<in> carrier_mat n n"
  and ev: "eigenvalue A e"
  shows "eigenvector A (find_eigenvector A e) e"
proof -
  define B where "B = char_matrix A e"
  from ev[unfolded eigenvalue_char_matrix[OF A]]  obtain v where
    v: "v \<in> carrier_vec n" "v \<noteq> 0\<^sub>v n" and Bv: "B *\<^sub>v v = 0\<^sub>v n" unfolding B_def by auto
  have B: "B \<in> carrier_mat n n" using A unfolding B_def by simp
  let ?z = "0\<^sub>m (dim_row A) 0"
  obtain C D where gauss: "gauss_jordan B ?z = (C,D)" by force
  define w where "w = find_base_vector C"
  have res: "find_eigenvector A e = w" unfolding w_def find_eigenvector_def Let_def gauss B_def[symmetric]
    by simp
  have "?z \<in> carrier_mat n 0" using A by auto
  note gauss_0 = gauss_jordan[OF B this gauss]
  hence C: "C \<in> carrier_mat n n" by auto
  from gauss_0(1)[OF v(1)] Bv have Cv: "C *\<^sub>v v = 0\<^sub>v n" by auto
  {
    assume C: "C = 1\<^sub>m n"
    have False using id Cv v unfolding C by auto
  }
  hence C1: "C \<noteq> 1\<^sub>m n" by auto
  from find_base_vector_not_1[OF gauss_jordan_row_echelon[OF B gauss] C C1]
  have w: "w \<in> carrier_vec n" "w \<noteq> 0\<^sub>v n" and id: "C *\<^sub>v w = 0\<^sub>v n" unfolding w_def by auto
  from gauss_0(1)[OF w(1)] id have Bw: "B *\<^sub>v w = 0\<^sub>v n" by simp
  from w Bw have "eigenvector A w e"
    unfolding eigenvector_char_matrix[OF A] B_def by auto
  thus ?thesis unfolding res .
qed

lemma eigenvalue_imp_nonzero_dim: assumes "A \<in> carrier_mat n n"
  and "eigenvalue A ev"
  shows "n > 0"
proof (cases n)
  case 0
  from assms obtain v where "eigenvector A v ev" unfolding eigenvalue_def by auto
  from this[unfolded eigenvector_def] assms 0
  have "v \<in> carrier_vec 0" "v \<noteq> 0\<^sub>v 0" by auto
  hence False by auto
  thus ?thesis by auto
qed simp

lemma eigenvalue_det: assumes A: "(A :: 'a :: field mat) \<in> carrier_mat n n" shows
  "eigenvalue A e = (det (char_matrix A e) = 0)"
proof -
  from A have cA: "char_matrix A e \<in> carrier_mat n n" by auto
  show ?thesis
    unfolding eigenvalue_char_matrix[OF A]
    unfolding id det_0_negate[OF cA] det_0_iff_vec_prod_zero[OF cA]
      eigenvalue_def by auto
qed

definition char_poly_matrix :: "'a :: comm_ring_1 mat \<Rightarrow> 'a poly mat" where
  "char_poly_matrix A = (([:0,1:] \<cdot>\<^sub>m 1\<^sub>m (dim_row A)) + map_mat (\<lambda> a. [: - a :]) A)"

lemma char_poly_matrix_closed[simp]: "A \<in> carrier_mat n n \<Longrightarrow> char_poly_matrix A \<in> carrier_mat n n"
  unfolding char_poly_matrix_def by auto

definition char_poly :: "'a :: comm_ring_1 mat \<Rightarrow> 'a poly" where
  "char_poly A = (det (char_poly_matrix A))"

lemmas char_poly_defs = char_poly_def char_poly_matrix_def

lemma (in comm_ring_hom) char_poly_matrix_hom: assumes A: "A \<in> carrier_mat n n"
  shows "char_poly_matrix (mat\<^sub>h A) = map_mat (map_poly hom) (char_poly_matrix A)"
  unfolding char_poly_defs
  by (rule eq_matI, insert A, auto simp: smult_mat_def hom_distribs)

lemma (in comm_ring_hom) char_poly_hom: assumes A: "A \<in> carrier_mat n n"
  shows "char_poly (map_mat hom A) = map_poly hom (char_poly A)"
proof -
  interpret map_poly_hom: map_poly_comm_ring_hom hom..
  show ?thesis
    unfolding char_poly_def map_poly_hom.hom_det[symmetric] char_poly_matrix_hom[OF A] ..
qed

context inj_comm_ring_hom
begin

lemma eigenvector_hom: assumes A: "A \<in> carrier_mat n n"
  and ev: "eigenvector A v ev"
  shows "eigenvector (mat\<^sub>h A) (vec\<^sub>h v) (hom ev)"
proof -
  let ?A = "mat\<^sub>h A"
  let ?v = "vec\<^sub>h v"
  let ?ev = "hom ev"
  from ev[unfolded eigenvector_def] A
  have v: "v \<in> carrier_vec n" "v \<noteq> 0\<^sub>v n" "A *\<^sub>v v = ev \<cdot>\<^sub>v v" by auto
  from v(1) have v1: "?v \<in> carrier_vec n" by simp
  from v(1-2) obtain i where "i < n" and "v $ i \<noteq> 0" by force
  with v(1) have "?v $ i \<noteq> 0" by auto
  hence v2: "?v \<noteq> 0\<^sub>v n" using \<open>i < n\<close> v(1) by force
  from arg_cong[OF v(3), of "vec\<^sub>h", unfolded mult_mat_vec_hom[OF A v(1)] vec_hom_smult]
  have v3: "?A *\<^sub>v ?v = ?ev \<cdot>\<^sub>v ?v" .
  from v1 v2 v3
  show ?thesis unfolding eigenvector_def using A by auto
qed

lemma eigenvalue_hom: assumes A: "A \<in> carrier_mat n n"
  and ev: "eigenvalue A ev"
  shows "eigenvalue (mat\<^sub>h A) (hom ev)"
  using eigenvector_hom[OF A, of _ ev] ev
  unfolding eigenvalue_def by auto

lemma eigenvector_hom_rev: assumes A: "A \<in> carrier_mat n n"
  and ev: "eigenvector (mat\<^sub>h A) (vec\<^sub>h v) (hom ev)"
  shows "eigenvector A v ev"
proof -
  let ?A = "mat\<^sub>h A"
  let ?v = "vec\<^sub>h v"
  let ?ev = "hom ev"
  from ev[unfolded eigenvector_def] A
  have v: "v \<in> carrier_vec n" "?v \<noteq> 0\<^sub>v n" "?A *\<^sub>v ?v = ?ev \<cdot>\<^sub>v ?v" by auto
  from v(1-2) obtain i where "i < n" and "v $ i \<noteq> 0" by force
  with v(1) have "v $ i \<noteq> 0" by auto
  hence v2: "v \<noteq> 0\<^sub>v n" using \<open>i < n\<close> v(1) by force
  from vec_hom_inj[OF v(3)[folded mult_mat_vec_hom[OF A v(1)] vec_hom_smult]]
  have v3: "A *\<^sub>v v = ev \<cdot>\<^sub>v v" .
  from v(1) v2 v3
  show ?thesis unfolding eigenvector_def using A by auto
qed

end

lemma poly_det_cong: assumes A: "A \<in> carrier_mat n n"
  and B: "B \<in> carrier_mat n n"
  and poly: "\<And> i j. i < n \<Longrightarrow> j < n \<Longrightarrow> poly (B $$ (i,j)) k = A $$ (i,j)"
  shows "poly (det B) k = det A"
proof -
  show ?thesis
  unfolding det_def'[OF A] det_def'[OF B] poly_sum poly_mult poly_prod
  proof (rule sum.cong[OF refl])
    fix x
    assume x: "x \<in> {p. p permutes {0..<n}}"
    let ?l = "\<Prod>ka = 0..<n. poly (B $$ (ka, x ka)) k"
    let ?r = "\<Prod>i = 0..<n. A $$ (i, x i)"
    have id: "?l = ?r"
      by (rule prod.cong[OF refl poly], insert x, auto)
    show "poly (signof x) k * ?l = signof x * ?r" unfolding id signof_def by auto
  qed
qed

lemma char_poly_matrix: assumes A: "(A :: 'a :: field mat) \<in> carrier_mat n n"
  shows "poly (char_poly A) k = det (- (char_matrix A k))"  unfolding char_poly_def
  by (rule poly_det_cong[of _ n], insert A, auto simp: char_poly_matrix_def char_matrix_def)

lemma eigenvalue_root_char_poly: assumes A: "(A :: 'a :: field mat) \<in> carrier_mat n n"
  shows "eigenvalue A k \<longleftrightarrow> poly (char_poly A) k = 0"
  unfolding eigenvalue_det[OF A] char_poly_matrix[OF A]
  by (subst det_0_negate[of _ n], insert A, auto)

context
  fixes A :: "'a :: comm_ring_1 mat" and n :: nat
  assumes A: "A \<in> carrier_mat n n"
  and ut: "upper_triangular A"
begin
lemma char_poly_matrix_upper_triangular: "upper_triangular (char_poly_matrix A)"
  using A ut unfolding upper_triangular_def char_poly_matrix_def by auto

lemma char_poly_upper_triangular:
  "char_poly A = (\<Prod> a \<leftarrow> diag_mat A. [:- a, 1:])"
proof -
  from A have cA: "char_poly_matrix A \<in> carrier_mat n n" by simp
  show ?thesis
    unfolding char_poly_def det_upper_triangular [OF char_poly_matrix_upper_triangular cA]
    by (rule arg_cong[where f = prod_list], unfold list_eq_iff_nth_eq, insert cA A, auto simp: diag_mat_def
      char_poly_matrix_def)
qed
end

lemma map_poly_mult: assumes A: "A \<in> carrier_mat nr n"
  and B: "B \<in> carrier_mat n nc"
  shows
    "map_mat (\<lambda> a. [: a :]) (A * B) = map_mat (\<lambda> a. [: a :]) A * map_mat (\<lambda> a. [: a :]) B" (is "?id")
    "map_mat (\<lambda> a. [: a :] * p) (A * B) = map_mat (\<lambda> a. [: a :] * p) A * map_mat (\<lambda> a. [: a :]) B" (is "?left")
    "map_mat (\<lambda> a. [: a :] * p) (A * B) = map_mat (\<lambda> a. [: a :]) A * map_mat (\<lambda> a. [: a :] * p) B" (is "?right")
proof -
  from A B have dim: "dim_row A = nr" "dim_col A = n" "dim_row B = n" "dim_col B = nc" by auto
  {
    fix i j
    have "i < nr \<Longrightarrow> j < nc \<Longrightarrow>
      row (map_mat (\<lambda>a. [:a:]) A) i \<bullet> col (map_mat (\<lambda>a. [:a:]) B) j = [:(row A i \<bullet> col B j):]"
      unfolding scalar_prod_def
      by (auto simp: dim ac_simps, induct n, auto)
  } note id = this
  {
    fix i j
    have "i < nr \<Longrightarrow> j < nc \<Longrightarrow>
      [:(row A i \<bullet> col B j):] * p = row (map_mat (\<lambda> a. [: a :] * p) A) i \<bullet> col (map_mat (\<lambda>a. [:a:]) B) j"
      unfolding scalar_prod_def
      by (auto simp: dim ac_simps smult_sum)
  } note left = this
  {
    fix i j
    have "i < nr \<Longrightarrow> j < nc \<Longrightarrow>
      [:(row A i \<bullet> col B j):] * p = row (map_mat (\<lambda> a. [: a :]) A) i \<bullet> col (map_mat (\<lambda>a. [:a:] * p) B) j"
      unfolding scalar_prod_def
      by (auto simp: dim ac_simps smult_sum)
  } note right = this
  show ?id
    by (rule eq_matI, insert id, auto simp: dim)
  show ?left
    by (rule eq_matI, insert left, auto simp: dim)
  show ?right
    by (rule eq_matI, insert right, auto simp: dim)
qed

lemma char_poly_similar: assumes "similar_mat A (B :: 'a :: comm_ring_1 mat)"
  shows "char_poly A = char_poly B"
proof -
  from similar_matD[OF assms] obtain n P Q where
  carr: "{A, B, P, Q} \<subseteq> carrier_mat n n" (is "_ \<subseteq> ?C")
  and PQ: "P * Q = 1\<^sub>m n"
  and AB: "A = P * B * Q" by auto
  hence A: "A \<in> ?C" and B: "B \<in> ?C" and P: "P \<in> ?C" and Q: "Q \<in> ?C" by auto
  let ?m = "\<lambda> a. [: -a :]"
  let ?P = "map_mat (\<lambda> a. [: a :]) P"
  let ?Q = "map_mat (\<lambda> a. [: a :]) Q"
  let ?B = "map_mat ?m B"
  let ?I = "map_mat (\<lambda> a. [: a :]) (1\<^sub>m n)"
  let ?XI = "[:0, 1:] \<cdot>\<^sub>m 1\<^sub>m n"
  from A B have dim: "dim_row A = n" "dim_row B = n" by auto
  have cong: "\<And> x y z. x = y \<Longrightarrow> x * z = y * z" by auto
  have id: "?m = (\<lambda> a :: 'a. [: a :] * [: -1 :])" by (intro ext, auto)
  have "char_poly A = det (?XI + map_mat (\<lambda>a. [:- a:]) (P * B * Q))" unfolding
    char_poly_defs dim
    by (simp add: AB)
  also have "?XI = ?P * ?XI * ?Q" (is "_ = ?left")
  proof -
    have "?P * ?XI = [:0, 1:] \<cdot>\<^sub>m (?P * 1\<^sub>m n)"
      by (rule mult_smult_distrib[of _ n n _ n], insert P, auto)
    also have "?P * 1\<^sub>m n = ?P" using P by simp
    also have "([: 0, 1:] \<cdot>\<^sub>m ?P) * ?Q = [: 0, 1:] \<cdot>\<^sub>m (?P * ?Q)"
      by (rule mult_smult_assoc_mat, insert P Q, auto)
    also have "?P * ?Q = ?I" unfolding PQ[symmetric]
      by (rule map_poly_mult[symmetric, OF P Q])
    also have "[: 0, 1:] \<cdot>\<^sub>m ?I = ?XI"
      by rule auto
    finally show ?thesis ..
  qed
  also have "map_mat ?m (P * B * Q) = ?P * ?B * ?Q" (is "_ = ?right")
    unfolding id
    by (subst map_poly_mult[OF mult_carrier_mat[OF P B] Q],
      subst map_poly_mult(3)[OF P B], simp)
  also have "?left + ?right = (?P * ?XI + ?P * ?B) * ?Q"
    by (rule add_mult_distrib_mat[symmetric, of _ n n], insert B P Q, auto)
  also have "?P * ?XI + ?P * ?B = ?P * (?XI + ?B)"
    by (rule mult_add_distrib_mat[symmetric, of _ n n], insert B P Q, auto)
  also have "det (?P * (?XI + ?B) * ?Q) = det ?P * det (?XI + ?B) * det ?Q"
    by (rule trans[OF det_mult[of _ n] cong[OF det_mult]], insert P Q B, auto)
  also have "\<dots> = (det ?P * det ?Q) * det (?XI + ?B)" by (simp add: ac_simps)
  also have "det (?XI + ?B) = char_poly B" unfolding char_poly_defs dim by simp
  also have "det ?P * det ?Q = det (?P * ?Q)"
    by (rule det_mult[symmetric], insert P Q, auto)
  also have "?P * ?Q = ?I" unfolding PQ[symmetric]
    by (rule map_poly_mult[symmetric, OF P Q])
  also have "det \<dots> = prod_list (diag_mat ?I)"
    by (rule det_upper_triangular[of _ n], auto)
  also have "\<dots> = 1" unfolding prod_list_diag_prod
    by (rule prod.neutral) simp
  finally show ?thesis by simp
qed

lemma degree_signof_mult[simp]: "degree (signof p * q) = degree q"
  by (cases "sign p = 1", auto simp: signof_def)

lemma degree_monic_char_poly: assumes A: "A \<in> carrier_mat n n"
  shows "degree (char_poly A) = n \<and> coeff (char_poly A) n = 1"
proof -
  from A have A': "[:0, 1:] \<cdot>\<^sub>m 1\<^sub>m (dim_row A) + map_mat (\<lambda>a. [:- a:]) A \<in> carrier_mat n n" by auto
  from A have dA: "dim_row A = n" by simp
  show ?thesis
    unfolding char_poly_defs det_def'[OF A']
  proof (rule degree_lcoeff_sum[of _ id], auto simp: finite_permutations permutes_id dA)
    have both: "degree (\<Prod>i = 0..<n. ([:0, 1:] \<cdot>\<^sub>m 1\<^sub>m n + map_mat (\<lambda>a. [:- a:]) A) $$ (i, i)) = n \<and>
      coeff (\<Prod>i = 0..<n. ([:0, 1:] \<cdot>\<^sub>m 1\<^sub>m n + map_mat (\<lambda>a. [:- a:]) A) $$ (i, i)) n = 1"
      by (rule degree_prod_monic, insert A, auto)
    from both show "degree (\<Prod>i = 0..<n. ([:0, 1:] \<cdot>\<^sub>m 1\<^sub>m n + map_mat (\<lambda>a. [:- a:]) A) $$ (i, i)) = n" ..
    from both show "coeff (\<Prod>i = 0..<n. ([:0, 1:] \<cdot>\<^sub>m 1\<^sub>m n + map_mat (\<lambda>a. [:- a:]) A) $$ (i, i)) n = 1" ..
  next
    fix p
    assume p: "p permutes {0..<n}"
      and "p \<noteq> id"
    then obtain i where i: "i < n" and pi: "p i \<noteq> i"
      by (metis atLeastLessThan_iff order_refl permutes_natset_le)
    show "degree (\<Prod>i = 0..<n. ([:0, 1:] \<cdot>\<^sub>m 1\<^sub>m n + map_mat (\<lambda>a. [:- a:]) A) $$ (i, p i)) < n"
      by (rule degree_prod_sum_lt_n[OF _ i], insert p i pi A, auto)
  qed
qed

lemma char_poly_factorized: fixes A :: "complex mat"
  assumes A: "A \<in> carrier_mat n n"
  shows "\<exists> as. char_poly A = (\<Prod> a \<leftarrow> as. [:- a, 1:]) \<and> length as = n"
proof -
  let ?p = "char_poly A"
  from fundamental_theorem_algebra_factorized[of ?p] obtain as
  where "Polynomial.smult (coeff ?p (degree ?p)) (\<Prod>a\<leftarrow>as. [:- a, 1:]) = ?p" by blast
  also have "coeff ?p (degree ?p) = 1" using degree_monic_char_poly[OF A] by simp
  finally have cA: "?p = (\<Prod>a\<leftarrow>as. [:- a, 1:])" by simp
  from degree_monic_char_poly[OF A] have "degree ?p = n" ..
  with degree_linear_factors[of uminus as, folded cA] have "length as = n" by auto
  with cA show ?thesis by blast
qed

lemma char_poly_four_block_zeros_col: assumes A1: "A1 \<in> carrier_mat 1 1"
  and A2: "A2 \<in> carrier_mat 1 n" and A3: "A3 \<in> carrier_mat n n"
  shows "char_poly (four_block_mat A1 A2 (0\<^sub>m n 1) A3) = char_poly A1 * char_poly A3"
    (is "char_poly ?A = ?cp1 * ?cp3")
proof -
  let ?cm = "\<lambda> A. [:0, 1:] \<cdot>\<^sub>m 1\<^sub>m (dim_row A) +
         map_mat (\<lambda>a. [:- a:]) A"
  let ?B2 = "map_mat (\<lambda>a. [:- a:]) A2"
  have "char_poly ?A = det (?cm ?A)"
    unfolding char_poly_defs using A1 A3 by simp
  also have "?cm ?A = four_block_mat (?cm A1) ?B2 (0\<^sub>m n 1) (?cm A3)"
    by (rule eq_matI, insert A1 A2 A3, auto simp: one_poly_def)
  also have "det \<dots> = det (?cm A1) * det (?cm A3)"
    by (rule det_four_block_mat_lower_left_zero_col[OF _ _ refl], insert A1 A2 A3, auto)
  also have "\<dots> = ?cp1 * ?cp3" unfolding char_poly_defs ..
  finally show ?thesis .
qed

lemma char_poly_transpose_mat[simp]: assumes A: "A \<in> carrier_mat n n"
  shows "char_poly (transpose_mat A) = char_poly A"
proof -
  let ?A = "[:0, 1:] \<cdot>\<^sub>m 1\<^sub>m (dim_row A) + map_mat (\<lambda>a. [:- a:]) A"
  have A': "?A \<in> carrier_mat n n" using A by auto
  show ?thesis unfolding char_poly_defs
    by (subst det_transpose[symmetric, OF A'], rule arg_cong[of _ _ det],
    insert A, auto)
qed

lemma pderiv_char_poly: fixes A :: "'a :: idom mat"
  assumes A: "A \<in> carrier_mat n n"
  shows "pderiv (char_poly A) = (\<Sum>i < n. char_poly (mat_delete A i i))"
proof -
  let ?det = Determinant.det
  let ?m = "map_mat (\<lambda>a. [:- a:])"
  let ?lam = "[:0, 1:] \<cdot>\<^sub>m 1\<^sub>m n :: 'a poly mat"
  from A have id: "dim_row A = n" by auto

  define mA where "mA = ?m A"
  define lam where "lam = ?lam"
  let ?sum = "lam + mA"
  define Sum where "Sum = ?sum"
  have mA: "mA \<in> carrier_mat n n" and
    lam: "lam \<in> carrier_mat n n" and
    Sum: "Sum \<in> carrier_mat n n"
    using A unfolding mA_def Sum_def lam_def by auto
  let ?P = "{p. p permutes {0..<n}}"
  let ?e = "\<lambda> p. (\<Prod>i = 0..<n. Sum $$ (i, p i))"
  let ?f = "\<lambda> p a. signof p * (\<Prod>i\<in>{0..<n} - {a}. Sum $$ (i, p i)) * pderiv (Sum $$ (a, p a))"
  let ?g = "\<lambda> p a. signof p * (\<Prod>i\<in>{0..<n} - {a}. Sum $$ (i, p i))"
  define f where "f = ?f"
  define g where "g = ?g"
  {
    fix p
    assume p: "p permutes {0 ..< n}"
    have "pderiv (signof p :: 'a poly) = 0" unfolding signof_def by (simp add: pderiv_minus)
    hence "pderiv (signof p * ?e p) = signof p * pderiv (\<Prod>i = 0..<n. Sum $$ (i, p i))"
      unfolding pderiv_mult by auto
    also have "signof p * pderiv (\<Prod>i = 0..<n. Sum $$ (i, p i)) =
       (\<Sum>a = 0..<n. f p a)"
      unfolding pderiv_prod sum_distrib_left f_def by (simp add: ac_simps)
    also note calculation
  } note to_f = this
  {
    fix a
    assume a: "a < n"
    have Psplit: "?P = {p. p permutes {0..<n} \<and> p a = a} \<union> (?P - {p. p a = a})" (is "_ = ?Pa \<union> ?Pz") by auto
    {
      fix p
      assume p: "p permutes {0 ..< n}" "p a \<noteq> a"
      hence "pderiv (Sum $$ (a, p a)) = 0" unfolding Sum_def lam_def mA_def using a p A by auto
      hence "f p a = 0" unfolding f_def by auto
    } note 0 = this
    {
      fix p
      assume p: "p permutes {0 ..< n}" "p a = a"
      hence "pderiv (Sum $$ (a, p a)) = 1" unfolding Sum_def lam_def mA_def using a p A
        by (auto simp: pderiv_pCons)
      hence "f p a = g p a" unfolding f_def g_def by auto
    } note fg = this
    let ?n = "n - 1"
    from a have n: "Suc ?n = n" by simp
    let ?B = "[:0, 1:] \<cdot>\<^sub>m 1\<^sub>m ?n + ?m (mat_delete A a a)"
    have B: "?B \<in> carrier_mat ?n ?n" using A by auto
    have "sum (\<lambda> p. f p a) ?P = sum (\<lambda> p. f p a) ?Pa + sum (\<lambda> p. f p a) ?Pz"
      by (subst sum.union_disjoint[symmetric], auto simp: finite_permutations Psplit[symmetric])
    also have "\<dots> = sum (\<lambda> p. f p a) ?Pa"
      by (subst (2) sum.neutral, insert 0, auto)
    also have "\<dots> = sum (\<lambda> p. g p a) ?Pa"
      by (rule sum.cong, auto simp: fg)
    also have "\<dots> = ?det ?B"
      unfolding det_def'[OF B]
      unfolding permutation_fix[of a ?n a, unfolded n, OF a a]
      unfolding sum.reindex[OF permutation_insert_inj_on[of a ?n a, unfolded n, OF a a]] o_def
    proof (rule sum.cong[OF refl])
      fix p
      let ?Q = "{p. p permutes {0..<?n}}"
      assume "p \<in> ?Q"
      hence p: "p permutes {0 ..< ?n}" by auto
      let ?p = "permutation_insert a a p"
      let ?i = "insert_index a"
      have sign: "signof ?p = signof p"
        unfolding signof_permutation_insert[OF p, unfolded n, OF a a] by simp
      show "g (permutation_insert a a p) a = signof p * (\<Prod>i = 0..<?n. ?B $$ (i, p i))"
        unfolding g_def sign
      proof (rule arg_cong[of _ _ "(*) (signof p)"])
        have "(\<Prod>i\<in>{0..<n} - {a}. Sum $$ (i, ?p i)) =
           prod (($$) Sum) ((\<lambda>x. (x, ?p x)) ` ({0..<n} - {a}))"
          unfolding prod.reindex[OF inj_on_convol_ident, of _ ?p] o_def ..
        also have "\<dots> = (\<Prod> ii \<in> {(i', ?p i') |i'. i' \<in> {0..<n} - {a}}. Sum $$ ii)"
          by (rule prod.cong, auto)
        also have "\<dots> = prod (($$) Sum) ((\<lambda> i. (?i i, ?i (p i))) ` {0 ..< ?n})"
          unfolding Determinant.foo[of a ?n a, unfolded n, OF a a p]
          by (rule arg_cong[of _ _ "prod _"], auto)
        also have "\<dots> = prod (\<lambda> i. Sum $$ (?i i, ?i (p i))) {0 ..< ?n}"
        proof (subst prod.reindex, unfold o_def)
          show "inj_on (\<lambda>i. (?i i, ?i (p i))) {0..<?n}" using insert_index_inj_on[of a]
            by (auto simp: inj_on_def)
        qed simp
        also have "\<dots> = (\<Prod>i = 0..<?n. ?B $$ (i, p i))"
        proof (rule prod.cong[OF refl], rename_tac i)
          fix j
          assume "j \<in> {0 ..< ?n}"
          hence j: "j < ?n" by auto
          with p have pj: "p j < ?n" by auto
          from j pj have jj: "?i j < n" "?i (p j) < n" by (auto simp: insert_index_def)
          let ?jj = "(?i j, ?i (p j))"
          note index_adj = mat_delete_index[of _ ?n, unfolded n, OF _ a a j pj]
          have "Sum $$ ?jj = lam $$ ?jj + mA $$ ?jj" unfolding Sum_def using jj A lam mA by auto
          also have "\<dots> = ?B $$ (j, p j)"
            unfolding index_adj[OF mA] index_adj[OF lam] using j pj A
            by (simp add: mA_def lam_def mat_delete_def)
          finally show "Sum $$ ?jj = ?B $$ (j, p j)" .
        qed
        finally
        show "(\<Prod>i\<in>{0..<n} - {a}. Sum $$ (i, ?p i)) = (\<Prod>i = 0..<?n. ?B $$ (i, p i))" .
      qed
    qed
    also have "\<dots> = char_poly (mat_delete A a a)" unfolding char_poly_def char_poly_matrix_def
      using A by simp
    also note calculation
  } note to_char_poly = this
  have "pderiv (char_poly A) = pderiv (?det Sum)"
    unfolding char_poly_def char_poly_matrix_def id lam_def mA_def Sum_def by auto
  also have "\<dots> = sum (\<lambda> p. pderiv (signof p * ?e p)) ?P" unfolding det_def'[OF Sum]
    pderiv_sum by (rule sum.cong, auto)
  also have "\<dots> = sum (\<lambda> p. (\<Sum>a = 0..<n. f p a)) ?P"
    by (rule sum.cong[OF refl], subst to_f, auto)
  also have "\<dots> = (\<Sum>a = 0..<n. sum (\<lambda> p. f p a) ?P)"
    by (rule sum.swap)
  also have "\<dots> = (\<Sum>a <n. char_poly (mat_delete A a a))"
    by (rule sum.cong, auto simp: to_char_poly)
  finally show ?thesis .
qed

lemma char_poly_0_column: fixes A :: "'a :: idom mat"
  assumes 0: "\<And> j. j < n \<Longrightarrow> A $$ (j,i) = 0"
  and A: "A \<in> carrier_mat n n"
  and i: "i < n"
shows "char_poly A = monom 1 1 * char_poly (mat_delete A i i)"
proof -
  let ?n = "n - 1"
  let ?A = "mat_delete A i i"
  let ?sum = "[:0, 1:] \<cdot>\<^sub>m 1\<^sub>m n + map_mat (\<lambda>a. [:- a:]) A"
  define Sum where "Sum = ?sum"
  let ?f = "\<lambda> j. Sum $$ (j, i) * cofactor Sum j i"
  have Sum: "Sum \<in> carrier_mat n n" using A unfolding Sum_def by auto
  from A have id: "dim_row A = n" by auto
  have "char_poly A = (\<Sum>j<n. ?f j)"
    unfolding char_poly_def[of A] char_poly_matrix_def
    using laplace_expansion_column[OF Sum i] unfolding Sum_def using A by simp
  also have "\<dots> = ?f i + sum ?f ({..<n} - {i})"
    by (rule sum.remove[of _ i], insert i, auto)
  also have "\<dots> = ?f i"
  proof (subst sum.neutral, intro ballI)
    fix j
    assume "j \<in> {..<n} - {i}"
    hence j: "j < n" and ji: "j \<noteq> i" by auto
    show "?f j = 0" unfolding Sum_def using ji j i A 0[OF j] by simp
  qed simp
  also have "?f i = [:0, 1:] * (cofactor Sum i i)"
    unfolding Sum_def using i A 0[OF i] by simp
  also have "cofactor Sum i i = det (mat_delete Sum i i)"
    unfolding cofactor_def by simp
  also have "\<dots> = char_poly ?A"
    unfolding char_poly_def char_poly_matrix_def Sum_def
  proof (rule arg_cong[of _ _ det])
    show "mat_delete ?sum i i = [:0, 1:] \<cdot>\<^sub>m 1\<^sub>m (dim_row ?A) + map_mat (\<lambda>a. [:- a:]) ?A"
      using i A by (auto simp: mat_delete_def)
  qed
  also have "[:0, 1:] = (monom 1 1 :: 'a poly)" by (rule x_as_monom)
  finally show ?thesis .
qed

definition mat_erase :: "'a :: zero mat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mat" where
  "mat_erase A i j = Matrix.mat (dim_row A) (dim_col A)
     (\<lambda> (i',j'). if i' = i \<or> j' = j then 0 else A $$ (i',j'))"

lemma mat_erase_carrier[simp]: "(mat_erase A i j) \<in> carrier_mat nr nc \<longleftrightarrow> A \<in> carrier_mat nr nc"
  unfolding mat_erase_def carrier_mat_def by simp

lemma pderiv_char_poly_mat_erase: fixes A :: "'a :: idom mat"
  assumes A: "A \<in> carrier_mat n n"
  shows "monom 1 1 * pderiv (char_poly A) = (\<Sum>i < n. char_poly (mat_erase A i i))"
proof -
  show ?thesis unfolding pderiv_char_poly[OF A] sum_distrib_left
  proof (rule sum.cong[OF refl])
    fix i
    assume "i \<in> {..<n}"
    hence i: "i < n" by simp
    have mA: "mat_erase A i i \<in> carrier_mat n n" using A by simp
    show "monom 1 1 * char_poly (mat_delete A i i) = char_poly (mat_erase A i i)"
      by (subst char_poly_0_column[OF _ mA i], (insert i A, force simp: mat_erase_def),
      rule arg_cong[of _ _ "\<lambda> x. f * char_poly x" for f],
      auto simp: mat_delete_def mat_erase_def)
  qed
qed

end


(*  Title:      ZF/Constructible/Normal.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Closed Unbounded Classes and Normal Functions\<close>

theory Normal imports ZF begin

text\<open>
One source is the book

Frank R. Drake.
\emph{Set Theory: An Introduction to Large Cardinals}.
North-Holland, 1974.
\<close>

subsection \<open>Closed and Unbounded (c.u.) Classes of Ordinals\<close>

definition
  Closed :: "(i=>o) => o" where
    "Closed(P) == \<forall>I. I \<noteq> 0 \<longrightarrow> (\<forall>i\<in>I. Ord(i) \<and> P(i)) \<longrightarrow> P(\<Union>(I))"

definition
  Unbounded :: "(i=>o) => o" where
    "Unbounded(P) == \<forall>i. Ord(i) \<longrightarrow> (\<exists>j. i<j \<and> P(j))"

definition
  Closed_Unbounded :: "(i=>o) => o" where
    "Closed_Unbounded(P) == Closed(P) \<and> Unbounded(P)"

subsubsection\<open>Simple facts about c.u. classes\<close>

lemma ClosedI:
     "[| !!I. [| I \<noteq> 0; \<forall>i\<in>I. Ord(i) \<and> P(i) |] ==> P(\<Union>(I)) |]
      ==> Closed(P)"
by (simp add: Closed_def)

lemma ClosedD:
     "[| Closed(P); I \<noteq> 0; !!i. i\<in>I ==> Ord(i); !!i. i\<in>I ==> P(i) |]
      ==> P(\<Union>(I))"
by (simp add: Closed_def)

lemma UnboundedD:
     "[| Unbounded(P);  Ord(i) |] ==> \<exists>j. i<j \<and> P(j)"
by (simp add: Unbounded_def)

lemma Closed_Unbounded_imp_Unbounded: "Closed_Unbounded(C) ==> Unbounded(C)"
by (simp add: Closed_Unbounded_def)

text\<open>The universal class, V, is closed and unbounded.
      A bit odd, since C. U. concerns only ordinals, but it's used below!\<close>
theorem Closed_Unbounded_V [simp]: "Closed_Unbounded(\<lambda>x. True)"
by (unfold Closed_Unbounded_def Closed_def Unbounded_def, blast)

text\<open>The class of ordinals, @{term Ord}, is closed and unbounded.\<close>
theorem Closed_Unbounded_Ord   [simp]: "Closed_Unbounded(Ord)"
by (unfold Closed_Unbounded_def Closed_def Unbounded_def, blast)

text\<open>The class of limit ordinals, @{term Limit}, is closed and unbounded.\<close>
theorem Closed_Unbounded_Limit [simp]: "Closed_Unbounded(Limit)"
apply (simp add: Closed_Unbounded_def Closed_def Unbounded_def Limit_Union,
       clarify)
apply (rule_tac x="i++nat" in exI)
apply (blast intro: oadd_lt_self oadd_LimitI Limit_nat Limit_has_0)
done

text\<open>The class of cardinals, @{term Card}, is closed and unbounded.\<close>
theorem Closed_Unbounded_Card  [simp]: "Closed_Unbounded(Card)"
apply (simp add: Closed_Unbounded_def Closed_def Unbounded_def Card_Union)
apply (blast intro: lt_csucc Card_csucc)
done

subsubsection\<open>The intersection of any set-indexed family of c.u. classes is
      c.u.\<close>

text\<open>The constructions below come from Kunen, \emph{Set Theory}, page 78.\<close>
locale cub_family =
  fixes P and A
  fixes next_greater \<comment> "the next ordinal satisfying class @{term A}"
  fixes sup_greater  \<comment> "sup of those ordinals over all @{term A}"
  assumes closed:    "a\<in>A ==> Closed(P(a))"
      and unbounded: "a\<in>A ==> Unbounded(P(a))"
      and A_non0: "A\<noteq>0"
  defines "next_greater(a,x) == \<mu> y. x<y \<and> P(a,y)"
      and "sup_greater(x) == \<Union>a\<in>A. next_greater(a,x)"

text\<open>Trivial that the intersection is closed.\<close>
lemma (in cub_family) Closed_INT: "Closed(\<lambda>x. \<forall>i\<in>A. P(i,x))"
by (blast intro: ClosedI ClosedD [OF closed])

text\<open>All remaining effort goes to show that the intersection is unbounded.\<close>

lemma (in cub_family) Ord_sup_greater:
     "Ord(sup_greater(x))"
by (simp add: sup_greater_def next_greater_def)

lemma (in cub_family) Ord_next_greater:
     "Ord(next_greater(a,x))"
by (simp add: next_greater_def Ord_Least)

text\<open>@{term next_greater} works as expected: it returns a larger value
and one that belongs to class @{term "P(a)"}.\<close>
lemma (in cub_family) next_greater_lemma:
     "[| Ord(x); a\<in>A |] ==> P(a, next_greater(a,x)) \<and> x < next_greater(a,x)"
apply (simp add: next_greater_def)
apply (rule exE [OF UnboundedD [OF unbounded]])
  apply assumption+
apply (blast intro: LeastI2 lt_Ord2)
done

lemma (in cub_family) next_greater_in_P:
     "[| Ord(x); a\<in>A |] ==> P(a, next_greater(a,x))"
by (blast dest: next_greater_lemma)

lemma (in cub_family) next_greater_gt:
     "[| Ord(x); a\<in>A |] ==> x < next_greater(a,x)"
by (blast dest: next_greater_lemma)

lemma (in cub_family) sup_greater_gt:
     "Ord(x) ==> x < sup_greater(x)"
apply (simp add: sup_greater_def)
apply (insert A_non0)
apply (blast intro: UN_upper_lt next_greater_gt Ord_next_greater)
done

lemma (in cub_family) next_greater_le_sup_greater:
     "a\<in>A ==> next_greater(a,x) \<le> sup_greater(x)"
apply (simp add: sup_greater_def)
apply (blast intro: UN_upper_le Ord_next_greater)
done

lemma (in cub_family) omega_sup_greater_eq_UN:
     "[| Ord(x); a\<in>A |]
      ==> sup_greater^\<omega> (x) =
          (\<Union>n\<in>nat. next_greater(a, sup_greater^n (x)))"
apply (simp add: iterates_omega_def)
apply (rule le_anti_sym)
apply (rule le_implies_UN_le_UN)
apply (blast intro: leI next_greater_gt Ord_iterates Ord_sup_greater)
txt\<open>Opposite bound:
@{subgoals[display,indent=0,margin=65]}
\<close>
apply (rule UN_least_le)
apply (blast intro: Ord_UN Ord_iterates Ord_sup_greater)
apply (rule_tac a="succ(n)" in UN_upper_le)
apply (simp_all add: next_greater_le_sup_greater)
apply (blast intro: Ord_UN Ord_iterates Ord_sup_greater)
done

lemma (in cub_family) P_omega_sup_greater:
     "[| Ord(x); a\<in>A |] ==> P(a, sup_greater^\<omega> (x))"
apply (simp add: omega_sup_greater_eq_UN)
apply (rule ClosedD [OF closed])
apply (blast intro: ltD, auto)
apply (blast intro: Ord_iterates Ord_next_greater Ord_sup_greater)
apply (blast intro: next_greater_in_P Ord_iterates Ord_sup_greater)
done

lemma (in cub_family) omega_sup_greater_gt:
     "Ord(x) ==> x < sup_greater^\<omega> (x)"
apply (simp add: iterates_omega_def)
apply (rule UN_upper_lt [of 1], simp_all)
 apply (blast intro: sup_greater_gt)
apply (blast intro: Ord_UN Ord_iterates Ord_sup_greater)
done

lemma (in cub_family) Unbounded_INT: "Unbounded(\<lambda>x. \<forall>a\<in>A. P(a,x))"
apply (unfold Unbounded_def)
apply (blast intro!: omega_sup_greater_gt P_omega_sup_greater)
done

lemma (in cub_family) Closed_Unbounded_INT:
     "Closed_Unbounded(\<lambda>x. \<forall>a\<in>A. P(a,x))"
by (simp add: Closed_Unbounded_def Closed_INT Unbounded_INT)

theorem Closed_Unbounded_INT:
    "(!!a. a\<in>A ==> Closed_Unbounded(P(a)))
     ==> Closed_Unbounded(\<lambda>x. \<forall>a\<in>A. P(a, x))"
apply (case_tac "A=0", simp)
apply (rule cub_family.Closed_Unbounded_INT [OF cub_family.intro])
apply (simp_all add: Closed_Unbounded_def)
done

lemma Int_iff_INT2:
     "P(x) \<and> Q(x)  \<longleftrightarrow>  (\<forall>i\<in>2. (i=0 \<longrightarrow> P(x)) \<and> (i=1 \<longrightarrow> Q(x)))"
by auto

theorem Closed_Unbounded_Int:
     "[| Closed_Unbounded(P); Closed_Unbounded(Q) |]
      ==> Closed_Unbounded(\<lambda>x. P(x) \<and> Q(x))"
apply (simp only: Int_iff_INT2)
apply (rule Closed_Unbounded_INT, auto)
done

subsection \<open>Normal Functions\<close>

definition
  mono_le_subset :: "(i=>i) => o" where
    "mono_le_subset(M) == \<forall>i j. i\<le>j \<longrightarrow> M(i) \<subseteq> M(j)"

definition
  mono_Ord :: "(i=>i) => o" where
    "mono_Ord(F) == \<forall>i j. i<j \<longrightarrow> F(i) < F(j)"

definition
  cont_Ord :: "(i=>i) => o" where
    "cont_Ord(F) == \<forall>l. Limit(l) \<longrightarrow> F(l) = (\<Union>i<l. F(i))"

definition
  Normal :: "(i=>i) => o" where
    "Normal(F) == mono_Ord(F) \<and> cont_Ord(F)"

subsubsection\<open>Immediate properties of the definitions\<close>

lemma NormalI:
     "[|!!i j. i<j ==> F(i) < F(j);  !!l. Limit(l) ==> F(l) = (\<Union>i<l. F(i))|]
      ==> Normal(F)"
by (simp add: Normal_def mono_Ord_def cont_Ord_def)

lemma mono_Ord_imp_Ord: "[| Ord(i); mono_Ord(F) |] ==> Ord(F(i))"
apply (auto simp add: mono_Ord_def)
apply (blast intro: lt_Ord)
done

lemma mono_Ord_imp_mono: "[| i<j; mono_Ord(F) |] ==> F(i) < F(j)"
by (simp add: mono_Ord_def)

lemma Normal_imp_Ord [simp]: "[| Normal(F); Ord(i) |] ==> Ord(F(i))"
by (simp add: Normal_def mono_Ord_imp_Ord)

lemma Normal_imp_cont: "[| Normal(F); Limit(l) |] ==> F(l) = (\<Union>i<l. F(i))"
by (simp add: Normal_def cont_Ord_def)

lemma Normal_imp_mono: "[| i<j; Normal(F) |] ==> F(i) < F(j)"
by (simp add: Normal_def mono_Ord_def)

lemma Normal_increasing:
  assumes i: "Ord(i)" and F: "Normal(F)" shows"i \<le> F(i)"
using i
proof (induct i rule: trans_induct3)
  case 0 thus ?case by (simp add: subset_imp_le F)
next
  case (succ i)
  hence "F(i) < F(succ(i))" using F
    by (simp add: Normal_def mono_Ord_def)
  thus ?case using succ.hyps
    by (blast intro: lt_trans1)
next
  case (limit l)
  hence "l = (\<Union>y<l. y)"
    by (simp add: Limit_OUN_eq)
  also have "... \<le> (\<Union>y<l. F(y))" using limit
    by (blast intro: ltD le_implies_OUN_le_OUN)
  finally have "l \<le> (\<Union>y<l. F(y))" .
  moreover have "(\<Union>y<l. F(y)) \<le> F(l)" using limit F
    by (simp add: Normal_imp_cont lt_Ord)
  ultimately show ?case
    by (blast intro: le_trans)
qed

subsubsection\<open>The class of fixedpoints is closed and unbounded\<close>

text\<open>The proof is from Drake, pages 113--114.\<close>

lemma mono_Ord_imp_le_subset: "mono_Ord(F) ==> mono_le_subset(F)"
apply (simp add: mono_le_subset_def, clarify)
apply (subgoal_tac "F(i)\<le>F(j)", blast dest: le_imp_subset)
apply (simp add: le_iff)
apply (blast intro: lt_Ord2 mono_Ord_imp_Ord mono_Ord_imp_mono)
done

text\<open>The following equation is taken for granted in any set theory text.\<close>
lemma cont_Ord_Union:
     "[| cont_Ord(F); mono_le_subset(F); X=0 \<longrightarrow> F(0)=0; \<forall>x\<in>X. Ord(x) |]
      ==> F(\<Union>(X)) = (\<Union>y\<in>X. F(y))"
apply (frule Ord_set_cases)
apply (erule disjE, force)
apply (thin_tac "X=0 \<longrightarrow> Q" for Q, auto)
 txt\<open>The trival case of @{term "\<Union>X \<in> X"}\<close>
 apply (rule equalityI, blast intro: Ord_Union_eq_succD)
 apply (simp add: mono_le_subset_def UN_subset_iff le_subset_iff)
 apply (blast elim: equalityE)
txt\<open>The limit case, @{term "Limit(\<Union>X)"}:
@{subgoals[display,indent=0,margin=65]}
\<close>
apply (simp add: OUN_Union_eq cont_Ord_def)
apply (rule equalityI)
txt\<open>First inclusion:\<close>
 apply (rule UN_least [OF OUN_least])
 apply (simp add: mono_le_subset_def, blast intro: leI)
txt\<open>Second inclusion:\<close>
apply (rule UN_least)
apply (frule Union_upper_le, blast, blast intro: Ord_Union)
apply (erule leE, drule ltD, elim UnionE)
 apply (simp add: OUnion_def)
 apply blast+
done

lemma Normal_Union:
     "[| X\<noteq>0; \<forall>x\<in>X. Ord(x); Normal(F) |] ==> F(\<Union>(X)) = (\<Union>y\<in>X. F(y))"
apply (simp add: Normal_def)
apply (blast intro: mono_Ord_imp_le_subset cont_Ord_Union)
done

lemma Normal_imp_fp_Closed: "Normal(F) ==> Closed(\<lambda>i. F(i) = i)"
apply (simp add: Closed_def ball_conj_distrib, clarify)
apply (frule Ord_set_cases)
apply (auto simp add: Normal_Union)
done

lemma iterates_Normal_increasing:
     "[| n\<in>nat;  x < F(x);  Normal(F) |]
      ==> F^n (x) < F^(succ(n)) (x)"
apply (induct n rule: nat_induct)
apply (simp_all add: Normal_imp_mono)
done

lemma Ord_iterates_Normal:
     "[| n\<in>nat;  Normal(F);  Ord(x) |] ==> Ord(F^n (x))"
by (simp add: Ord_iterates)

text\<open>THIS RESULT IS UNUSED\<close>
lemma iterates_omega_Limit:
     "[| Normal(F);  x < F(x) |] ==> Limit(F^\<omega> (x))"
apply (frule lt_Ord)
apply (simp add: iterates_omega_def)
apply (rule increasing_LimitI)
   \<comment>"this lemma is @{thm increasing_LimitI [no_vars]}"
 apply (blast intro: UN_upper_lt [of "1"]   Normal_imp_Ord
                     Ord_UN Ord_iterates lt_imp_0_lt
                     iterates_Normal_increasing, clarify)
apply (rule bexI)
 apply (blast intro: Ord_in_Ord [OF Ord_iterates_Normal])
apply (rule UN_I, erule nat_succI)
apply (blast intro:  iterates_Normal_increasing Ord_iterates_Normal
                     ltD [OF lt_trans1, OF succ_leI, OF ltI])
done

lemma iterates_omega_fixedpoint:
     "[| Normal(F); Ord(a) |] ==> F(F^\<omega> (a)) = F^\<omega> (a)"
apply (frule Normal_increasing, assumption)
apply (erule leE)
 apply (simp_all add: iterates_omega_triv [OF sym])  (*for subgoal 2*)
apply (simp add:  iterates_omega_def Normal_Union)
apply (rule equalityI, force simp add: nat_succI)
txt\<open>Opposite inclusion:
@{subgoals[display,indent=0,margin=65]}
\<close>
apply clarify
apply (rule UN_I, assumption)
apply (frule iterates_Normal_increasing, assumption, assumption, simp)
apply (blast intro: Ord_trans ltD Ord_iterates_Normal Normal_imp_Ord [of F])
done

lemma iterates_omega_increasing:
     "[| Normal(F); Ord(a) |] ==> a \<le> F^\<omega> (a)"
apply (unfold iterates_omega_def)
apply (rule UN_upper_le [of 0], simp_all)
done

lemma Normal_imp_fp_Unbounded: "Normal(F) ==> Unbounded(\<lambda>i. F(i) = i)"
apply (unfold Unbounded_def, clarify)
apply (rule_tac x="F^\<omega> (succ(i))" in exI)
apply (simp add: iterates_omega_fixedpoint)
apply (blast intro: lt_trans2 [OF _ iterates_omega_increasing])
done

theorem Normal_imp_fp_Closed_Unbounded:
     "Normal(F) ==> Closed_Unbounded(\<lambda>i. F(i) = i)"
by (simp add: Closed_Unbounded_def Normal_imp_fp_Closed
              Normal_imp_fp_Unbounded)

subsubsection\<open>Function \<open>normalize\<close>\<close>

text\<open>Function \<open>normalize\<close> maps a function \<open>F\<close> to a
      normal function that bounds it above.  The result is normal if and
      only if \<open>F\<close> is continuous: succ is not bounded above by any
      normal function, by @{thm [source] Normal_imp_fp_Unbounded}.
\<close>
definition
  normalize :: "[i=>i, i] => i" where
    "normalize(F,a) == transrec2(a, F(0), \<lambda>x r. F(succ(x)) \<union> succ(r))"

lemma Ord_normalize [simp, intro]:
     "[| Ord(a); !!x. Ord(x) ==> Ord(F(x)) |] ==> Ord(normalize(F, a))"
apply (induct a rule: trans_induct3)
apply (simp_all add: ltD def_transrec2 [OF normalize_def])
done

lemma normalize_increasing:
  assumes ab: "a < b" and F: "!!x. Ord(x) ==> Ord(F(x))"
  shows "normalize(F,a) < normalize(F,b)"
proof -
  { fix x
    have "Ord(b)" using ab by (blast intro: lt_Ord2)
    hence "x < b \<Longrightarrow> normalize(F,x) < normalize(F,b)"
    proof (induct b arbitrary: x rule: trans_induct3)
      case 0 thus ?case by simp
    next
      case (succ b)
      thus ?case
        by (auto simp add: le_iff def_transrec2 [OF normalize_def] intro: Un_upper2_lt F)
    next
      case (limit l)
      hence sc: "succ(x) < l"
        by (blast intro: Limit_has_succ)
      hence "normalize(F,x) < normalize(F,succ(x))"
        by (blast intro: limit elim: ltE)
      hence "normalize(F,x) < (\<Union>j<l. normalize(F,j))"
        by (blast intro: OUN_upper_lt lt_Ord F sc)
      thus ?case using limit
        by (simp add: def_transrec2 [OF normalize_def])
    qed
  } thus ?thesis using ab .
qed

theorem Normal_normalize:
     "(!!x. Ord(x) ==> Ord(F(x))) ==> Normal(normalize(F))"
apply (rule NormalI)
apply (blast intro!: normalize_increasing)
apply (simp add: def_transrec2 [OF normalize_def])
done

theorem le_normalize:
  assumes a: "Ord(a)" and coF: "cont_Ord(F)" and F: "!!x. Ord(x) ==> Ord(F(x))"
  shows "F(a) \<le> normalize(F,a)"
using a
proof (induct a rule: trans_induct3)
  case 0 thus ?case by (simp add: F def_transrec2 [OF normalize_def])
next
  case (succ a)
  thus ?case
    by (simp add: def_transrec2 [OF normalize_def] Un_upper1_le F )
next
  case (limit l)
  thus ?case using F coF [unfolded cont_Ord_def]
    by (simp add: def_transrec2 [OF normalize_def] le_implies_OUN_le_OUN ltD)
qed

subsection \<open>The Alephs\<close>
text \<open>This is the well-known transfinite enumeration of the cardinal
numbers.\<close>

definition
  Aleph :: "i => i"  ("\<aleph>_" [90] 90) where
    "Aleph(a) == transrec2(a, nat, \<lambda>x r. csucc(r))"

lemma Card_Aleph [simp, intro]:
     "Ord(a) ==> Card(Aleph(a))"
apply (erule trans_induct3)
apply (simp_all add: Card_csucc Card_nat Card_is_Ord
                     def_transrec2 [OF Aleph_def])
done

lemma Aleph_increasing:
  assumes ab: "a < b" shows "Aleph(a) < Aleph(b)"
proof -
  { fix x
    have "Ord(b)" using ab by (blast intro: lt_Ord2)
    hence "x < b \<Longrightarrow> Aleph(x) < Aleph(b)"
    proof (induct b arbitrary: x rule: trans_induct3)
      case 0 thus ?case by simp
    next
      case (succ b)
      thus ?case
        by (force simp add: le_iff def_transrec2 [OF Aleph_def]
                  intro: lt_trans lt_csucc Card_is_Ord)
    next
      case (limit l)
      hence sc: "succ(x) < l"
        by (blast intro: Limit_has_succ)
      hence "\<aleph> x < (\<Union>j<l. \<aleph>j)" using limit
        by (blast intro: OUN_upper_lt Card_is_Ord ltD lt_Ord)
      thus ?case using limit
        by (simp add: def_transrec2 [OF Aleph_def])
    qed
  } thus ?thesis using ab .
qed

theorem Normal_Aleph: "Normal(Aleph)"
apply (rule NormalI)
apply (blast intro!: Aleph_increasing)
apply (simp add: def_transrec2 [OF Aleph_def])
done

end


(*  Title:      HOL/Decision_Procs/Rat_Pair.thy
    Author:     Amine Chaieb
*)

section \<open>Rational numbers as pairs\<close>

theory Rat_Pair
  imports Complex_Main
begin

type_synonym Num = "int \<times> int"

abbreviation Num0_syn :: Num  (\<open>0\<^sub>N\<close>)
  where "0\<^sub>N \<equiv> (0, 0)"

abbreviation Numi_syn :: "int \<Rightarrow> Num"  (\<open>'((_)')\<^sub>N\<close>)
  where "(i)\<^sub>N \<equiv> (i, 1)"

definition isnormNum :: "Num \<Rightarrow> bool"
  where "isnormNum = (\<lambda>(a, b). if a = 0 then b = 0 else b > 0 \<and> gcd a b = 1)"

definition normNum :: "Num \<Rightarrow> Num"
  where "normNum = (\<lambda>(a,b).
    (if a = 0 \<or> b = 0 then (0, 0)
     else
      (let g = gcd a b
       in if b > 0 then (a div g, b div g) else (- (a div g), - (b div g)))))"

declare gcd_dvd1[presburger] gcd_dvd2[presburger]

lemma normNum_isnormNum [simp]: "isnormNum (normNum x)"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  consider "a = 0 \<or> b = 0" | "a \<noteq> 0" "b \<noteq> 0"
    by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      by (simp add: x normNum_def isnormNum_def)
  next
    case ab: 2
    let ?g = "gcd a b"
    let ?a' = "a div ?g"
    let ?b' = "b div ?g"
    let ?g' = "gcd ?a' ?b'"
    from ab have "?g \<noteq> 0" by simp
    with gcd_ge_0_int[of a b] have gpos: "?g > 0" by arith
    have gdvd: "?g dvd a" "?g dvd b" by arith+
    from dvd_mult_div_cancel[OF gdvd(1)] dvd_mult_div_cancel[OF gdvd(2)] ab
    have nz': "?a' \<noteq> 0" "?b' \<noteq> 0" by - (rule notI, simp)+
    from ab have stupid: "a \<noteq> 0 \<or> b \<noteq> 0" by arith
    from div_gcd_coprime[OF stupid] have gp1: "?g' = 1"
      by simp
    from ab consider "b < 0" | "b > 0" by arith
    then show ?thesis
    proof cases
      case b: 1
      have False if b': "?b' \<ge> 0"
      proof -
        from gpos have th: "?g \<ge> 0" by arith
        from mult_nonneg_nonneg[OF th b'] dvd_mult_div_cancel[OF gdvd(2)]
        show ?thesis using b by arith
      qed
      then have b': "?b' < 0" by (presburger add: linorder_not_le[symmetric])
      from ab(1) nz' b b' gp1 show ?thesis
        by (simp add: x isnormNum_def normNum_def Let_def split_def)
    next
      case b: 2
      then have "?b' \<ge> 0"
        by (presburger add: pos_imp_zdiv_nonneg_iff[OF gpos])
      with nz' have b': "?b' > 0" by arith
      from b b' ab(1) nz' gp1 show ?thesis
        by (simp add: x isnormNum_def normNum_def Let_def split_def)
    qed
  qed
qed

text \<open>Arithmetic over Num\<close>

definition Nadd :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl \<open>+\<^sub>N\<close> 60)
where
  "Nadd = (\<lambda>(a, b) (a', b').
    if a = 0 \<or> b = 0 then normNum (a', b')
    else if a' = 0 \<or> b' = 0 then normNum (a, b)
    else normNum (a * b' + b * a', b * b'))"

definition Nmul :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl \<open>*\<^sub>N\<close> 60)
where
  "Nmul = (\<lambda>(a, b) (a', b').
    let g = gcd (a * a') (b * b')
    in (a * a' div g, b * b' div g))"

definition Nneg :: "Num \<Rightarrow> Num" (\<open>~\<^sub>N\<close>)
  where "Nneg = (\<lambda>(a, b). (- a, b))"

definition Nsub :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl \<open>-\<^sub>N\<close> 60)
  where "Nsub = (\<lambda>a b. a +\<^sub>N ~\<^sub>N b)"

definition Ninv :: "Num \<Rightarrow> Num"
  where "Ninv = (\<lambda>(a, b). if a < 0 then (- b, \<bar>a\<bar>) else (b, a))"

definition Ndiv :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl \<open>\<div>\<^sub>N\<close> 60)
  where "Ndiv = (\<lambda>a b. a *\<^sub>N Ninv b)"

lemma Nneg_normN[simp]: "isnormNum x \<Longrightarrow> isnormNum (~\<^sub>N x)"
  by (simp add: isnormNum_def Nneg_def split_def)

lemma Nadd_normN[simp]: "isnormNum (x +\<^sub>N y)"
  by (simp add: Nadd_def split_def)

lemma Nsub_normN[simp]: "isnormNum y \<Longrightarrow> isnormNum (x -\<^sub>N y)"
  by (simp add: Nsub_def split_def)

lemma Nmul_normN[simp]:
  assumes xn: "isnormNum x"
    and yn: "isnormNum y"
  shows "isnormNum (x *\<^sub>N y)"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  consider "a = 0" | "a' = 0" | "a \<noteq> 0" "a' \<noteq> 0" by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      using xn x y by (simp add: isnormNum_def Let_def Nmul_def split_def)
  next
    case 2
    then show ?thesis
      using yn x y by (simp add: isnormNum_def Let_def Nmul_def split_def)
  next
    case aa': 3
    then have bp: "b > 0" "b' > 0"
      using xn yn x y by (simp_all add: isnormNum_def)
    from bp have "x *\<^sub>N y = normNum (a * a', b * b')"
      using x y aa' bp by (simp add: Nmul_def Let_def split_def normNum_def)
    then show ?thesis by simp
  qed
qed

lemma Ninv_normN[simp]: "isnormNum x \<Longrightarrow> isnormNum (Ninv x)"
  apply (simp add: Ninv_def isnormNum_def split_def)
  apply (cases "fst x = 0")
  apply (auto simp add: gcd.commute)
  done

lemma isnormNum_int[simp]: "isnormNum 0\<^sub>N" "isnormNum ((1::int)\<^sub>N)" "i \<noteq> 0 \<Longrightarrow> isnormNum (i)\<^sub>N"
  by (simp_all add: isnormNum_def)

text \<open>Relations over Num\<close>

definition Nlt0:: "Num \<Rightarrow> bool"  (\<open>0>\<^sub>N\<close>)
  where "Nlt0 = (\<lambda>(a, b). a < 0)"

definition Nle0:: "Num \<Rightarrow> bool"  (\<open>0\<ge>\<^sub>N\<close>)
  where "Nle0 = (\<lambda>(a, b). a \<le> 0)"

definition Ngt0:: "Num \<Rightarrow> bool"  (\<open>0<\<^sub>N\<close>)
  where "Ngt0 = (\<lambda>(a, b). a > 0)"

definition Nge0:: "Num \<Rightarrow> bool"  (\<open>0\<le>\<^sub>N\<close>)
  where "Nge0 = (\<lambda>(a, b). a \<ge> 0)"

definition Nlt :: "Num \<Rightarrow> Num \<Rightarrow> bool"  (infix \<open><\<^sub>N\<close> 55)
  where "Nlt = (\<lambda>a b. 0>\<^sub>N (a -\<^sub>N b))"

definition Nle :: "Num \<Rightarrow> Num \<Rightarrow> bool"  (infix \<open>\<le>\<^sub>N\<close> 55)
  where "Nle = (\<lambda>a b. 0\<ge>\<^sub>N (a -\<^sub>N b))"

definition "INum = (\<lambda>(a, b). of_int a / of_int b)"

lemma INum_int [simp]: "INum (i)\<^sub>N = (of_int i ::'a::field)" "INum 0\<^sub>N = (0::'a::field)"
  by (simp_all add: INum_def)

lemma isnormNum_unique[simp]:
  assumes na: "isnormNum x"
    and nb: "isnormNum y"
  shows "(INum x ::'a::field_char_0) = INum y \<longleftrightarrow> x = y"
  (is "?lhs = ?rhs")
proof
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  consider "a = 0 \<or> b = 0 \<or> a' = 0 \<or> b' = 0" | "a \<noteq> 0" "b \<noteq> 0" "a' \<noteq> 0" "b' \<noteq> 0"
    by blast
  then show ?rhs if H: ?lhs
  proof cases
    case 1
    then show ?thesis
      using na nb H by (simp add: x y INum_def split_def isnormNum_def split: if_split_asm)
  next
    case 2
    with na nb have pos: "b > 0" "b' > 0"
      by (simp_all add: x y isnormNum_def)
    from H \<open>b \<noteq> 0\<close> \<open>b' \<noteq> 0\<close> have eq: "a * b' = a' * b"
      by (simp add: x y INum_def eq_divide_eq divide_eq_eq of_int_mult[symmetric] del: of_int_mult)
    from \<open>a \<noteq> 0\<close> \<open>a' \<noteq> 0\<close> na nb
    have gcd1: "gcd a b = 1" "gcd b a = 1" "gcd a' b' = 1" "gcd b' a' = 1"
      by (simp_all add: x y isnormNum_def add: gcd.commute)
    then have "coprime a b" "coprime b a" "coprime a' b'" "coprime b' a'"
      by (simp_all add: coprime_iff_gcd_eq_1)
    from eq have raw_dvd: "a dvd a' * b" "b dvd b' * a" "a' dvd a * b'" "b' dvd b * a'"
      apply -
      apply algebra
      apply algebra
      apply simp
      apply algebra
      done
    then have eq1: "b = b'"
      using pos \<open>coprime b a\<close> \<open>coprime b' a'\<close>
      by (auto simp add: coprime_dvd_mult_left_iff intro: associated_eqI)
    with eq have "a = a'" using pos by simp
    with \<open>b = b'\<close> show ?thesis by (simp add: x y)
  qed
  show ?lhs if ?rhs
    using that by simp
qed

lemma isnormNum0[simp]: "isnormNum x \<Longrightarrow> INum x = (0::'a::field_char_0) \<longleftrightarrow> x = 0\<^sub>N"
  unfolding INum_int(2)[symmetric]
  by (rule isnormNum_unique) simp_all

lemma of_int_div_aux:
  assumes "d \<noteq> 0"
  shows "(of_int x ::'a::field_char_0) / of_int d =
    of_int (x div d) + (of_int (x mod d)) / of_int d"
proof -
  let ?t = "of_int (x div d) * (of_int d ::'a) + of_int (x mod d)"
  let ?f = "\<lambda>x. x / of_int d"
  have "x = (x div d) * d + x mod d"
    by auto
  then have eq: "of_int x = ?t"
    by (simp only: of_int_mult[symmetric] of_int_add [symmetric])
  then have "of_int x / of_int d = ?t / of_int d"
    using cong[OF refl[of ?f] eq] by simp
  then show ?thesis
    by (simp add: add_divide_distrib algebra_simps \<open>d \<noteq> 0\<close>)
qed

lemma of_int_div:
  fixes d :: int
  assumes "d \<noteq> 0" "d dvd n"
  shows "(of_int (n div d) ::'a::field_char_0) = of_int n / of_int d"
  using assms of_int_div_aux [of d n, where ?'a = 'a] by simp

lemma normNum[simp]: "INum (normNum x) = (INum x :: 'a::field_char_0)"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  consider "a = 0 \<or> b = 0" | "a \<noteq> 0" "b \<noteq> 0" by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      by (simp add: x INum_def normNum_def split_def Let_def)
  next
    case ab: 2
    let ?g = "gcd a b"
    from ab have g: "?g \<noteq> 0"by simp
    from of_int_div[OF g, where ?'a = 'a] show ?thesis
      by (auto simp add: x INum_def normNum_def split_def Let_def)
  qed
qed

lemma INum_normNum_iff: "(INum x ::'a::field_char_0) = INum y \<longleftrightarrow> normNum x = normNum y"
  (is "?lhs \<longleftrightarrow> _")
proof -
  have "normNum x = normNum y \<longleftrightarrow> (INum (normNum x) :: 'a) = INum (normNum y)"
    by (simp del: normNum)
  also have "\<dots> = ?lhs" by simp
  finally show ?thesis by simp
qed

lemma Nadd[simp]: "INum (x +\<^sub>N y) = INum x + (INum y :: 'a :: field_char_0)"
proof -
  let ?z = "0::'a"
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  consider "a = 0 \<or> a'= 0 \<or> b =0 \<or> b' = 0" | "a \<noteq> 0" "a'\<noteq> 0" "b \<noteq> 0" "b' \<noteq> 0"
    by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      apply (cases "a = 0")
      apply (simp_all add: x y Nadd_def)
      apply (cases "b = 0")
      apply (simp_all add: INum_def)
      apply (cases "a'= 0")
      apply simp_all
      apply (cases "b'= 0")
      apply simp_all
      done
  next
    case neq: 2
    show ?thesis
    proof (cases "a * b' + b * a' = 0")
      case True
      then have "of_int (a * b' + b * a') / (of_int b * of_int b') = ?z"
        by simp
      then have "of_int b' * of_int a / (of_int b * of_int b') +
          of_int b * of_int a' / (of_int b * of_int b') = ?z"
        by (simp add: add_divide_distrib)
      then have th: "of_int a / of_int b + of_int a' / of_int b' = ?z"
        using neq by simp
      from True neq show ?thesis
        by (simp add: x y th Nadd_def normNum_def INum_def split_def)
    next
      case False
      let ?g = "gcd (a * b' + b * a') (b * b')"
      have gz: "?g \<noteq> 0"
        using False by simp
      show ?thesis
        using neq False gz
          of_int_div [where ?'a = 'a, OF gz gcd_dvd1 [of "a * b' + b * a'" "b * b'"]]
          of_int_div [where ?'a = 'a, OF gz gcd_dvd2 [of "a * b' + b * a'" "b * b'"]]
        by (simp add: x y Nadd_def INum_def normNum_def Let_def) (simp add: field_simps)
    qed
  qed
qed

lemma Nmul[simp]: "INum (x *\<^sub>N y) = INum x * (INum y:: 'a::field_char_0)"
proof -
  let ?z = "0::'a"
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  consider "a = 0 \<or> a' = 0 \<or> b = 0 \<or> b' = 0" | "a \<noteq> 0" "a' \<noteq> 0" "b \<noteq> 0" "b' \<noteq> 0"
    by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      by (auto simp add: x y Nmul_def INum_def)
  next
    case neq: 2
    let ?g = "gcd (a * a') (b * b')"
    have gz: "?g \<noteq> 0"
      using neq by simp
    from neq of_int_div [where ?'a = 'a, OF gz gcd_dvd1 [of "a * a'" "b * b'"]]
      of_int_div [where ?'a = 'a , OF gz gcd_dvd2 [of "a * a'" "b * b'"]]
    show ?thesis
      by (simp add: Nmul_def x y Let_def INum_def)
  qed
qed

lemma Nneg[simp]: "INum (~\<^sub>N x) = - (INum x :: 'a::field)"
  by (simp add: Nneg_def split_def INum_def)

lemma Nsub[simp]: "INum (x -\<^sub>N y) = INum x - (INum y:: 'a::field_char_0)"
  by (simp add: Nsub_def split_def)

lemma Ninv[simp]: "INum (Ninv x) = (1 :: 'a::field) / INum x"
  by (simp add: Ninv_def INum_def split_def)

lemma Ndiv[simp]: "INum (x \<div>\<^sub>N y) = INum x / (INum y :: 'a::field_char_0)"
  by (simp add: Ndiv_def)

lemma Nlt0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "((INum x :: 'a::{field_char_0,linordered_field}) < 0) = 0>\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  show ?thesis
  proof (cases "a = 0")
    case True
    then show ?thesis
      by (simp add: x Nlt0_def INum_def)
  next
    case False
    then have b: "(of_int b::'a) > 0"
      using nx by (simp add: x isnormNum_def)
    from pos_divide_less_eq[OF b, where b="of_int a" and a="0::'a"]
    show ?thesis
      by (simp add: x Nlt0_def INum_def)
  qed
qed

lemma Nle0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "((INum x :: 'a::{field_char_0,linordered_field}) \<le> 0) = 0\<ge>\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  show ?thesis
  proof (cases "a = 0")
    case True
    then show ?thesis
      by (simp add: x Nle0_def INum_def)
  next
    case False
    then have b: "(of_int b :: 'a) > 0"
      using nx by (simp add: x isnormNum_def)
    from pos_divide_le_eq[OF b, where b="of_int a" and a="0::'a"]
    show ?thesis
      by (simp add: x Nle0_def INum_def)
  qed
qed

lemma Ngt0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "((INum x :: 'a::{field_char_0,linordered_field}) > 0) = 0<\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  show ?thesis
  proof (cases "a = 0")
    case True
    then show ?thesis
      by (simp add: x Ngt0_def INum_def)
  next
    case False
    then have b: "(of_int b::'a) > 0"
      using nx by (simp add: x isnormNum_def)
    from pos_less_divide_eq[OF b, where b="of_int a" and a="0::'a"]
    show ?thesis
      by (simp add: x Ngt0_def INum_def)
  qed
qed

lemma Nge0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "(INum x :: 'a::{field_char_0,linordered_field}) \<ge> 0 \<longleftrightarrow> 0\<le>\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  show ?thesis
  proof (cases "a = 0")
    case True
    then show ?thesis
      by (simp add: x Nge0_def INum_def)
  next
    case False
    then have b: "(of_int b::'a) > 0"
      using nx by (simp add: x isnormNum_def)
    from pos_le_divide_eq[OF b, where b="of_int a" and a="0::'a"]
    show ?thesis
      by (simp add: x Nge0_def INum_def)
  qed
qed

lemma Nlt_iff[simp]:
  assumes nx: "isnormNum x"
    and ny: "isnormNum y"
  shows "((INum x :: 'a::{field_char_0,linordered_field}) < INum y) \<longleftrightarrow> x <\<^sub>N y"
proof -
  let ?z = "0::'a"
  have "((INum x ::'a) < INum y) \<longleftrightarrow> INum (x -\<^sub>N y) < ?z"
    using nx ny by simp
  also have "\<dots> \<longleftrightarrow> 0>\<^sub>N (x -\<^sub>N y)"
    using Nlt0_iff[OF Nsub_normN[OF ny]] by simp
  finally show ?thesis
    by (simp add: Nlt_def)
qed

lemma Nle_iff[simp]:
  assumes nx: "isnormNum x"
    and ny: "isnormNum y"
  shows "((INum x :: 'a::{field_char_0,linordered_field}) \<le> INum y) \<longleftrightarrow> x \<le>\<^sub>N y"
proof -
  have "((INum x ::'a) \<le> INum y) \<longleftrightarrow> INum (x -\<^sub>N y) \<le> (0::'a)"
    using nx ny by simp
  also have "\<dots> \<longleftrightarrow> 0\<ge>\<^sub>N (x -\<^sub>N y)"
    using Nle0_iff[OF Nsub_normN[OF ny]] by simp
  finally show ?thesis
    by (simp add: Nle_def)
qed

lemma Nadd_commute:
  assumes "SORT_CONSTRAINT('a::field_char_0)"
  shows "x +\<^sub>N y = y +\<^sub>N x"
proof -
  have n: "isnormNum (x +\<^sub>N y)" "isnormNum (y +\<^sub>N x)"
    by simp_all
  have "(INum (x +\<^sub>N y)::'a) = INum (y +\<^sub>N x)"
    by simp
  with isnormNum_unique[OF n] show ?thesis
    by simp
qed

lemma normNum_nilpotent_aux[simp]:
  assumes "SORT_CONSTRAINT('a::field_char_0)"
  assumes nx: "isnormNum x"
  shows "normNum x = x"
proof -
  let ?a = "normNum x"
  have n: "isnormNum ?a" by simp
  have th: "INum ?a = (INum x ::'a)" by simp
  with isnormNum_unique[OF n nx] show ?thesis by simp
qed

lemma normNum_nilpotent[simp]:
  assumes "SORT_CONSTRAINT('a::field_char_0)"
  shows "normNum (normNum x) = normNum x"
  by simp

lemma normNum0[simp]: "normNum (0, b) = 0\<^sub>N" "normNum (a, 0) = 0\<^sub>N"
  by (simp_all add: normNum_def)

lemma normNum_Nadd:
  assumes "SORT_CONSTRAINT('a::field_char_0)"
  shows "normNum (x +\<^sub>N y) = x +\<^sub>N y"
  by simp

lemma Nadd_normNum1[simp]:
  assumes "SORT_CONSTRAINT('a::field_char_0)"
  shows "normNum x +\<^sub>N y = x +\<^sub>N y"
proof -
  have n: "isnormNum (normNum x +\<^sub>N y)" "isnormNum (x +\<^sub>N y)"
    by simp_all
  have "INum (normNum x +\<^sub>N y) = INum x + (INum y :: 'a)"
    by simp
  also have "\<dots> = INum (x +\<^sub>N y)"
    by simp
  finally show ?thesis
    using isnormNum_unique[OF n] by simp
qed

lemma Nadd_normNum2[simp]:
  assumes "SORT_CONSTRAINT('a::field_char_0)"
  shows "x +\<^sub>N normNum y = x +\<^sub>N y"
proof -
  have n: "isnormNum (x +\<^sub>N normNum y)" "isnormNum (x +\<^sub>N y)"
    by simp_all
  have "INum (x +\<^sub>N normNum y) = INum x + (INum y :: 'a)"
    by simp
  also have "\<dots> = INum (x +\<^sub>N y)"
    by simp
  finally show ?thesis
    using isnormNum_unique[OF n] by simp
qed

lemma Nadd_assoc:
  assumes "SORT_CONSTRAINT('a::field_char_0)"
  shows "x +\<^sub>N y +\<^sub>N z = x +\<^sub>N (y +\<^sub>N z)"
proof -
  have n: "isnormNum (x +\<^sub>N y +\<^sub>N z)" "isnormNum (x +\<^sub>N (y +\<^sub>N z))"
    by simp_all
  have "INum (x +\<^sub>N y +\<^sub>N z) = (INum (x +\<^sub>N (y +\<^sub>N z)) :: 'a)"
    by simp
  with isnormNum_unique[OF n] show ?thesis
    by simp
qed

lemma Nmul_commute: "isnormNum x \<Longrightarrow> isnormNum y \<Longrightarrow> x *\<^sub>N y = y *\<^sub>N x"
  by (simp add: Nmul_def split_def Let_def gcd.commute mult.commute)

lemma Nmul_assoc:
  assumes "SORT_CONSTRAINT('a::field_char_0)"
  assumes nx: "isnormNum x"
    and ny: "isnormNum y"
    and nz: "isnormNum z"
  shows "x *\<^sub>N y *\<^sub>N z = x *\<^sub>N (y *\<^sub>N z)"
proof -
  from nx ny nz have n: "isnormNum (x *\<^sub>N y *\<^sub>N z)" "isnormNum (x *\<^sub>N (y *\<^sub>N z))"
    by simp_all
  have "INum (x +\<^sub>N y +\<^sub>N z) = (INum (x +\<^sub>N (y +\<^sub>N z)) :: 'a)"
    by simp
  with isnormNum_unique[OF n] show ?thesis
    by simp
qed

lemma Nsub0:
  assumes "SORT_CONSTRAINT('a::field_char_0)"
  assumes x: "isnormNum x"
    and y: "isnormNum y"
  shows "x -\<^sub>N y = 0\<^sub>N \<longleftrightarrow> x = y"
proof -
  from isnormNum_unique[where 'a = 'a, OF Nsub_normN[OF y], where y="0\<^sub>N"]
  have "x -\<^sub>N y = 0\<^sub>N \<longleftrightarrow> INum (x -\<^sub>N y) = (INum 0\<^sub>N :: 'a)"
    by simp
  also have "\<dots> \<longleftrightarrow> INum x = (INum y :: 'a)"
    by simp
  also have "\<dots> \<longleftrightarrow> x = y"
    using x y by simp
  finally show ?thesis .
qed

lemma Nmul0[simp]: "c *\<^sub>N 0\<^sub>N = 0\<^sub>N" " 0\<^sub>N *\<^sub>N c = 0\<^sub>N"
  by (simp_all add: Nmul_def Let_def split_def)

lemma Nmul_eq0[simp]:
  assumes "SORT_CONSTRAINT('a::field_char_0)"
  assumes nx: "isnormNum x"
    and ny: "isnormNum y"
  shows "x*\<^sub>N y = 0\<^sub>N \<longleftrightarrow> x = 0\<^sub>N \<or> y = 0\<^sub>N"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  have n0: "isnormNum 0\<^sub>N" by simp
  show ?thesis using nx ny
    apply (simp only: isnormNum_unique[where ?'a = 'a, OF  Nmul_normN[OF nx ny] n0, symmetric]
      Nmul[where ?'a = 'a])
    apply (simp add: x y INum_def split_def isnormNum_def split: if_split_asm)
    done
qed

lemma Nneg_Nneg[simp]: "~\<^sub>N (~\<^sub>N c) = c"
  by (simp add: Nneg_def split_def)

lemma Nmul1[simp]: "isnormNum c \<Longrightarrow> (1)\<^sub>N *\<^sub>N c = c" "isnormNum c \<Longrightarrow> c *\<^sub>N (1)\<^sub>N = c"
  apply (simp_all add: Nmul_def Let_def split_def isnormNum_def)
  apply (cases "fst c = 0", simp_all, cases c, simp_all)+
  done

end


theory Interleave imports "HOL-Library.Multiset" SelfInv begin

inductive
  interleave :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  interleave_Nil_NilI[intro]:   "interleave [] [] []" |
  interleave_Cons_FreeI[intro]: "\<lbrakk> interleave xs ys zs \<rbrakk> \<Longrightarrow> interleave (x#xs) ys (x#zs)" |
  interleave_Free_ConsI[intro]: "\<lbrakk> interleave xs ys zs \<rbrakk> \<Longrightarrow> interleave xs (y#ys) (y#zs)"

inductive_cases interleave_Free_Free_NilE: "interleave xs ys []"
inductive_cases interleave_Free_Free_ConsE: "interleave xs ys (z#zs)"
inductive_cases interleave_Nil_Nil_FreeE: "interleave [] [] zs"
inductive_cases interleave_Nil_Free_FreeE: "interleave [] ys zs"
inductive_cases interleave_Free_Nil_FreeE: "interleave xs [] zs"
inductive_cases interleave_Cons_Free_FreeE: "interleave (x#xs) ys zs"
inductive_cases interleave_Free_Cons_FreeE: "interleave xs (y#ys) zs"
inductive_cases interleave_Free_Cons_ConsE: "interleave xs (y#ys) (z#zs)"
inductive_cases interleave_Cons_Cons_FreeE: "interleave (x#xs) (y#ys) zs"
inductive_cases interleave_Cons_Cons_ConsE: "interleave (x#xs) (y#ys) (z#zs)"

lemma interleave_Free_Free_Nil: "interleave xs ys [] \<longleftrightarrow> xs = [] \<and> ys = []"
  apply(auto elim: interleave_Free_Free_NilE)
  done

theorem interleave_left_neutralI[rule_format]: "\<forall>zs. ys = zs \<longrightarrow> interleave [] ys zs"
  apply(induct_tac ys)
  apply(auto)
  done

theorem interleave_left_neutralD[rule_format]: "\<forall>ys. interleave [] ys zs \<longrightarrow> ys = zs"
  apply(induct zs)
  apply(auto elim: interleave_Free_Free_NilE)
  apply(erule interleave.cases)
  apply(auto)
  done

theorem interleave_left_neutral: "interleave [] ys zs \<longleftrightarrow> ys = zs"
  apply(rule iffI)
  apply(erule interleave_left_neutralD)
  apply(erule interleave_left_neutralI)
  done

theorem interleave_flip[rule_format]: "\<forall>xs ys. interleave xs ys zs \<longleftrightarrow> interleave ys xs zs"
  apply(induct_tac zs)
  apply(auto elim!: interleave_Free_Free_NilE interleave_Free_Free_ConsE)
  done

theorem interleave_right_neutral: "interleave xs [] zs \<longleftrightarrow> xs = zs"
  apply(subst interleave_flip)
  apply(rule interleave_left_neutral)
  done

theorem interleave_count[rule_format]: "\<forall>xs ys. interleave xs ys zs \<longrightarrow> mset xs + mset ys = mset zs"
  apply(induct_tac zs)
  apply(auto elim: interleave_Free_Free_NilE interleave_Free_Free_ConsE)
  done

theorem interleave_ex_concat: "\<forall>ys. interleave xs ys (xs@ys)"
  apply(induct_tac xs)
  apply(auto intro: interleave_left_neutralI)
  done

lemma list_double_induct[rule_format]: "P [] [] \<longrightarrow> (\<forall>x xs ys. P xs ys \<longrightarrow> P (x#xs) ys) \<longrightarrow> (\<forall>y xs ys. P xs ys \<longrightarrow> P xs (y#ys)) \<longrightarrow> P xs ys"
  apply(induct_tac xs)
  apply(induct_tac ys)
  apply(auto)
  done

lemma list_double_rev_induct[rule_format]: "P [] [] \<longrightarrow> (\<forall>x xs ys. P xs ys \<longrightarrow> P (xs@[x]) ys) \<longrightarrow> (\<forall>y xs ys. P xs ys \<longrightarrow> P xs (ys@[y])) \<longrightarrow> P xs ys"
  apply(rule_tac xs=xs in rev_induct)
  apply(rule_tac xs=ys in rev_induct)
  apply(auto)
  done

lemma interleave_Nil_Free_Free_rev: "interleave [] ys zs \<longleftrightarrow> interleave [] (rev ys) (rev zs)"
  apply(subst (1 2) interleave_left_neutral)
  apply(force)
  done

lemma interleave_Free_Nil_Free_rev: "interleave xs [] zs \<longleftrightarrow> interleave (rev xs) [] (rev zs)"
  apply(subst (1 2) interleave_flip)
  apply(rule interleave_Nil_Free_Free_rev)
  done

lemma interleave_append_Free_appendI[rule_format]: "\<forall>xs ys z x. interleave xs ys zs \<longrightarrow> x = z \<longrightarrow> interleave (xs@[x]) ys (zs@[z])"
  apply(induct zs)
  apply(force simp: interleave_Free_Free_Nil)
  apply(clarsimp)
  apply(erule interleave_Free_Free_ConsE)
  apply(auto)
  done

lemma interleave_Free_append_appendI[rule_format]: "interleave xs ys zs \<longrightarrow> y = z \<longrightarrow> interleave xs (ys@[y]) (zs@[z])"
  apply(subst (1 2) interleave_flip)
  apply(force elim: interleave_append_Free_appendI)
  done

lemma interleave_revI[rule_format]: "\<forall>xs ys. interleave xs ys zs \<longrightarrow> interleave (rev xs) (rev ys) (rev zs)"
  apply(induct zs)
  apply(force elim: interleave_Free_Free_NilE)
  apply(clarsimp)
  apply(erule interleave_Free_Free_ConsE)
  apply(simp add: interleave_append_Free_appendI)
  apply(simp add: interleave_Free_append_appendI)
  done

lemma interleave_revD[rule_format]: "interleave (rev xs) (rev ys) (rev zs) \<longrightarrow> interleave xs ys zs"
  apply(subgoal_tac "\<exists>xs' ys' zs'. rev xs = xs' \<and> rev ys = ys' \<and> rev zs = zs' \<and> xs = rev xs' \<and> ys = rev ys' \<and> zs = rev zs'")
  apply(elim exE)
  apply(elim conjE)
  apply(erule ssubst)+
  apply(rule impI)
  apply(erule interleave_revI)
  apply(auto)
  done

lemma interleave_rev: "interleave (rev xs) (rev ys) (rev zs) \<longleftrightarrow> interleave xs ys zs"
  apply(rule iffI)
  apply(erule interleave_revD)
  apply(erule interleave_revI)
  done

lemma interleave_mapI[rule_format]: "\<forall>xs ys. interleave xs ys zs \<longrightarrow> interleave (map f ys) (map f xs) (map f zs)"
  apply(induct_tac zs)
  apply(force elim: interleave_Free_Free_NilE)
  apply(clarsimp)
  apply(erule interleave_Free_Free_ConsE)
  apply(auto)
  done

lemma interleave_single_single: "interleave [x] [y] zs \<longleftrightarrow> zs = [x, y] \<or> zs = [y, x]"
  apply(rule iffI)
  apply(erule interleave.cases)
  apply(auto simp: interleave_left_neutral interleave_right_neutral)
  done
end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Intermission: upper bound on the cardinality of the continuum (HOL)\<close>
theory HOL_CContinuum
  imports CZH_Sets_Introduction
begin

text\<open>
The section presents a proof of \<open>|\<real>|\<le>|\<P>(\<nat>)|\<close> in Isabelle/HOL. The proof is
based on an outline at the beginning of Chapter 4 in the textbook
\<open>Set Theory\<close> by Thomas Jech \<^cite>\<open>"jech_set_2006"\<close>.
\<close>

lemma Pow_lepoll_mono:
  assumes "A \<lesssim> B"
  shows "Pow A \<lesssim> Pow B"
  using assms by (metis Pow_mono image_Pow_surj lepoll_iff)

lemma rat_lepoll_nat: "(UNIV::rat set) \<lesssim> (UNIV::nat set)"
  unfolding lepoll_def by auto

definition rcut :: "real \<Rightarrow> real set" where "rcut r = {x\<in>\<rat>. x < r}"

lemma inj_rcut: "inj rcut"
  unfolding rcut_def
proof(intro inj_onI)
  have xy: "x < y \<Longrightarrow> {r\<in>\<rat>. r < x} = {r\<in>\<rat>. r < y} \<Longrightarrow> x = y" for x y :: real
  proof(rule ccontr)
    assume prems: "x < y" "{r\<in>\<rat>. r < x} = {r\<in>\<rat>. r < y}"
    then have "{r\<in>\<rat>. r < y} - {r\<in>\<rat>. r < x} = {}" by simp
    with prems(1) Rats_dense_in_real show False by force
  qed
  then have yx: "y < x \<Longrightarrow> {r\<in>\<rat>. r < x} = {r\<in>\<rat>. r < y} \<Longrightarrow> x = y"
    for x y :: real
    by auto
  show "{z \<in> \<rat>. z < x} = {z \<in> \<rat>. z < y} \<Longrightarrow> x = y" for x y :: real
  proof(rule ccontr)
    fix x y :: real assume prems: "{xa \<in> \<rat>. xa < x} = {x \<in> \<rat>. x < y}" "x \<noteq> y"
    from this(2) consider "x < y" | "y < x" by force
    with xy[OF _ prems(1)] yx[OF _ prems(1)] show False by cases auto
  qed
qed

lemma range_rcut_subset_Pow_rat: "range rcut \<subseteq> Pow \<rat>"
proof(intro subsetI)
  fix x assume "x \<in> range rcut"
  then obtain r where "x = {x\<in>\<rat>. x < r}" unfolding rcut_def by clarsimp
  then show "x \<in> Pow \<rat>" by simp
qed

lemma inj_on_inv_of_rat_rat: "inj_on (inv of_rat) \<rat>"
  using inv_into_injective by (intro inj_onI) (fastforce simp: Rats_def)

lemma inj_on_inv_image_inv_of_rat_Pow_rat: "inj_on (image (inv of_rat)) (Pow \<rat>)"
  by (simp add: inj_on_inv_of_rat_rat inj_on_image_Pow)

lemma inj_on_image_inv_of_rat_range_rcut:
  "inj_on (image (inv of_rat)) (range rcut)"
  using range_rcut_subset_Pow_rat inj_on_inv_image_inv_of_rat_Pow_rat
  by (auto intro: inj_on_subset)

lemma real_lepoll_ratrat: "(UNIV::real set) \<lesssim> (UNIV::rat set set)"
  unfolding lepoll_def
proof(intro exI conjI)
  from inj_rcut inj_on_image_inv_of_rat_range_rcut show
    "inj (image (inv of_rat) \<circ> rcut)"
    by (rule comp_inj_on)
qed auto

lemma nat_lepoll_real: "(UNIV::nat set) \<lesssim> (UNIV::real set)"
  using infinite_UNIV_char_0 infinite_countable_subset
  unfolding lepoll_def
  by blast

lemma real_lepoll_natnat: "(UNIV::real set) \<lesssim> Pow (UNIV::nat set)"
proof-
  have "(UNIV::rat set set) \<lesssim> (UNIV::nat set set)"
    unfolding Pow_UNIV[symmetric] by (intro Pow_lepoll_mono rat_lepoll_nat)
  from lepoll_trans[OF real_lepoll_ratrat this] show ?thesis by simp
qed

text\<open>\newpage\<close>

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_StoogeSortPermutes
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun reverse :: "'a list => 'a list" where
  "reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv y z = (if lt y z then Z else S (idiv (minus y z) z))"
  by pat_completeness auto

fun elem :: "'a => 'a list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "Nat list => Nat list"
  and stoogesort :: "Nat list => Nat list"
  and stooge1sort1 :: "Nat list => Nat list" where
  "stooge1sort2 y =
   (case splitAt (idiv (length y) (S (S (S Z)))) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt (idiv (length y) (S (S (S Z)))) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (stoogesort xs) xs"
  oops

end


theory SINVAR_BLPbasic
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant Basic Bell LaPadula  *}

type_synonym security_level = nat

definition default_node_properties :: "security_level"
  where  "default_node_properties \<equiv> 0"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> security_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (nP e1) \<le> (nP e2))"

text{* What we call a @{typ security_level} is also referred to as security label
(or security clearance of subjects and classification of objects) in the literature.
The lowest security level is @{term "0::nat"}, which can be understood as unclassified.
Consequently, 1 = confidential, 2 = secret, 3 = topSecret, ....
The total order of the security levels corresponds to the total order of the natural numbers @{text \<le>}.
It is important that there is smallest security level (i.e. @{const default_node_properties}),
otherwise, a unique and secure default parameter could not exist.
Hence, it is not possible to extend the security levels to @{typ int} to model unlimited ``un-confidentialness''.
*}

definition receiver_violation :: "bool" where "receiver_violation \<equiv> True"

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[6]
   apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[1]
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

lemma BLP_def_unique: "otherbot \<noteq> 0 \<Longrightarrow>
    \<exists>G p i f. wf_graph G \<and> \<not> sinvar G p \<and> f \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G p) \<and>
       sinvar (delete_edges G f) p \<and>
        i \<in> snd ` f \<and> sinvar G (p(i := otherbot)) "
  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: prod.split_asm prod.split)
  apply(rule_tac x="\<lparr> nodes=set [vertex_1,vertex_2], edges = set [(vertex_1,vertex_2)] \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: wf_graph_def)
  apply(rule_tac x="(\<lambda> x. 0)(vertex_1 := 1, vertex_2 := 0)" in exI, simp)
  apply(rule_tac x="vertex_2" in exI, simp)
  apply(rule_tac x="set [(vertex_1,vertex_2)]" in exI, simp)
  done

(*Test instantiation without any fancy lemmata*)
(*
interpretation SecurityInvariant
where default_node_properties = default_node_properties
and sinvar = sinvar
and receiver_violation = receiver_violation
  unfolding default_node_properties_def
  unfolding receiver_violation_def
  apply unfold_locales

  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: prod.split_asm prod.split add:case_prod_beta)
   apply(auto intro!:bexI)[1]
   (*apply (smt image_iff offending_in_edges prod.collapse)*)
  apply(blast intro: BLP_def_unique)
done
*)

subsubsection {*ENF*}
  lemma zero_default_candidate: "\<And> nP e1 e2. \<not> (op \<le>::security_level \<Rightarrow> security_level \<Rightarrow> bool) (nP e1) (nP e2) \<Longrightarrow> \<not> (op \<le>) (nP e1) 0"
    by simp_all
  lemma zero_default_candidate_rule: "\<And> (nP::('v \<Rightarrow> security_level)) e1 e2. \<not> (nP e1) \<le> (nP e2) \<Longrightarrow> \<not> (nP e1) \<le> 0"
    by simp_all
  lemma privacylevel_refl: "(op \<le>::security_level \<Rightarrow> security_level \<Rightarrow> bool) e e"
    by(simp_all)
  lemma BLP_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar (op \<le>)"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    by simp
  lemma BLP_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar (op \<le>)"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: BLP_ENF)
    apply(simp add: privacylevel_refl)
  done

  definition BLP_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> security_level) \<Rightarrow> ('v \<times> 'v) set set" where
  "BLP_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> (nP e1) > (nP e2)} })"
  lemma BLP_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply(simp only: fun_eq_iff SecurityInvariant_withOffendingFlows.ENF_offending_set[OF BLP_ENF] BLP_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

  interpretation BLPbasic: SecurityInvariant_IFS sinvar default_node_properties
  rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    unfolding receiver_violation_def
    unfolding default_node_properties_def
    apply(unfold_locales)
      apply(rule ballI)
      apply(rule SecurityInvariant_withOffendingFlows.ENF_snds_refl_instance[OF BLP_ENF_refl])
         apply(simp_all add: BLP_ENF BLP_ENF_refl)[3]
     apply(erule default_uniqueness_by_counterexample_IFS)
     apply(fact BLP_def_unique)
    apply(fact BLP_offending_set)
   done

  lemma TopoS_BLPBasic: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

text{*Alternate definition of the @{const sinvar}:
      For all reachable nodes, the security level is higher*}
lemma sinvar_BLPbasic_tancl:
  "wf_graph G \<Longrightarrow> sinvar G nP = (\<forall> v \<in> nodes G. \<forall>v' \<in> succ_tran G v. (nP v) \<le> (nP v'))"
  proof(unfold sinvar.simps, rule iffI, goal_cases)
  case 1
      have "(v, v') \<in> (edges G)\<^sup>+ \<Longrightarrow> nP v \<le> nP v'" for v v'
        proof(induction rule: trancl_induct)
        case base thus ?case using 1(2) by fastforce
        next
        case step thus ?case using 1(2) by fastforce
        qed
      thus ?case
      by(simp add: succ_tran_def)
    next
    case 2
      from 2(1)[simplified wf_graph_def] have f1: "fst ` edges G \<subseteq> nodes G" by simp
      from f1 2(2) have "\<forall>v \<in> (fst ` edges G). \<forall>v'\<in>succ_tran G v. nP v \<le> nP v'" by auto
      thus ?case unfolding succ_tran_def by fastforce
  qed

hide_fact (open) sinvar_mono
hide_fact BLP_def_unique zero_default_candidate zero_default_candidate_rule privacylevel_refl BLP_ENF BLP_ENF_refl

hide_const (open) sinvar receiver_violation default_node_properties

end


theory ExF016
  imports Main
begin

lemma "(\<exists>x. (P x \<longrightarrow> \<not>P(F x))) \<longrightarrow> (\<exists>x. \<not>P x)"
proof -
  {
    assume a:"\<exists>x. (P x \<longrightarrow> \<not>P(F x))"
    {
      assume b:"\<not>(\<exists>x . \<not>P x )"
      {
        fix aa
        assume c:"P aa \<longrightarrow> \<not>P(F aa)"
        {
          assume "P aa"
          with c have "\<not>P (F aa)" by (rule mp)
          hence "\<exists>x. \<not>P (x)" by (rule exI)
          with b have False by contradiction
        }
        hence "\<not>P aa" by (rule notI)
        hence "\<exists>x. \<not>P x" by (rule exI)
        with b have False by contradiction
      }
      with a have False by (rule exE)
    }
    hence "\<not>\<not>(\<exists>x . \<not>P x )" by (rule notI)
    hence "\<exists>x . \<not>P x " by (rule notnotD)
  }
  thus ?thesis by (rule impI)
qed


(*  Title:      CTT/ex/Equality.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section "Equality reasoning by rewriting"

theory Equality
imports "../CTT"
begin

lemma split_eq: "p : Sum(A,B) \<Longrightarrow> split(p,pair) = p : Sum(A,B)"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply rew
done

lemma when_eq: "\<lbrakk>A type; B type; p : A+B\<rbrakk> \<Longrightarrow> when(p,inl,inr) = p : A + B"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply rew
done

(*in the "rec" formulation of addition, 0+n=n *)
lemma "p:N \<Longrightarrow> rec(p,0, \<lambda>y z. succ(y)) = p : N"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply rew
done

(*the harder version, n+0=n: recursive, uses induction hypothesis*)
lemma "p:N \<Longrightarrow> rec(p,0, \<lambda>y z. succ(z)) = p : N"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply hyp_rew
done

(*Associativity of addition*)
lemma "\<lbrakk>a:N; b:N; c:N\<rbrakk>
  \<Longrightarrow> rec(rec(a, b, \<lambda>x y. succ(y)), c, \<lambda>x y. succ(y)) =
    rec(a, rec(b, c, \<lambda>x y. succ(y)), \<lambda>x y. succ(y)) : N"
apply (NE a)
apply hyp_rew
done

(*Martin-Löf (1984) page 62: pairing is surjective*)
lemma "p : Sum(A,B) \<Longrightarrow> <split(p,\<lambda>x y. x), split(p,\<lambda>x y. y)> = p : Sum(A,B)"
apply (rule EqE)
apply (rule elim_rls, assumption)
apply (tactic \<open>DEPTH_SOLVE_1 (rew_tac @{context} [])\<close>) (*!!!!!!!*)
done

lemma "\<lbrakk>a : A; b : B\<rbrakk> \<Longrightarrow> (\<^bold>\<lambda>u. split(u, \<lambda>v w.<w,v>)) ` <a,b> = <b,a> : \<Sum>x:B. A"
apply rew
done

(*a contrived, complicated simplication, requires sum-elimination also*)
lemma "(\<^bold>\<lambda>f. \<^bold>\<lambda>x. f`(f`x)) ` (\<^bold>\<lambda>u. split(u, \<lambda>v w.<w,v>)) =
      \<^bold>\<lambda>x. x  :  \<Prod>x:(\<Sum>y:N. N). (\<Sum>y:N. N)"
apply (rule reduction_rls)
apply (rule_tac [3] intrL_rls)
apply (rule_tac [4] EqE)
apply (erule_tac [4] SumE)
(*order of unifiers is essential here*)
apply rew
done

end


(* Title:      Demonic refinement algebra
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Models for Demonic Refinement Algebra with Tests\<close>

theory DRA_Models
  imports DRAT
begin

text \<open>
  We formalise the predicate transformer model of demonic refinement algebra.
  Predicate transformers are formalised as strict and additive functions over a field of sets,
  or alternatively as costrict and multiplicative functions.
  In the future, this should be merged with Preoteasa's more abstract formalisation~\<^cite>\<open>"Preoteasa11"\<close>.
\<close>

no_notation
  plus (infixl "+" 65) and
  less_eq  ("'(\<le>')") and
  less_eq  ("(_/ \<le> _)"  [51, 51] 50)

notation comp (infixl "\<cdot>" 55)

type_synonym 'a bfun = "'a set \<Rightarrow> 'a set"

text \<open>
  Definitions of signature:
\<close>

definition top :: "'a bfun" where "top \<equiv> \<lambda>x. UNIV"
definition bot :: "'a bfun" where "bot \<equiv> \<lambda>x. {}"
definition adjoint :: "'a bfun \<Rightarrow> 'a bfun" where "adjoint f \<equiv> (\<lambda>p. - f (-p))"

definition fun_inter :: "'a bfun \<Rightarrow> 'a bfun \<Rightarrow> 'a bfun" (infix "\<sqinter>" 51) where
  "f \<sqinter> g \<equiv> \<lambda>p. f p \<inter> g p"

definition fun_union :: "'a bfun \<Rightarrow> 'a bfun \<Rightarrow> 'a bfun" (infix "+" 52) where
  "f + g \<equiv> \<lambda>p. f p \<union> g p"

definition fun_order :: "'a bfun \<Rightarrow> 'a bfun \<Rightarrow> bool" (infix "\<le>" 50) where
  "f \<le> g \<equiv> \<forall>p. f p \<subseteq> g p"

definition fun_strict_order :: "'a bfun \<Rightarrow> 'a bfun \<Rightarrow> bool" (infix "<." 50) where
  "f <. g \<equiv> f \<le> g \<and> f \<noteq> g"

definition N :: "'a bfun \<Rightarrow> 'a bfun" where
  "N f \<equiv> ((adjoint f o bot) \<sqinter> id)"

lemma top_max: "f \<le> top"
  by (auto simp: top_def fun_order_def)

lemma bot_min: "bot \<le> f"
  by (auto simp: bot_def fun_order_def)

lemma oder_def: "f \<sqinter> g = f \<Longrightarrow> f \<le> g"
  by (metis fun_inter_def fun_order_def le_iff_inf)

lemma order_def_var: "f \<le> g \<Longrightarrow> f \<sqinter> g = f"
  by (auto simp: fun_inter_def fun_order_def)

lemma adjoint_idem [simp]: "adjoint (adjoint f) = f"
  by (auto simp: adjoint_def)

lemma adjoint_prop1[simp]: "(f o top) \<sqinter> (adjoint f o bot) = bot"
  by (auto simp: fun_inter_def adjoint_def bot_def top_def)

lemma adjoint_prop2[simp]: "(f o top) + (adjoint f o bot) = top"
  by (auto simp: fun_union_def adjoint_def bot_def top_def)

lemma adjoint_mult: "adjoint (f o g) = adjoint f o adjoint g"
  by (auto simp: adjoint_def)

lemma adjoint_top[simp]: "adjoint top = bot"
  by (auto simp: adjoint_def bot_def top_def)

lemma N_comp1: "(N (N f)) + N f = id"
  by (auto simp: fun_union_def N_def fun_inter_def adjoint_def bot_def)

lemma N_comp2: "(N (N f)) o N f = bot"
  by (auto simp: N_def fun_inter_def adjoint_def bot_def)

lemma N_comp3: "N f o (N (N f)) = bot"
  by (auto simp: N_def fun_inter_def adjoint_def bot_def)

lemma N_de_morgan: "N (N f) o N (N g) = N (N f) \<sqinter> N (N g)"
  by (auto simp: fun_union_def N_def fun_inter_def adjoint_def bot_def)

lemma conj_pred_aux [simp]: "(\<lambda>p. x p \<union> y p) = y \<Longrightarrow> \<forall>p. x p \<subseteq> y p"
  by (metis Un_upper1)

text \<open>
  Next, we define a type for conjuctive or multiplicative predicate transformers.
\<close>

typedef 'a bool_op = "{f::'a bfun. (\<forall>g h. mono f \<and> f \<circ> g + f \<circ> h = f \<circ> (g + h) \<and> bot o f = bot)}"
  apply (rule_tac x="\<lambda>x. x" in exI)
  apply auto
  apply (metis monoI)
  by (auto simp: fun_order_def fun_union_def)

setup_lifting type_definition_bool_op

text \<open>
  Conjuctive predicate transformers form a dioid with tests without right annihilator.
\<close>

instantiation bool_op :: (type) dioid_one_zerol
begin
  lift_definition less_eq_bool_op :: "'a bool_op \<Rightarrow> 'a bool_op \<Rightarrow> bool" is fun_order .

  lift_definition less_bool_op :: "'a bool_op \<Rightarrow> 'a bool_op \<Rightarrow> bool" is "(<.)" .

  lift_definition zero_bool_op :: "'a bool_op" is "bot"
    by (auto simp: bot_def fun_union_def fun_order_def mono_def)

  lift_definition one_bool_op :: "'a bool_op" is "id"
    by (auto simp: fun_union_def fun_order_def mono_def)

  lift_definition times_bool_op :: "'a bool_op \<Rightarrow> 'a bool_op \<Rightarrow> 'a bool_op" is "(o)"
    by (auto simp: o_def fun_union_def fun_order_def bot_def mono_def) metis

  lift_definition plus_bool_op :: "'a bool_op \<Rightarrow> 'a bool_op \<Rightarrow> 'a bool_op" is "(+)"
    apply (auto simp: o_def fun_union_def fun_order_def bot_def mono_def)
    apply (metis subsetD)
    apply (metis subsetD)
    apply (rule ext)
    by (metis (no_types, lifting) semilattice_sup_class.sup.assoc semilattice_sup_class.sup.left_commute)

  instance
    by standard (transfer, auto simp: fun_order_def fun_strict_order_def fun_union_def bot_def)+

end

instantiation bool_op :: (type) test_semiring_zerol
begin
  lift_definition n_op_bool_op :: "'a bool_op \<Rightarrow> 'a bool_op" is "N"
    by (auto simp: N_def fun_inter_def adjoint_def bot_def fun_union_def mono_def)

  instance
  apply standard
  apply (transfer, clarsimp simp add: N_def adjoint_def bot_def id_def comp_def fun_inter_def)
  apply (transfer, clarsimp simp add: N_def adjoint_def bot_def id_def comp_def fun_inter_def fun_union_def mono_def, blast)
  apply (transfer, clarsimp simp add: N_def adjoint_def bot_def comp_def mono_def fun_union_def fun_inter_def)
  by (transfer, clarsimp simp add: N_def adjoint_def bot_def comp_def mono_def fun_union_def fun_inter_def, blast)

end

definition fun_star :: "'a bfun \<Rightarrow> 'a bfun" where
  "fun_star f = lfp (\<lambda>r. f o r + id)"

definition fun_iteration :: "'a bfun \<Rightarrow> 'a bfun" where
  "fun_iteration f = gfp (\<lambda>g. f o g + id)"

text \<open>
  Verifying the iteration laws is left for future work. This could be obtained by integrating
  Preoteasa's approach~\<^cite>\<open>"Preoteasa11"\<close>.
\<close>

end