(*  Title:       Square Matrices
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

section \<open> Square Matrices \<close>

text \<open> The general solution for affine systems of ODEs involves the exponential function.
Unfortunately, this operation is only available in Isabelle for the type class ``banach''.
Hence, we define a type of square matrices and prove that it is an instance of this class. \<close>

theory SQ_MTX
  imports MTX_Norms

begin

subsection \<open> Definition \<close>

typedef 'm sq_mtx = "UNIV::(real^'m^'m) set"
  morphisms to_vec to_mtx by simp

declare to_mtx_inverse [simp]
    and to_vec_inverse [simp]

setup_lifting type_definition_sq_mtx

lift_definition sq_mtx_ith :: "'m sq_mtx \<Rightarrow> 'm \<Rightarrow> (real^'m)" (infixl "$$" 90) is "($)" .

lift_definition sq_mtx_vec_mult :: "'m sq_mtx \<Rightarrow> (real^'m) \<Rightarrow> (real^'m)" (infixl "*\<^sub>V" 90) is "(*v)" .

lift_definition vec_sq_mtx_prod :: "(real^'m) \<Rightarrow> 'm sq_mtx \<Rightarrow> (real^'m)" is "(v*)" .

lift_definition sq_mtx_diag :: "(('m::finite) \<Rightarrow> real) \<Rightarrow> ('m::finite) sq_mtx" (binder "\<d>\<i>\<a>\<g> " 10)
  is diag_mat .

lift_definition sq_mtx_transpose :: "('m::finite) sq_mtx \<Rightarrow> 'm sq_mtx" ("_\<^sup>\<dagger>") is transpose .

lift_definition sq_mtx_inv :: "('m::finite) sq_mtx \<Rightarrow> 'm sq_mtx" ("_\<^sup>-\<^sup>1" [90]) is matrix_inv .

lift_definition sq_mtx_row :: "'m \<Rightarrow> ('m::finite) sq_mtx \<Rightarrow> real^'m" ("\<r>\<o>\<w>") is row .

lift_definition sq_mtx_col :: "'m \<Rightarrow> ('m::finite) sq_mtx \<Rightarrow> real^'m" ("\<c>\<o>\<l>")  is column .

lemma to_vec_eq_ith: "(to_vec A) $ i = A $$ i"
  by transfer simp

lemma to_mtx_ith[simp]:
  "(to_mtx A) $$ i1 = A $ i1"
  "(to_mtx A) $$ i1 $ i2 = A $ i1 $ i2"
  by (transfer, simp)+

lemma to_mtx_vec_lambda_ith[simp]: "to_mtx (\<chi> i j. x i j) $$ i1 $ i2 = x i1 i2"
  by (simp add: sq_mtx_ith_def)

lemma sq_mtx_eq_iff:
  shows "A = B = (\<forall>i j. A $$ i $ j = B $$ i $ j)"
    and "A = B = (\<forall>i. A $$ i = B $$ i)"
  by (transfer, simp add: vec_eq_iff)+

lemma sq_mtx_diag_simps[simp]:
  "i = j \<Longrightarrow> sq_mtx_diag f $$ i $ j = f i"
  "i \<noteq> j \<Longrightarrow> sq_mtx_diag f $$ i $ j = 0"
  "sq_mtx_diag f $$ i = axis i (f i)"
  unfolding sq_mtx_diag_def by (simp_all add: axis_def vec_eq_iff)

lemma sq_mtx_vec_mult_diag_axis: "(\<d>\<i>\<a>\<g> i. f i) *\<^sub>V (axis i k) = axis i (f i * k)"
  unfolding sq_mtx_diag_vec_mult axis_def by auto

lemma sq_mtx_vec_mult_eq: "m *\<^sub>V x = (\<chi> i. sum (\<lambda>j. (m $$ i $ j) * (x $ j)) UNIV)"
  by (transfer, simp add: matrix_vector_mult_def)

lemma sq_mtx_transpose_transpose[simp]: "(A\<^sup>\<dagger>)\<^sup>\<dagger> = A"
  by (transfer, simp)

lemma transpose_mult_vec_canon_row[simp]: "(A\<^sup>\<dagger>) *\<^sub>V (\<e> i) = \<r>\<o>\<w> i A"
  by transfer (simp add: row_def transpose_def axis_def matrix_vector_mult_def)

lemma row_ith[simp]: "\<r>\<o>\<w> i A = A $$ i"
  by transfer (simp add: row_def)

lemma mtx_vec_mult_canon: "A *\<^sub>V (\<e> i) = \<c>\<o>\<l> i A"
  by (transfer, simp add: matrix_vector_mult_basis)

subsection \<open> Ring of square matrices \<close>

instantiation sq_mtx :: (finite) ring
begin

lift_definition plus_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is "(+)" .

lift_definition zero_sq_mtx :: "'a sq_mtx" is "0" .

lift_definition uminus_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx" is "uminus" .

lift_definition minus_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is "(-)" .

lift_definition times_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is "(**)" .

declare plus_sq_mtx.rep_eq [simp]
    and minus_sq_mtx.rep_eq [simp]

instance apply intro_classes
  by(transfer, simp add: algebra_simps matrix_mul_assoc matrix_add_rdistrib matrix_add_ldistrib)+

end

lemma sq_mtx_zero_ith[simp]: "0 $$ i = 0"
  by (transfer, simp)

lemma sq_mtx_zero_nth[simp]: "0 $$ i $ j = 0"
  by transfer simp

lemma sq_mtx_plus_eq: "A + B = to_mtx (\<chi> i j. A$$i$j + B$$i$j)"
  by transfer (simp add: vec_eq_iff)

lemma sq_mtx_plus_ith[simp]:"(A + B) $$ i = A $$ i + B $$ i"
  unfolding sq_mtx_plus_eq by (simp add: vec_eq_iff)

lemma sq_mtx_minus_eq: "A - B = to_mtx (\<chi> i j. A$$i$j - B$$i$j)"
  by transfer (simp add: vec_eq_iff)

lemma sq_mtx_minus_ith[simp]:"(A - B) $$ i = A $$ i - B $$ i"
  unfolding sq_mtx_minus_eq by (simp add: vec_eq_iff)

lemma sq_mtx_times_eq: "A * B = to_mtx (\<chi> i j. sum (\<lambda>k. A$$i$k * B$$k$j) UNIV)"
  by transfer (simp add: matrix_matrix_mult_def)

lemma sq_mtx_plus_diag_diag[simp]: "sq_mtx_diag f + sq_mtx_diag g = (\<d>\<i>\<a>\<g> i. f i + g i)"
  by (subst sq_mtx_eq_iff) (simp add: axis_def)

lemma sq_mtx_minus_diag_diag[simp]: "sq_mtx_diag f - sq_mtx_diag g = (\<d>\<i>\<a>\<g> i. f i - g i)"
  by (subst sq_mtx_eq_iff) (simp add: axis_def)

lemma sum_sq_mtx_diag[simp]: "(\<Sum>n<m. sq_mtx_diag (g n)) = (\<d>\<i>\<a>\<g> i. \<Sum>n<m. (g n i))" for m::nat
  by (induct m, simp, subst sq_mtx_eq_iff, simp_all)

lemma sq_mtx_mult_diag_diag[simp]: "sq_mtx_diag f * sq_mtx_diag g = (\<d>\<i>\<a>\<g> i. f i * g i)"
  by (simp add: matrix_mul_diag_diag sq_mtx_diag.abs_eq times_sq_mtx.abs_eq)

lemma sq_mtx_mult_diagl: "(\<d>\<i>\<a>\<g> i. f i) * A = to_mtx (\<chi> i j. f i * A $$ i $ j)"
  by transfer (simp add: matrix_mul_diag_matl)

lemma sq_mtx_mult_diagr: "A * (\<d>\<i>\<a>\<g> i. f i) = to_mtx (\<chi> i j. A $$ i $ j * f j)"
  by transfer (simp add: matrix_matrix_mul_diag_matr)

lemma mtx_vec_mult_0l[simp]: "0 *\<^sub>V x = 0"
  by (simp add: sq_mtx_vec_mult.abs_eq zero_sq_mtx_def)

lemma mtx_vec_mult_0r[simp]: "A *\<^sub>V 0 = 0"
  by (transfer, simp)

lemma mtx_vec_mult_add_rdistr: "(A + B) *\<^sub>V x = A *\<^sub>V x + B *\<^sub>V x"
  unfolding plus_sq_mtx_def
  apply(transfer)
  by (simp add: matrix_vector_mult_add_rdistrib)

lemma mtx_vec_mult_add_rdistl: "A *\<^sub>V (x + y) = A *\<^sub>V x + A *\<^sub>V y"
  unfolding plus_sq_mtx_def
  apply transfer
  by (simp add: matrix_vector_right_distrib)

lemma mtx_vec_mult_minus_rdistrib: "(A - B) *\<^sub>V x = A *\<^sub>V x - B *\<^sub>V x"
  unfolding minus_sq_mtx_def by(transfer, simp add: matrix_vector_mult_diff_rdistrib)

lemma mtx_vec_mult_minus_ldistrib: "A *\<^sub>V (x - y) =  A *\<^sub>V x -  A *\<^sub>V y"
  by (metis (no_types, lifting) add_diff_cancel diff_add_cancel
      matrix_vector_right_distrib sq_mtx_vec_mult.rep_eq)

lemma sq_mtx_times_vec_assoc: "(A * B) *\<^sub>V x = A *\<^sub>V (B *\<^sub>V x)"
  by (transfer, simp add: matrix_vector_mul_assoc)

lemma sq_mtx_vec_mult_sum_cols: "A *\<^sub>V x = sum (\<lambda>i. x $ i *\<^sub>R \<c>\<o>\<l> i A) UNIV"
  by(transfer) (simp add: matrix_mult_sum scalar_mult_eq_scaleR)

subsection \<open> Real normed vector space of square matrices \<close>

instantiation sq_mtx :: (finite) real_normed_vector
begin

definition norm_sq_mtx :: "'a sq_mtx \<Rightarrow> real" where "\<parallel>A\<parallel> = \<parallel>to_vec A\<parallel>\<^sub>o\<^sub>p"

lift_definition scaleR_sq_mtx :: "real \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is scaleR .

definition sgn_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx"
  where "sgn_sq_mtx A = (inverse (\<parallel>A\<parallel>)) *\<^sub>R A"

definition dist_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> real"
  where "dist_sq_mtx A B = \<parallel>A - B\<parallel>"

definition uniformity_sq_mtx :: "('a sq_mtx \<times> 'a sq_mtx) filter"
  where "uniformity_sq_mtx = (INF e\<in>{0<..}. principal {(x, y). dist x y < e})"

definition open_sq_mtx :: "'a sq_mtx set \<Rightarrow> bool"
  where "open_sq_mtx U = (\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> U)"

instance apply intro_classes
  unfolding sgn_sq_mtx_def open_sq_mtx_def dist_sq_mtx_def uniformity_sq_mtx_def
            prefer 10
            apply(transfer, simp add: norm_sq_mtx_def op_norm_triangle)
           prefer 9
           apply(simp_all add: norm_sq_mtx_def zero_sq_mtx_def op_norm_eq_0)
  by (transfer, simp add: norm_sq_mtx_def op_norm_scaleR algebra_simps)+

end

lemma sq_mtx_scaleR_eq: "c *\<^sub>R A = to_mtx (\<chi> i j. c *\<^sub>R A $$ i $ j)"
  by transfer (simp add: vec_eq_iff)

lemma scaleR_to_mtx_ith[simp]: "c *\<^sub>R (to_mtx A) $$ i1 $ i2 = c * A $ i1 $ i2"
  by transfer (simp add: scaleR_vec_def)

lemma sq_mtx_scaleR_ith[simp]: "(c *\<^sub>R A) $$ i = (c  *\<^sub>R (A $$ i))"
  by (unfold scaleR_sq_mtx_def, transfer, simp)

lemma scaleR_sq_mtx_diag: "c *\<^sub>R sq_mtx_diag f = (\<d>\<i>\<a>\<g> i. c * f i)"
  by (subst sq_mtx_eq_iff, simp add: axis_def)

lemma scaleR_mtx_vec_assoc: "(c *\<^sub>R A) *\<^sub>V x = c *\<^sub>R (A *\<^sub>V x)"
  unfolding scaleR_sq_mtx_def sq_mtx_vec_mult_def apply simp
  by (simp add: scaleR_matrix_vector_assoc)

lemma mtx_vec_scaleR_commute: "A *\<^sub>V (c *\<^sub>R x) = c *\<^sub>R (A *\<^sub>V x)"
  unfolding scaleR_sq_mtx_def sq_mtx_vec_mult_def apply(simp, transfer)
  by (simp add: vector_scaleR_commute)

lemma mtx_times_scaleR_commute: "A * (c *\<^sub>R B) = c *\<^sub>R (A * B)" for A::"('n::finite) sq_mtx"
  unfolding sq_mtx_scaleR_eq sq_mtx_times_eq
  apply(simp add: to_mtx_inject)
  apply(simp add: vec_eq_iff fun_eq_iff)
  by (simp add: semiring_normalization_rules(19) vector_space_over_itself.scale_sum_right)

lemma le_mtx_norm: "m \<in> {\<parallel>A *\<^sub>V x\<parallel> |x. \<parallel>x\<parallel> = 1} \<Longrightarrow> m \<le> \<parallel>A\<parallel>"
  using cSup_upper[of _ "{\<parallel>(to_vec A) *v x\<parallel> | x. \<parallel>x\<parallel> = 1}"]
  by (simp add: op_norm_set_proptys(2) op_norm_def norm_sq_mtx_def sq_mtx_vec_mult.rep_eq)

lemma norm_vec_mult_le: "\<parallel>A *\<^sub>V x\<parallel> \<le> (\<parallel>A\<parallel>) * (\<parallel>x\<parallel>)"
  by (simp add: norm_matrix_le_mult_op_norm norm_sq_mtx_def sq_mtx_vec_mult.rep_eq)

lemma bounded_bilinear_sq_mtx_vec_mult: "bounded_bilinear (\<lambda>A s. A *\<^sub>V s)"
  apply (rule bounded_bilinear.intro, simp_all add: mtx_vec_mult_add_rdistr
      mtx_vec_mult_add_rdistl scaleR_mtx_vec_assoc mtx_vec_scaleR_commute)
  by (rule_tac x=1 in exI, auto intro!: norm_vec_mult_le)

lemma norm_sq_mtx_def2: "\<parallel>A\<parallel> = Sup {\<parallel>A *\<^sub>V x\<parallel> |x. \<parallel>x\<parallel> = 1}"
  unfolding norm_sq_mtx_def op_norm_def sq_mtx_vec_mult_def by simp

lemma norm_sq_mtx_def3: "\<parallel>A\<parallel> = (SUP x. (\<parallel>A *\<^sub>V x\<parallel>) / (\<parallel>x\<parallel>))"
  unfolding norm_sq_mtx_def onorm_def sq_mtx_vec_mult_def by simp

lemma norm_sq_mtx_diag: "\<parallel>sq_mtx_diag f\<parallel> = Max {\<bar>f i\<bar> |i. i \<in> UNIV}"
  unfolding norm_sq_mtx_def apply transfer
  by (rule op_norm_diag_mat_eq)

lemma sq_mtx_norm_le_sum_col: "\<parallel>A\<parallel> \<le> (\<Sum>i\<in>UNIV. \<parallel>\<c>\<o>\<l> i A\<parallel>)"
  using op_norm_le_sum_column[of "to_vec A"]
  apply(simp add: norm_sq_mtx_def)
  by(transfer, simp add: op_norm_le_sum_column)

lemma norm_le_transpose: "\<parallel>A\<parallel> \<le> \<parallel>A\<^sup>\<dagger>\<parallel>"
  unfolding norm_sq_mtx_def by transfer (rule op_norm_le_transpose)

lemma norm_eq_norm_transpose[simp]: "\<parallel>A\<^sup>\<dagger>\<parallel> = \<parallel>A\<parallel>"
  using norm_le_transpose[of A] and norm_le_transpose[of "A\<^sup>\<dagger>"] by simp

lemma norm_column_le_norm: "\<parallel>A $$ i\<parallel> \<le> \<parallel>A\<parallel>"
  using norm_vec_mult_le[of "A\<^sup>\<dagger>" "\<e> i"] by simp

subsection \<open> Real normed algebra of square matrices \<close>

instantiation sq_mtx :: (finite) real_normed_algebra_1
begin

lift_definition one_sq_mtx :: "'a sq_mtx" is "to_mtx (mat 1)" .

lemma sq_mtx_one_idty: "1 * A = A" "A * 1 = A" for A :: "'a sq_mtx"
  by(transfer, transfer, unfold mat_def matrix_matrix_mult_def, simp add: vec_eq_iff)+

lemma sq_mtx_norm_1: "\<parallel>(1::'a sq_mtx)\<parallel> = 1"
  unfolding one_sq_mtx_def norm_sq_mtx_def
  apply(simp add: op_norm_def)
  apply(subst cSup_eq[of _ 1])
  using ex_norm_eq_1 by auto

lemma sq_mtx_norm_times: "\<parallel>A * B\<parallel> \<le> (\<parallel>A\<parallel>) * (\<parallel>B\<parallel>)" for A :: "'a sq_mtx"
  unfolding norm_sq_mtx_def times_sq_mtx_def by(simp add: op_norm_matrix_matrix_mult_le)

instance
  apply intro_classes
  apply(simp_all add: sq_mtx_one_idty sq_mtx_norm_1 sq_mtx_norm_times)
  apply(simp_all add: to_mtx_inject vec_eq_iff one_sq_mtx_def zero_sq_mtx_def mat_def)
  by(transfer, simp add: scalar_matrix_assoc matrix_scalar_ac)+

end

lemma sq_mtx_one_ith_simps[simp]: "1 $$ i $ i = 1" "i \<noteq> j \<Longrightarrow> 1 $$ i $ j = 0"
  unfolding one_sq_mtx_def mat_def by simp_all

lemma of_nat_eq_sq_mtx_diag[simp]: "of_nat m = (\<d>\<i>\<a>\<g> i. m)"
  by (induct m) (simp, subst sq_mtx_eq_iff, simp add: axis_def)+

lemma mtx_vec_mult_1[simp]: "1 *\<^sub>V s = s"
  by (auto simp: sq_mtx_vec_mult_def one_sq_mtx_def
      mat_def vec_eq_iff matrix_vector_mult_def)

lemma sq_mtx_diag_one[simp]: "(\<d>\<i>\<a>\<g> i. 1) = 1"
  by (subst sq_mtx_eq_iff, simp add: one_sq_mtx_def mat_def axis_def)

abbreviation "mtx_invertible A \<equiv> invertible (to_vec A)"

lemma mtx_invertible_def: "mtx_invertible A \<longleftrightarrow> (\<exists>A'. A' * A = 1 \<and> A * A' = 1)"
  apply (unfold sq_mtx_inv_def times_sq_mtx_def one_sq_mtx_def invertible_def, clarsimp, safe)
   apply(rule_tac x="to_mtx A'" in exI, simp)
  by (rule_tac x="to_vec A'" in exI, simp add: to_mtx_inject)

lemma mtx_invertibleD[simp]:
  assumes "mtx_invertible A"
  shows "A\<^sup>-\<^sup>1 * A = 1" and "A * A\<^sup>-\<^sup>1 = 1"
  apply (unfold sq_mtx_inv_def times_sq_mtx_def one_sq_mtx_def)
  using assms by simp_all

lemma mtx_invertible_inv[simp]: "mtx_invertible A \<Longrightarrow> mtx_invertible (A\<^sup>-\<^sup>1)"
  using mtx_invertibleD mtx_invertibleI by blast

lemma mtx_invertible_one[simp]: "mtx_invertible 1"
  by (simp add: one_sq_mtx.rep_eq)

lemma sq_mtx_inv_unique:
  assumes "A * B = 1" and "B * A = 1"
  shows "A\<^sup>-\<^sup>1 = B"
  by (metis (no_types, lifting) assms mtx_invertibleD(2)
      mtx_invertibleI mult.assoc sq_mtx_one_idty(1))

lemma sq_mtx_inv_idempotent[simp]: "mtx_invertible A \<Longrightarrow> A\<^sup>-\<^sup>1\<^sup>-\<^sup>1 = A"
  using mtx_invertibleD sq_mtx_inv_unique by blast

lemma sq_mtx_inv_mult:
  assumes "mtx_invertible A" and "mtx_invertible B"
  shows "(A * B)\<^sup>-\<^sup>1 = B\<^sup>-\<^sup>1 * A\<^sup>-\<^sup>1"
  by (simp add: assms matrix_inv_matrix_mul sq_mtx_inv_def times_sq_mtx_def)

lemma sq_mtx_inv_one[simp]: "1\<^sup>-\<^sup>1 = 1"
  by (simp add: sq_mtx_inv_unique)

definition similar_sq_mtx :: "('n::finite) sq_mtx \<Rightarrow> 'n sq_mtx \<Rightarrow> bool" (infixr "\<sim>" 25)
  where "(A \<sim> B) \<longleftrightarrow> (\<exists> P. mtx_invertible P \<and> A = P\<^sup>-\<^sup>1 * B * P)"

lemma similar_sq_mtx_matrix: "(A \<sim> B) = similar_matrix (to_vec A) (to_vec B)"
  apply(unfold similar_matrix_def similar_sq_mtx_def, safe)
   apply (metis sq_mtx_inv.rep_eq times_sq_mtx.rep_eq)
  by (metis UNIV_I sq_mtx_inv.abs_eq times_sq_mtx.abs_eq to_mtx_inverse to_vec_inverse)

lemma similar_sq_mtx_refl[simp]: "A \<sim> A"
  by (unfold similar_sq_mtx_def, rule_tac x="1" in exI, simp)

lemma similar_sq_mtx_simm: "A \<sim> B \<Longrightarrow> B \<sim> A"
  apply(unfold similar_sq_mtx_def, clarsimp)
  apply(rule_tac x="P\<^sup>-\<^sup>1" in exI, simp add: mult.assoc)
  by (metis mtx_invertibleD(2) mult.assoc mult.left_neutral)

lemma similar_sq_mtx_trans: "A \<sim> B \<Longrightarrow> B \<sim> C \<Longrightarrow> A \<sim> C"
  unfolding similar_sq_mtx_matrix using similar_matrix_trans by blast

lemma power_similiar_sq_mtx_diag_eq:
  assumes "mtx_invertible P"
      and "A = P\<^sup>-\<^sup>1 * (sq_mtx_diag f) * P"
    shows "A^n = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i^n) * P"
proof(induct n, simp_all add: assms)
  fix n::nat
  have "P\<^sup>-\<^sup>1 * sq_mtx_diag f * P * (P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P) =
  P\<^sup>-\<^sup>1 * sq_mtx_diag f * (\<d>\<i>\<a>\<g> i. f i ^ n) * P"
    by (metis (no_types, lifting) assms(1) mtx_invertibleD(2) mult.assoc mult.right_neutral)
  also have "... = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i * f i ^ n) * P"
    by (simp add: mult.assoc)
  finally show "P\<^sup>-\<^sup>1 * sq_mtx_diag f * P * (P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P) =
  P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i * f i ^ n) * P" .
qed

lemma power_similar_sq_mtx_diag:
  assumes "A \<sim> (sq_mtx_diag f)"
  shows "A^n \<sim> (\<d>\<i>\<a>\<g> i. f i^n)"
  using assms power_similiar_sq_mtx_diag_eq
  unfolding similar_sq_mtx_def by blast

subsection \<open> Banach space of square matrices \<close>

lemma Cauchy_cols:
  fixes X :: "nat \<Rightarrow> ('a::finite) sq_mtx"
  assumes "Cauchy X"
  shows "Cauchy (\<lambda>n. \<c>\<o>\<l> i (X n))"
proof(unfold Cauchy_def dist_norm, clarsimp)
  fix \<epsilon>::real assume "\<epsilon> > 0"
  then obtain M where M_def:"\<forall>m\<ge>M. \<forall>n\<ge>M. \<parallel>X m - X n\<parallel> < \<epsilon>"
    using \<open>Cauchy X\<close> unfolding Cauchy_def by(simp add: dist_sq_mtx_def) metis
  {fix m n assume "m \<ge> M" and "n \<ge> M"
    hence "\<epsilon> > \<parallel>X m - X n\<parallel>"
      using M_def by blast
    moreover have "\<parallel>X m - X n\<parallel> \<ge> \<parallel>(X m - X n) *\<^sub>V \<e> i\<parallel>"
      by(rule le_mtx_norm[of _ "X m - X n"], force)
    moreover have "\<parallel>(X m - X n) *\<^sub>V \<e> i\<parallel> = \<parallel>X m *\<^sub>V \<e> i - X n *\<^sub>V \<e> i\<parallel>"
      by (simp add: mtx_vec_mult_minus_rdistrib)
    moreover have "... = \<parallel>\<c>\<o>\<l> i (X m) - \<c>\<o>\<l> i (X n)\<parallel>"
      by (simp add: mtx_vec_mult_minus_rdistrib mtx_vec_mult_canon)
    ultimately have "\<parallel>\<c>\<o>\<l> i (X m) - \<c>\<o>\<l> i (X n)\<parallel> < \<epsilon>"
      by linarith}
  thus "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. \<parallel>\<c>\<o>\<l> i (X m) - \<c>\<o>\<l> i (X n)\<parallel> < \<epsilon>"
    by blast
qed

lemma col_convergence:
  assumes "\<forall>i. (\<lambda>n. \<c>\<o>\<l> i (X n)) \<longlonglongrightarrow> L $ i"
  shows "X \<longlonglongrightarrow> to_mtx (transpose L)"
proof(unfold LIMSEQ_def dist_norm, clarsimp)
  let ?L = "to_mtx (transpose L)"
  let ?a = "CARD('a)" fix \<epsilon>::real assume "\<epsilon> > 0"
  hence "\<epsilon> / ?a > 0" by simp
  hence "\<forall>i. \<exists> N. \<forall>n\<ge>N. \<parallel>\<c>\<o>\<l> i (X n) - L $ i\<parallel> < \<epsilon>/?a"
    using assms unfolding LIMSEQ_def dist_norm convergent_def by blast
  then obtain N where "\<forall>i. \<forall>n\<ge>N. \<parallel>\<c>\<o>\<l> i (X n) - L $ i\<parallel> < \<epsilon>/?a"
    using finite_nat_minimal_witness[of "\<lambda> i n. \<parallel>\<c>\<o>\<l> i (X n) - L $ i\<parallel> < \<epsilon>/?a"] by blast
  also have "\<And>i n. (\<c>\<o>\<l> i (X n) - L $ i) = (\<c>\<o>\<l> i (X n - ?L))"
    unfolding minus_sq_mtx_def by(transfer, simp add: transpose_def vec_eq_iff column_def)
  ultimately have N_def:"\<forall>i. \<forall>n\<ge>N. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel> < \<epsilon>/?a"
    by auto
  have "\<forall>n\<ge>N. \<parallel>X n - ?L\<parallel> < \<epsilon>"
  proof(rule allI, rule impI)
    fix n::nat assume "N \<le> n"
    hence "\<forall> i. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel> < \<epsilon>/?a"
      using N_def by blast
    hence "(\<Sum>i\<in>UNIV. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel>) < (\<Sum>(i::'a)\<in>UNIV. \<epsilon>/?a)"
      using sum_strict_mono[of _ "\<lambda>i. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel>"] by force
    moreover have "\<parallel>X n - ?L\<parallel> \<le> (\<Sum>i\<in>UNIV. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel>)"
      using sq_mtx_norm_le_sum_col by blast
    moreover have "(\<Sum>(i::'a)\<in>UNIV. \<epsilon>/?a) = \<epsilon>"
      by force
    ultimately show "\<parallel>X n - ?L\<parallel> < \<epsilon>"
      by linarith
  qed
  thus "\<exists>no. \<forall>n\<ge>no. \<parallel>X n - ?L\<parallel> < \<epsilon>"
    by blast
qed

instance sq_mtx :: (finite) banach
proof(standard)
  fix X :: "nat \<Rightarrow> 'a sq_mtx"
  assume "Cauchy X"
  hence "\<And>i. Cauchy (\<lambda>n. \<c>\<o>\<l> i (X n))"
    using Cauchy_cols by blast
  hence obs: "\<forall>i. \<exists>! L. (\<lambda>n. \<c>\<o>\<l> i (X n)) \<longlonglongrightarrow> L"
    using Cauchy_convergent convergent_def LIMSEQ_unique by fastforce
  define L where "L = (\<chi> i. lim (\<lambda>n. \<c>\<o>\<l> i (X n)))"
  hence "\<forall>i. (\<lambda>n. \<c>\<o>\<l> i (X n)) \<longlonglongrightarrow> L $ i"
    using obs theI_unique[of "\<lambda>L. (\<lambda>n. \<c>\<o>\<l> _ (X n)) \<longlonglongrightarrow> L" "L $ _"] by (simp add: lim_def)
  thus "convergent X"
    using col_convergence unfolding convergent_def by blast
qed

lemma exp_similiar_sq_mtx_diag_eq:
  assumes "mtx_invertible P"
      and "A = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i) * P"
    shows "exp A = P\<^sup>-\<^sup>1 * exp (\<d>\<i>\<a>\<g> i. f i) * P"
proof(unfold exp_def power_similiar_sq_mtx_diag_eq[OF assms])
  have "(\<Sum>n. P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P /\<^sub>R fact n) =
  (\<Sum>n. P\<^sup>-\<^sup>1 * ((\<d>\<i>\<a>\<g> i. f i ^ n) /\<^sub>R fact n) * P)"
    by simp
  also have "... = (\<Sum>n. P\<^sup>-\<^sup>1 * ((\<d>\<i>\<a>\<g> i. f i ^ n) /\<^sub>R fact n)) * P"
    apply(subst suminf_multr[OF bounded_linear.summable[OF bounded_linear_mult_right]])
    unfolding power_sq_mtx_diag[symmetric] by (simp_all add: summable_exp_generic)
  also have "... = P\<^sup>-\<^sup>1 * (\<Sum>n. (\<d>\<i>\<a>\<g> i. f i ^ n) /\<^sub>R fact n) * P"
    apply(subst suminf_mult[of _ "P\<^sup>-\<^sup>1"])
    unfolding power_sq_mtx_diag[symmetric]
    by (simp_all add: summable_exp_generic)
  finally show "(\<Sum>n. P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P /\<^sub>R fact n) =
  P\<^sup>-\<^sup>1 * (\<Sum>n. sq_mtx_diag f ^ n /\<^sub>R fact n) * P"
    unfolding power_sq_mtx_diag by simp
qed

lemma exp_similiar_sq_mtx_diag:
  assumes "A \<sim> sq_mtx_diag f"
  shows "exp A \<sim> exp (sq_mtx_diag f)"
  using assms exp_similiar_sq_mtx_diag_eq
  unfolding similar_sq_mtx_def by blast

lemma suminf_sq_mtx_diag:
  assumes "\<forall>i. (\<lambda>n. f n i) sums (suminf (\<lambda>n. f n i))"
  shows "(\<Sum>n. (\<d>\<i>\<a>\<g> i. f n i)) = (\<d>\<i>\<a>\<g> i. \<Sum>n. f n i)"
proof(rule suminfI, unfold sums_def LIMSEQ_iff, clarsimp simp: norm_sq_mtx_diag)
  let ?g = "\<lambda>n i. \<bar>(\<Sum>n<n. f n i) - (\<Sum>n. f n i)\<bar>"
  fix r::real assume "r > 0"
  have "\<forall>i. \<exists>no. \<forall>n\<ge>no. ?g n i < r"
    using assms \<open>r > 0\<close> unfolding sums_def LIMSEQ_iff by clarsimp
  then obtain N where key: "\<forall>i. \<forall>n\<ge>N. ?g n i < r"
    using finite_nat_minimal_witness[of "\<lambda>i n. ?g n i < r"] by blast
  {fix n::nat
    assume "n \<ge> N"
    obtain i where i_def: "Max {x. \<exists>i. x = ?g n i} = ?g n i"
      using cMax_finite_ex[of "{x. \<exists>i. x = ?g n i}"] by auto
    hence "?g n i < r"
      using key \<open>n \<ge> N\<close> by blast
    hence "Max {x. \<exists>i. x = ?g n i} < r"
      unfolding i_def[symmetric] .}
  thus "\<exists>N. \<forall>n\<ge>N. Max {x. \<exists>i. x = ?g n i} < r"
    by blast
qed

lemma exp_sq_mtx_diag: "exp (sq_mtx_diag f) = (\<d>\<i>\<a>\<g> i. exp (f i))"
  apply(unfold exp_def, simp add: power_sq_mtx_diag scaleR_sq_mtx_diag)
  apply(rule suminf_sq_mtx_diag)
  using exp_converges[of "f _"]
  unfolding sums_def LIMSEQ_iff exp_def by force

lemma exp_scaleR_diagonal1:
  assumes "mtx_invertible P" and "A = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i) * P"
    shows "exp (t *\<^sub>R A) = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P"
proof-
  have "exp (t *\<^sub>R A) = exp (P\<^sup>-\<^sup>1 * (t *\<^sub>R sq_mtx_diag f) * P)"
    using assms by simp
  also have "... = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P"
    by (metis assms(1) exp_similiar_sq_mtx_diag_eq exp_sq_mtx_diag scaleR_sq_mtx_diag)
  finally show "exp (t *\<^sub>R A) = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P" .
qed

lemma exp_scaleR_diagonal2:
  assumes "mtx_invertible P" and "A = P * (\<d>\<i>\<a>\<g> i. f i) * P\<^sup>-\<^sup>1"
    shows "exp (t *\<^sub>R A) = P * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P\<^sup>-\<^sup>1"
  apply(subst sq_mtx_inv_idempotent[OF assms(1), symmetric])
  apply(rule exp_scaleR_diagonal1)
  by (simp_all add: assms)

subsection \<open> Examples \<close>

definition "mtx A = to_mtx (vector (map vector A))"

lemma vector_nth_eq: "(vector A) $ i = foldr (\<lambda>x f n. (f (n + 1))(n := x)) A (\<lambda>n x. 0) 1 i"
  unfolding vector_def by simp

lemma mtx_ith_eq[simp]: "mtx A $$ i $ j = foldr (\<lambda>x f n. (f (n + 1))(n := x))
  (map (\<lambda>l. vec_lambda (foldr (\<lambda>x f n. (f (n + 1))(n := x)) l (\<lambda>n x. 0) 1)) A) (\<lambda>n x. 0) 1 i $ j"
  unfolding mtx_def vector_def by (simp add: vector_nth_eq)

subsubsection \<open> 2x2 matrices \<close>

lemma mtx2_eq_iff: "(mtx
  ([a1, b1] #
   [c1, d1] # []) :: 2 sq_mtx) = mtx
  ([a2, b2] #
   [c2, d2] # []) \<longleftrightarrow> a1 = a2 \<and> b1 = b2 \<and> c1 = c2 \<and> d1 = d2"
  apply(simp add: sq_mtx_eq_iff, safe)
  using exhaust_2 by force+

lemma mtx2_to_mtx: "mtx
  ([a, b] #
   [c, d] # []) =
  to_mtx (\<chi> i j::2. if i=1 \<and> j=1 then a
  else (if i=1 \<and> j=2 then b
  else (if i=2 \<and> j=1 then c
  else d)))"
  apply(subst sq_mtx_eq_iff)
  using exhaust_2 by force

abbreviation diag2 :: "real \<Rightarrow> real \<Rightarrow> 2 sq_mtx"
  where "diag2 \<iota>\<^sub>1 \<iota>\<^sub>2 \<equiv> mtx
   ([\<iota>\<^sub>1, 0] #
    [0, \<iota>\<^sub>2] # [])"

lemma diag2_eq: "diag2 (\<iota> 1) (\<iota> 2) = (\<d>\<i>\<a>\<g> i. \<iota> i)"
  apply(simp add: sq_mtx_eq_iff)
  using exhaust_2 by (force simp: axis_def)

lemma one_mtx2: "(1::2 sq_mtx) = diag2 1 1"
  apply(subst sq_mtx_eq_iff)
  using exhaust_2 by force

lemma zero_mtx2: "(0::2 sq_mtx) = diag2 0 0"
  by (simp add: sq_mtx_eq_iff)

lemma scaleR_mtx2: "k *\<^sub>R mtx
  ([a, b] #
   [c, d] # []) = mtx
  ([k*a, k*b] #
   [k*c, k*d] # [])"
  by (simp add: sq_mtx_eq_iff)

lemma uminus_mtx2: "-mtx
  ([a, b] #
   [c, d] # []) = (mtx
  ([-a, -b] #
   [-c, -d] # [])::2 sq_mtx)"
  by (simp add: sq_mtx_uminus_eq sq_mtx_eq_iff)

lemma plus_mtx2: "mtx
  ([a1, b1] #
   [c1, d1] # []) + mtx
  ([a2, b2] #
   [c2, d2] # []) = ((mtx
  ([a1+a2, b1+b2] #
   [c1+c2, d1+d2] # []))::2 sq_mtx)"
  by (simp add: sq_mtx_eq_iff)

lemma minus_mtx2: "mtx
  ([a1, b1] #
   [c1, d1] # []) - mtx
  ([a2, b2] #
   [c2, d2] # []) = ((mtx
  ([a1-a2, b1-b2] #
   [c1-c2, d1-d2] # []))::2 sq_mtx)"
  by (simp add: sq_mtx_eq_iff)

lemma times_mtx2: "mtx
  ([a1, b1] #
   [c1, d1] # []) * mtx
  ([a2, b2] #
   [c2, d2] # []) = ((mtx
  ([a1*a2+b1*c2, a1*b2+b1*d2] #
   [c1*a2+d1*c2, c1*b2+d1*d2] # []))::2 sq_mtx)"
  unfolding sq_mtx_times_eq UNIV_2
  by (simp add: sq_mtx_eq_iff)

subsubsection \<open> 3x3 matrices \<close>

lemma mtx3_to_mtx: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) =
  to_mtx (\<chi> i j::3. if i=1 \<and> j=1 then a\<^sub>1\<^sub>1
  else (if i=1 \<and> j=2 then a\<^sub>1\<^sub>2
  else (if i=1 \<and> j=3 then a\<^sub>1\<^sub>3
  else (if i=2 \<and> j=1 then a\<^sub>2\<^sub>1
  else (if i=2 \<and> j=2 then a\<^sub>2\<^sub>2
  else (if i=2 \<and> j=3 then a\<^sub>2\<^sub>3
  else (if i=3 \<and> j=1 then a\<^sub>3\<^sub>1
  else (if i=3 \<and> j=2 then a\<^sub>3\<^sub>2
  else a\<^sub>3\<^sub>3))))))))"
  apply(simp add: sq_mtx_eq_iff)
  using exhaust_3 by force

abbreviation diag3 :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 3 sq_mtx"
  where "diag3 \<iota>\<^sub>1 \<iota>\<^sub>2 \<iota>\<^sub>3 \<equiv> mtx
  ([\<iota>\<^sub>1, 0, 0] #
   [0, \<iota>\<^sub>2, 0] #
   [0, 0, \<iota>\<^sub>3] # [])"

lemma diag3_eq: "diag3 (\<iota> 1) (\<iota> 2) (\<iota> 3) = (\<d>\<i>\<a>\<g> i. \<iota> i)"
  apply(simp add: sq_mtx_eq_iff)
  using exhaust_3 by (force simp: axis_def)

lemma one_mtx3: "(1::3 sq_mtx) = diag3 1 1 1"
  apply(subst sq_mtx_eq_iff)
  using exhaust_3 by force

lemma zero_mtx3: "(0::3 sq_mtx) = diag3 0 0 0"
  by (simp add: sq_mtx_eq_iff)

lemma scaleR_mtx3: "k *\<^sub>R mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) = mtx
  ([k*a\<^sub>1\<^sub>1, k*a\<^sub>1\<^sub>2, k*a\<^sub>1\<^sub>3] #
   [k*a\<^sub>2\<^sub>1, k*a\<^sub>2\<^sub>2, k*a\<^sub>2\<^sub>3] #
   [k*a\<^sub>3\<^sub>1, k*a\<^sub>3\<^sub>2, k*a\<^sub>3\<^sub>3] # [])"
  by (simp add: sq_mtx_eq_iff)

lemma plus_mtx3: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) + mtx
  ([b\<^sub>1\<^sub>1, b\<^sub>1\<^sub>2, b\<^sub>1\<^sub>3] #
   [b\<^sub>2\<^sub>1, b\<^sub>2\<^sub>2, b\<^sub>2\<^sub>3] #
   [b\<^sub>3\<^sub>1, b\<^sub>3\<^sub>2, b\<^sub>3\<^sub>3] # []) = (mtx
  ([a\<^sub>1\<^sub>1+b\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2+b\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3+b\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1+b\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2+b\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3+b\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1+b\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2+b\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3+b\<^sub>3\<^sub>3] # [])::3 sq_mtx)"
  by (subst sq_mtx_eq_iff) simp

lemma minus_mtx3: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) - mtx
  ([b\<^sub>1\<^sub>1, b\<^sub>1\<^sub>2, b\<^sub>1\<^sub>3] #
   [b\<^sub>2\<^sub>1, b\<^sub>2\<^sub>2, b\<^sub>2\<^sub>3] #
   [b\<^sub>3\<^sub>1, b\<^sub>3\<^sub>2, b\<^sub>3\<^sub>3] # []) = (mtx
  ([a\<^sub>1\<^sub>1-b\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2-b\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3-b\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1-b\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2-b\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3-b\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1-b\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2-b\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3-b\<^sub>3\<^sub>3] # [])::3 sq_mtx)"
  by (simp add: sq_mtx_eq_iff)

lemma times_mtx3: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) * mtx
  ([b\<^sub>1\<^sub>1, b\<^sub>1\<^sub>2, b\<^sub>1\<^sub>3] #
   [b\<^sub>2\<^sub>1, b\<^sub>2\<^sub>2, b\<^sub>2\<^sub>3] #
   [b\<^sub>3\<^sub>1, b\<^sub>3\<^sub>2, b\<^sub>3\<^sub>3] # []) = (mtx
  ([a\<^sub>1\<^sub>1*b\<^sub>1\<^sub>1+a\<^sub>1\<^sub>2*b\<^sub>2\<^sub>1+a\<^sub>1\<^sub>3*b\<^sub>3\<^sub>1, a\<^sub>1\<^sub>1*b\<^sub>1\<^sub>2+a\<^sub>1\<^sub>2*b\<^sub>2\<^sub>2+a\<^sub>1\<^sub>3*b\<^sub>3\<^sub>2, a\<^sub>1\<^sub>1*b\<^sub>1\<^sub>3+a\<^sub>1\<^sub>2*b\<^sub>2\<^sub>3+a\<^sub>1\<^sub>3*b\<^sub>3\<^sub>3] #
   [a\<^sub>2\<^sub>1*b\<^sub>1\<^sub>1+a\<^sub>2\<^sub>2*b\<^sub>2\<^sub>1+a\<^sub>2\<^sub>3*b\<^sub>3\<^sub>1, a\<^sub>2\<^sub>1*b\<^sub>1\<^sub>2+a\<^sub>2\<^sub>2*b\<^sub>2\<^sub>2+a\<^sub>2\<^sub>3*b\<^sub>3\<^sub>2, a\<^sub>2\<^sub>1*b\<^sub>1\<^sub>3+a\<^sub>2\<^sub>2*b\<^sub>2\<^sub>3+a\<^sub>2\<^sub>3*b\<^sub>3\<^sub>3] #
   [a\<^sub>3\<^sub>1*b\<^sub>1\<^sub>1+a\<^sub>3\<^sub>2*b\<^sub>2\<^sub>1+a\<^sub>3\<^sub>3*b\<^sub>3\<^sub>1, a\<^sub>3\<^sub>1*b\<^sub>1\<^sub>2+a\<^sub>3\<^sub>2*b\<^sub>2\<^sub>2+a\<^sub>3\<^sub>3*b\<^sub>3\<^sub>2, a\<^sub>3\<^sub>1*b\<^sub>1\<^sub>3+a\<^sub>3\<^sub>2*b\<^sub>2\<^sub>3+a\<^sub>3\<^sub>3*b\<^sub>3\<^sub>3] # [])::3 sq_mtx)"
  unfolding sq_mtx_times_eq
  unfolding UNIV_3 by (simp add: sq_mtx_eq_iff)

end


(*
    Original Author of Riddle: Tjark Weber
    Updates and additions by Jacques Fleuriot
*)

theory tut4sol imports Main begin

(* Note that most of these can be proved in more than one way *)

lemma "(P \<longrightarrow>(Q\<longrightarrow>R))\<longrightarrow>((P\<longrightarrow>Q)\<longrightarrow>(P\<longrightarrow>R))"
proof (rule impI)+
  assume "P" "P \<longrightarrow> Q \<longrightarrow> R" then have qr: "Q \<longrightarrow> R"
    (* try sledgehammer here instead to see what it suggests *)
    by fast
  assume "P" "P \<longrightarrow> Q" then have "Q"
    by blast
  then show "R" using qr
    by blast
qed

lemma "(\<forall>x. P x \<longrightarrow> Q)\<longrightarrow>(\<exists>x. P x\<longrightarrow>Q)"
proof
  assume "\<forall>x. P x \<longrightarrow> Q" then have "P a \<longrightarrow> Q" ..
  then show "\<exists>x. P x\<longrightarrow>Q" ..
qed
lemma foo: assumes ex: "\<not>(\<exists>x. P x)" shows all: "\<forall>x. \<not>P x"
proof
  fix x
  show  "\<not> P x"
  proof
    assume "P x" then have "\<exists>x. P x" by (rule exI)
    then show False using ex by simp
  qed
qed

lemma foo2: assumes ex: "\<not>(\<exists>x. P x)" shows "\<forall>x. \<not>P x"
(* "safe" is a method that will not make any provable goal become unprovable.
    It does not do any exI or spec/allE steps. You can use other methods instead *)
proof(safe)
  fix x
  assume "P x" then have "\<exists>x. P x" by (rule exI)
  then show False using ex
    by simp
qed

(* A proof showing the use of a raw proof block. More elegant proofs are possible. *)

lemma assumes n_all: "\<not>(\<forall>x. P x)" shows "\<exists>x. \<not>P x"
proof (rule ccontr)
  assume n_ex: "\<nexists>x. \<not> P x"
  have "\<forall>x. P x"
    proof - (* dash means don't apply any default ND steps *)
      {fix z   (* arbitrary z *)
        have "P z"
        proof (rule ccontr)
          assume "\<not> P z" then have "\<exists>x. \<not> P x" ..
          then show False using n_ex  by simp
        qed
      }
      then show ?thesis .. (* method ".." is one that can do straightforward ND steps but you could e.g. use simp instead*)
    qed
    then show False using n_all by simp
qed

(* Shorter proof of same theorem as above *)

lemma assumes n_all: "\<not>(\<forall>x. P x)" shows "\<exists>x. \<not>P x"
proof (rule ccontr)
  assume n_ex: "\<nexists>x. \<not> P x"
  {fix x
    have "P x"
    proof (rule ccontr)
      assume "\<not> P x" then have "\<exists>x. \<not> P x" ..
      then show False using n_ex  by simp
    qed
  }
  then have "\<forall>x. P x" ..
  then show False using n_all by simp
qed

(* Another Proof using previous result *)
lemma assumes n_all: "\<not>(\<forall>x. P x)" shows "\<exists>x. \<not>P x"
proof (rule ccontr)
  assume "\<nexists>x. \<not> P x"
  then have "\<forall>x. \<not>\<not>P x" by (rule foo)
  then have "\<forall>x. P x" by simp
  from n_all this show False by (rule notE)
qed

(* A possible proof, without named assumptions and goals. Other proofs are possible *)

lemma "(R\<longrightarrow>P)\<longrightarrow>(((\<not>R \<or> P)\<longrightarrow>(Q\<longrightarrow>S))\<longrightarrow>(Q\<longrightarrow>S))"
proof (rule impI)+
  assume "R \<longrightarrow> P" "Q" "\<not> R \<or> P \<longrightarrow> Q \<longrightarrow> S"
  show "S"
  proof (cases)
    assume  "R"
    then have "P" using `R \<longrightarrow> P` by blast
    then have "\<not>R \<or> P" ..
    then have "Q \<longrightarrow> S" using `\<not> R \<or> P \<longrightarrow> Q \<longrightarrow> S` by blast
    then show "S" using  `Q` by simp
  next
    assume notr: "\<not>R"
    then have "\<not>R \<or> P" ..
    then have "Q \<longrightarrow> S" using `\<not> R \<or> P \<longrightarrow> Q \<longrightarrow> S` by blast
    then show "S" using  `Q` by simp
  qed
qed

(* Another proof of the above, without explicit use of cases *)
lemma "(R \<longrightarrow> P) \<longrightarrow> (((\<not>R \<or> P) \<longrightarrow> (Q \<longrightarrow> S)) \<longrightarrow> (Q \<longrightarrow> S))"
proof (rule impI, rule impI)
  assume a: "R \<longrightarrow> P" "\<not> R \<or> P \<longrightarrow> Q \<longrightarrow> S"
  { assume R
    hence P using a(1) by (rule_tac mp)
    hence "\<not> R \<or> P" by (rule disjI2)
  }
  moreover
  { assume "\<not>R"
    hence "\<not> R \<or> P" by (rule disjI1)
  }
  ultimately have "\<not> R \<or> P" by (rule_tac disjE, rule_tac excluded_middle)
  from this a(2) show "Q \<longrightarrow> S" by (rule_tac mp)
qed

text {* A Riddle: Rich Grandfather *}

text {*
  First prove the following formula, which is valid in classical predicate
  logic, informally with pen and paper.  Use case distinctions and/or proof by
  contradiction.

  "If every poor man has a rich father,
   then there is a rich man who has a rich grandfather"
*}

text {*
Proof
(1) We first show: "\<exists>x. rich x".
Proof by contradiction.
    Assume "\<not> (\<exists>x. rich x)"
      Then "\<forall>x. \<not> rich x"
      We consider an arbitrary "y" with "\<not> rich y"
      Then "rich (father y)"

(2) Now we show the theorem.
Proof by cases.
    Case 1:  "rich (father (father x))"
             We are done.
    Case 2: "\<not> rich (father (father x))"
            Then "rich (father (father (father x)))
            Also "rich (father x)"
            because otherwise "rich (father (father x))"
qed
*}

text {*
  Now prove the formula in Isabelle using a sequence of rule applications (i.e.\
  only using the methods rule, erule and assumption).
*}

theorem
  "\<forall>x. \<not> rich x \<longrightarrow> rich (father x) \<Longrightarrow>
  \<exists>x. rich (father (father x)) \<and> rich x"
apply (rule classical)
apply (rule exI)
apply (rule conjI)

  apply (rule classical)
  apply (rule allE) apply assumption
  apply (erule impE) apply assumption
  apply (erule notE)
  apply (rule exI)
  apply (rule conjI) apply assumption
  apply (rule classical)
  apply (erule allE)
  apply (erule notE)
  apply (erule impE) apply assumption
  apply assumption

apply (rule classical)
apply (rule allE) apply assumption
apply (erule impE) apply assumption
apply (erule notE)
apply (rule exI)
apply (rule conjI) apply assumption
apply (rule classical)
apply (erule allE)
apply (erule notE)
apply (erule impE) apply assumption
apply assumption
done

text{* An alternative proof of the above that does not rely on meta variables and uses additional
       tactics/methods such as drule and cut_tac .Note the use of rule exCI too.

       Note also that the order in which the subgoals are tackled are dictated by Isabelle but
       there are ways of doing the proof in a way closer to the informal one e.g. using "prefer"
       to change the order of the goals (although this makes the proof potentially more "brittle"
       to changes in future versions of Isabelle *}

theorem
  "\<forall>x. \<not> rich x \<longrightarrow> rich (father x) \<Longrightarrow>
  \<exists>x. rich (father (father x)) \<and> rich x"
apply (subgoal_tac "\<exists>x. rich x")
apply (erule exE)
(* Tackling (2) first *)
apply (cut_tac P="rich (father(father x))" in excluded_middle)
apply (erule disjE)
(* Case 2 *)
apply (subgoal_tac "rich(father x)")
apply (drule_tac x="father(father x)" in spec)
apply (drule mp, assumption)
apply (rule_tac x="father x" in exI)
apply (rule conjI)
apply assumption
apply assumption
apply (rule ccontr)
apply (drule_tac x="father x" in spec)
apply (drule mp, assumption)
apply (erule notE, assumption)
(* Case 1*)
apply (rule_tac x=x in exI)
apply (rule conjI)
apply assumption
apply assumption
(* Tackling (1) now *)
apply (rule_tac a="father x" in exCI)
apply (drule_tac x=x in spec)
apply (drule_tac x=x in spec)
apply (drule mp, assumption)
apply assumption
done

text {*
  Here is a proof in Isar that resembles the informal reasoning above:
*}

theorem rich_grandfather:
  "\<forall>x. \<not> rich x \<longrightarrow> rich (father x)
   \<Longrightarrow> \<exists>x. rich x \<and> rich (father (father x))"
proof -
  assume a: "\<forall>x. \<not> rich x \<longrightarrow> rich (father x)"
  have "\<exists>x. rich x"
  proof (rule classical)
    fix y
    assume "\<not> (\<exists>x. rich x)"
    then have "\<forall>x. \<not> rich x" by simp
    then have "\<not> rich y" by simp
    with a have "rich (father y)" by simp
    then show ?thesis by rule
  qed
  then obtain x where x: "rich x" by auto
  show ?thesis
  proof cases
    assume "rich (father (father x))"
    with x show ?thesis by auto
  next
    assume b: "\<not> rich (father (father x))"
    with a have "rich (father (father (father x)))" by blast
    moreover have "rich (father x)"
    proof (rule classical)
      assume "\<not> rich (father x)"
      with a have "rich (father (father x))" by simp
      with b show ?thesis by contradiction
    qed
    ultimately show ?thesis by auto
  qed
qed

text {*
  An slightly modified proof of the above, with a named assumption right from the beginning:
*}

theorem rich_grandfather2:
  assumes a: "\<forall>x. \<not> rich x \<longrightarrow> rich (father x)"
  shows "\<exists>x. rich x \<and> rich (father (father x))"
proof -
  have "\<exists>x. rich x"
  proof (rule classical)
    fix y
    assume "\<not> (\<exists>x. rich x)"
    then have "\<forall>x. \<not> rich x" by simp
    then have "\<not> rich y" by simp
    with a have "rich (father y)" by simp
    then show ?thesis by rule
  qed
  then obtain x where x: "rich x" by auto
  show ?thesis
  proof cases
    assume "rich (father (father x))"
    with x show ?thesis by auto
  next
    assume b: "\<not> rich (father (father x))"
    with a have "rich (father (father (father x)))" by simp
    moreover have "rich (father x)"
    proof (rule classical)
      assume "\<not> rich (father x)"
      with a have "rich (father (father x))" by simp
      with b show ?thesis by contradiction
    qed
    ultimately show ?thesis by auto
  qed
qed

 end


(*  Title:      HOL/Analysis/Operator_Norm.thy
    Author:     Amine Chaieb, University of Cambridge
    Author:     Brian Huffman
*)

section \<open>Operator Norm\<close>

theory Operator_Norm
imports Complex_Main
begin

text \<open>This formulation yields zero if \<open>'a\<close> is the trivial vector space.\<close>

text\<^marker>\<open>tag important\<close> \<open>%whitespace\<close>
definition\<^marker>\<open>tag important\<close>
onorm :: "('a::real_normed_vector \<Rightarrow> 'b::real_normed_vector) \<Rightarrow> real" where
"onorm f = (SUP x. norm (f x) / norm x)"

proposition onorm_bound:
  assumes "0 \<le> b" and "\<And>x. norm (f x) \<le> b * norm x"
  shows "onorm f \<le> b"
  unfolding onorm_def
proof (rule cSUP_least)
  fix x
  show "norm (f x) / norm x \<le> b"
    using assms by (cases "x = 0") (simp_all add: pos_divide_le_eq)
qed simp

text \<open>In non-trivial vector spaces, the first assumption is redundant.\<close>

lemma onorm_le:
  fixes f :: "'a::{real_normed_vector, perfect_space} \<Rightarrow> 'b::real_normed_vector"
  assumes "\<And>x. norm (f x) \<le> b * norm x"
  shows "onorm f \<le> b"
proof (rule onorm_bound [OF _ assms])
  have "{0::'a} \<noteq> UNIV" by (metis not_open_singleton open_UNIV)
  then obtain a :: 'a where "a \<noteq> 0" by fast
  have "0 \<le> b * norm a"
    by (rule order_trans [OF norm_ge_zero assms])
  with \<open>a \<noteq> 0\<close> show "0 \<le> b"
    by (simp add: zero_le_mult_iff)
qed

lemma le_onorm:
  assumes "bounded_linear f"
  shows "norm (f x) / norm x \<le> onorm f"
proof -
  interpret f: bounded_linear f by fact
  obtain b where "0 \<le> b" and "\<forall>x. norm (f x) \<le> norm x * b"
    using f.nonneg_bounded by auto
  then have "\<forall>x. norm (f x) / norm x \<le> b"
    by (clarify, case_tac "x = 0",
      simp_all add: f.zero pos_divide_le_eq mult.commute)
  then have "bdd_above (range (\<lambda>x. norm (f x) / norm x))"
    unfolding bdd_above_def by fast
  with UNIV_I show ?thesis
    unfolding onorm_def by (rule cSUP_upper)
qed

lemma onorm:
  assumes "bounded_linear f"
  shows "norm (f x) \<le> onorm f * norm x"
proof -
  interpret f: bounded_linear f by fact
  show ?thesis
  proof (cases)
    assume "x = 0"
    then show ?thesis by (simp add: f.zero)
  next
    assume "x \<noteq> 0"
    have "norm (f x) / norm x \<le> onorm f"
      by (rule le_onorm [OF assms])
    then show "norm (f x) \<le> onorm f * norm x"
      by (simp add: pos_divide_le_eq \<open>x \<noteq> 0\<close>)
  qed
qed

lemma onorm_pos_le:
  assumes f: "bounded_linear f"
  shows "0 \<le> onorm f"
  using le_onorm [OF f, where x=0] by simp

lemma onorm_zero: "onorm (\<lambda>x. 0) = 0"
proof (rule order_antisym)
  show "onorm (\<lambda>x. 0) \<le> 0"
    by (simp add: onorm_bound)
  show "0 \<le> onorm (\<lambda>x. 0)"
    using bounded_linear_zero by (rule onorm_pos_le)
qed

lemma onorm_eq_0:
  assumes f: "bounded_linear f"
  shows "onorm f = 0 \<longleftrightarrow> (\<forall>x. f x = 0)"
  using onorm [OF f] by (auto simp: fun_eq_iff [symmetric] onorm_zero)

lemma onorm_pos_lt:
  assumes f: "bounded_linear f"
  shows "0 < onorm f \<longleftrightarrow> \<not> (\<forall>x. f x = 0)"
  by (simp add: less_le onorm_pos_le [OF f] onorm_eq_0 [OF f])

lemma onorm_id_le: "onorm (\<lambda>x. x) \<le> 1"
  by (rule onorm_bound) simp_all

lemma onorm_id: "onorm (\<lambda>x. x::'a::{real_normed_vector, perfect_space}) = 1"
proof (rule antisym[OF onorm_id_le])
  have "{0::'a} \<noteq> UNIV" by (metis not_open_singleton open_UNIV)
  then obtain x :: 'a where "x \<noteq> 0" by fast
  hence "1 \<le> norm x / norm x"
    by simp
  also have "\<dots> \<le> onorm (\<lambda>x::'a. x)"
    by (rule le_onorm) (rule bounded_linear_ident)
  finally show "1 \<le> onorm (\<lambda>x::'a. x)" .
qed

lemma onorm_compose:
  assumes f: "bounded_linear f"
  assumes g: "bounded_linear g"
  shows "onorm (f \<circ> g) \<le> onorm f * onorm g"
proof (rule onorm_bound)
  show "0 \<le> onorm f * onorm g"
    by (intro mult_nonneg_nonneg onorm_pos_le f g)
next
  fix x
  have "norm (f (g x)) \<le> onorm f * norm (g x)"
    by (rule onorm [OF f])
  also have "onorm f * norm (g x) \<le> onorm f * (onorm g * norm x)"
    by (rule mult_left_mono [OF onorm [OF g] onorm_pos_le [OF f]])
  finally show "norm ((f \<circ> g) x) \<le> onorm f * onorm g * norm x"
    by (simp add: mult.assoc)
qed

lemma onorm_scaleR_lemma:
  assumes f: "bounded_linear f"
  shows "onorm (\<lambda>x. r *\<^sub>R f x) \<le> \<bar>r\<bar> * onorm f"
proof (rule onorm_bound)
  show "0 \<le> \<bar>r\<bar> * onorm f"
    by (intro mult_nonneg_nonneg onorm_pos_le abs_ge_zero f)
next
  fix x
  have "\<bar>r\<bar> * norm (f x) \<le> \<bar>r\<bar> * (onorm f * norm x)"
    by (intro mult_left_mono onorm abs_ge_zero f)
  then show "norm (r *\<^sub>R f x) \<le> \<bar>r\<bar> * onorm f * norm x"
    by (simp only: norm_scaleR mult.assoc)
qed

lemma onorm_scaleR:
  assumes f: "bounded_linear f"
  shows "onorm (\<lambda>x. r *\<^sub>R f x) = \<bar>r\<bar> * onorm f"
proof (cases "r = 0")
  assume "r \<noteq> 0"
  show ?thesis
  proof (rule order_antisym)
    show "onorm (\<lambda>x. r *\<^sub>R f x) \<le> \<bar>r\<bar> * onorm f"
      using f by (rule onorm_scaleR_lemma)
  next
    have "bounded_linear (\<lambda>x. r *\<^sub>R f x)"
      using bounded_linear_scaleR_right f by (rule bounded_linear_compose)
    then have "onorm (\<lambda>x. inverse r *\<^sub>R r *\<^sub>R f x) \<le> \<bar>inverse r\<bar> * onorm (\<lambda>x. r *\<^sub>R f x)"
      by (rule onorm_scaleR_lemma)
    with \<open>r \<noteq> 0\<close> show "\<bar>r\<bar> * onorm f \<le> onorm (\<lambda>x. r *\<^sub>R f x)"
      by (simp add: inverse_eq_divide pos_le_divide_eq mult.commute)
  qed
qed (simp add: onorm_zero)

lemma onorm_scaleR_left_lemma:
  assumes r: "bounded_linear r"
  shows "onorm (\<lambda>x. r x *\<^sub>R f) \<le> onorm r * norm f"
proof (rule onorm_bound)
  fix x
  have "norm (r x *\<^sub>R f) = norm (r x) * norm f"
    by simp
  also have "\<dots> \<le> onorm r * norm x * norm f"
    by (intro mult_right_mono onorm r norm_ge_zero)
  finally show "norm (r x *\<^sub>R f) \<le> onorm r * norm f * norm x"
    by (simp add: ac_simps)
qed (intro mult_nonneg_nonneg norm_ge_zero onorm_pos_le r)

lemma onorm_scaleR_left:
  assumes f: "bounded_linear r"
  shows "onorm (\<lambda>x. r x *\<^sub>R f) = onorm r * norm f"
proof (cases "f = 0")
  assume "f \<noteq> 0"
  show ?thesis
  proof (rule order_antisym)
    show "onorm (\<lambda>x. r x *\<^sub>R f) \<le> onorm r * norm f"
      using f by (rule onorm_scaleR_left_lemma)
  next
    have bl1: "bounded_linear (\<lambda>x. r x *\<^sub>R f)"
      by (metis bounded_linear_scaleR_const f)
    have "bounded_linear (\<lambda>x. r x * norm f)"
      by (metis bounded_linear_mult_const f)
    from onorm_scaleR_left_lemma[OF this, of "inverse (norm f)"]
    have "onorm r \<le> onorm (\<lambda>x. r x * norm f) * inverse (norm f)"
      using \<open>f \<noteq> 0\<close>
      by (simp add: inverse_eq_divide)
    also have "onorm (\<lambda>x. r x * norm f) \<le> onorm (\<lambda>x. r x *\<^sub>R f)"
      by (rule onorm_bound)
        (auto simp: abs_mult bl1 onorm_pos_le intro!: order_trans[OF _ onorm])
    finally show "onorm r * norm f \<le> onorm (\<lambda>x. r x *\<^sub>R f)"
      using \<open>f \<noteq> 0\<close>
      by (simp add: inverse_eq_divide pos_le_divide_eq mult.commute)
  qed
qed (simp add: onorm_zero)

lemma onorm_neg:
  shows "onorm (\<lambda>x. - f x) = onorm f"
  unfolding onorm_def by simp

lemma onorm_triangle:
  assumes f: "bounded_linear f"
  assumes g: "bounded_linear g"
  shows "onorm (\<lambda>x. f x + g x) \<le> onorm f + onorm g"
proof (rule onorm_bound)
  show "0 \<le> onorm f + onorm g"
    by (intro add_nonneg_nonneg onorm_pos_le f g)
next
  fix x
  have "norm (f x + g x) \<le> norm (f x) + norm (g x)"
    by (rule norm_triangle_ineq)
  also have "norm (f x) + norm (g x) \<le> onorm f * norm x + onorm g * norm x"
    by (intro add_mono onorm f g)
  finally show "norm (f x + g x) \<le> (onorm f + onorm g) * norm x"
    by (simp only: distrib_right)
qed

lemma onorm_triangle_le:
  assumes "bounded_linear f"
  assumes "bounded_linear g"
  assumes "onorm f + onorm g \<le> e"
  shows "onorm (\<lambda>x. f x + g x) \<le> e"
  using assms by (rule onorm_triangle [THEN order_trans])

lemma onorm_triangle_lt:
  assumes "bounded_linear f"
  assumes "bounded_linear g"
  assumes "onorm f + onorm g < e"
  shows "onorm (\<lambda>x. f x + g x) < e"
  using assms by (rule onorm_triangle [THEN order_le_less_trans])

lemma onorm_sum:
  assumes "finite S"
  assumes "\<And>s. s \<in> S \<Longrightarrow> bounded_linear (f s)"
  shows "onorm (\<lambda>x. sum (\<lambda>s. f s x) S) \<le> sum (\<lambda>s. onorm (f s)) S"
  using assms
  by (induction) (auto simp: onorm_zero intro!: onorm_triangle_le bounded_linear_sum)

lemmas onorm_sum_le = onorm_sum[THEN order_trans]

end


(* Author: Manuel Eberl *)

section \<open>Abstract euclidean algorithm\<close>

theory Euclidean_Algorithm
imports "~~/src/HOL/GCD" Factorial_Ring
begin

text \<open>
  A Euclidean semiring is a semiring upon which the Euclidean algorithm can be
  implemented. It must provide:
  \begin{itemize}
  \item division with remainder
  \item a size function such that @{term "size (a mod b) < size b"}
        for any @{term "b \<noteq> 0"}
  \end{itemize}
  The existence of these functions makes it possible to derive gcd and lcm functions
  for any Euclidean semiring.
\<close>
class euclidean_semiring = semiring_modulo + normalization_semidom +
  fixes euclidean_size :: "'a \<Rightarrow> nat"
  assumes size_0 [simp]: "euclidean_size 0 = 0"
  assumes mod_size_less:
    "b \<noteq> 0 \<Longrightarrow> euclidean_size (a mod b) < euclidean_size b"
  assumes size_mult_mono:
    "b \<noteq> 0 \<Longrightarrow> euclidean_size a \<le> euclidean_size (a * b)"
begin

lemma mod_0 [simp]: "0 mod a = 0"
  using div_mult_mod_eq [of 0 a] by simp

lemma dvd_mod_iff:
  assumes "k dvd n"
  shows   "(k dvd m mod n) = (k dvd m)"
proof -
  from assms have "(k dvd m mod n) \<longleftrightarrow> (k dvd ((m div n) * n + m mod n))"
    by (simp add: dvd_add_right_iff)
  also have "(m div n) * n + m mod n = m"
    using div_mult_mod_eq [of m n] by simp
  finally show ?thesis .
qed

lemma mod_0_imp_dvd:
  assumes "a mod b = 0"
  shows   "b dvd a"
proof -
  have "b dvd ((a div b) * b)" by simp
  also have "(a div b) * b = a"
    using div_mult_mod_eq [of a b] by (simp add: assms)
  finally show ?thesis .
qed

lemma euclidean_size_normalize [simp]:
  "euclidean_size (normalize a) = euclidean_size a"
proof (cases "a = 0")
  case True
  then show ?thesis
    by simp
next
  case [simp]: False
  have "euclidean_size (normalize a) \<le> euclidean_size (normalize a * unit_factor a)"
    by (rule size_mult_mono) simp
  moreover have "euclidean_size a \<le> euclidean_size (a * (1 div unit_factor a))"
    by (rule size_mult_mono) simp
  ultimately show ?thesis
    by simp
qed

lemma euclidean_division:
  fixes a :: 'a and b :: 'a
  assumes "b \<noteq> 0"
  obtains s and t where "a = s * b + t"
    and "euclidean_size t < euclidean_size b"
proof -
  from div_mult_mod_eq [of a b]
     have "a = a div b * b + a mod b" by simp
  with that and assms show ?thesis by (auto simp add: mod_size_less)
qed

lemma dvd_euclidean_size_eq_imp_dvd:
  assumes "a \<noteq> 0" and b_dvd_a: "b dvd a" and size_eq: "euclidean_size a = euclidean_size b"
  shows "a dvd b"
proof (rule ccontr)
  assume "\<not> a dvd b"
  hence "b mod a \<noteq> 0" using mod_0_imp_dvd[of b a] by blast
  then have "b mod a \<noteq> 0" by (simp add: mod_eq_0_iff_dvd)
  from b_dvd_a have b_dvd_mod: "b dvd b mod a" by (simp add: dvd_mod_iff)
  from b_dvd_mod obtain c where "b mod a = b * c" unfolding dvd_def by blast
    with \<open>b mod a \<noteq> 0\<close> have "c \<noteq> 0" by auto
  with \<open>b mod a = b * c\<close> have "euclidean_size (b mod a) \<ge> euclidean_size b"
      using size_mult_mono by force
  moreover from \<open>\<not> a dvd b\<close> and \<open>a \<noteq> 0\<close>
  have "euclidean_size (b mod a) < euclidean_size a"
      using mod_size_less by blast
  ultimately show False using size_eq by simp
qed

lemma size_mult_mono': "b \<noteq> 0 \<Longrightarrow> euclidean_size a \<le> euclidean_size (b * a)"
  by (subst mult.commute) (rule size_mult_mono)

lemma euclidean_size_times_unit:
  assumes "is_unit a"
  shows   "euclidean_size (a * b) = euclidean_size b"
proof (rule antisym)
  from assms have [simp]: "a \<noteq> 0" by auto
  thus "euclidean_size (a * b) \<ge> euclidean_size b" by (rule size_mult_mono')
  from assms have "is_unit (1 div a)" by simp
  hence "1 div a \<noteq> 0" by (intro notI) simp_all
  hence "euclidean_size (a * b) \<le> euclidean_size ((1 div a) * (a * b))"
    by (rule size_mult_mono')
  also from assms have "(1 div a) * (a * b) = b"
    by (simp add: algebra_simps unit_div_mult_swap)
  finally show "euclidean_size (a * b) \<le> euclidean_size b" .
qed

lemma euclidean_size_unit: "is_unit a \<Longrightarrow> euclidean_size a = euclidean_size 1"
  using euclidean_size_times_unit[of a 1] by simp

lemma unit_iff_euclidean_size:
  "is_unit a \<longleftrightarrow> euclidean_size a = euclidean_size 1 \<and> a \<noteq> 0"
proof safe
  assume A: "a \<noteq> 0" and B: "euclidean_size a = euclidean_size 1"
  show "is_unit a" by (rule dvd_euclidean_size_eq_imp_dvd[OF A _ B]) simp_all
qed (auto intro: euclidean_size_unit)

lemma euclidean_size_times_nonunit:
  assumes "a \<noteq> 0" "b \<noteq> 0" "\<not>is_unit a"
  shows   "euclidean_size b < euclidean_size (a * b)"
proof (rule ccontr)
  assume "\<not>euclidean_size b < euclidean_size (a * b)"
  with size_mult_mono'[OF assms(1), of b]
    have eq: "euclidean_size (a * b) = euclidean_size b" by simp
  have "a * b dvd b"
    by (rule dvd_euclidean_size_eq_imp_dvd[OF _ _ eq]) (insert assms, simp_all)
  hence "a * b dvd 1 * b" by simp
  with \<open>b \<noteq> 0\<close> have "is_unit a" by (subst (asm) dvd_times_right_cancel_iff)
  with assms(3) show False by contradiction
qed

lemma dvd_imp_size_le:
  assumes "a dvd b" "b \<noteq> 0"
  shows   "euclidean_size a \<le> euclidean_size b"
  using assms by (auto elim!: dvdE simp: size_mult_mono)

lemma dvd_proper_imp_size_less:
  assumes "a dvd b" "\<not>b dvd a" "b \<noteq> 0"
  shows   "euclidean_size a < euclidean_size b"
proof -
  from assms(1) obtain c where "b = a * c" by (erule dvdE)
  hence z: "b = c * a" by (simp add: mult.commute)
  from z assms have "\<not>is_unit c" by (auto simp: mult.commute mult_unit_dvd_iff)
  with z assms show ?thesis
    by (auto intro!: euclidean_size_times_nonunit simp: )
qed

function gcd_eucl :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
where
  "gcd_eucl a b = (if b = 0 then normalize a else gcd_eucl b (a mod b))"
  by pat_completeness simp
termination
  by (relation "measure (euclidean_size \<circ> snd)") (simp_all add: mod_size_less)

declare gcd_eucl.simps [simp del]

lemma gcd_eucl_induct [case_names zero mod]:
  assumes H1: "\<And>b. P b 0"
  and H2: "\<And>a b. b \<noteq> 0 \<Longrightarrow> P b (a mod b) \<Longrightarrow> P a b"
  shows "P a b"
proof (induct a b rule: gcd_eucl.induct)
  case ("1" a b)
  show ?case
  proof (cases "b = 0")
    case True then show "P a b" by simp (rule H1)
  next
    case False
    then have "P b (a mod b)"
      by (rule "1.hyps")
    with \<open>b \<noteq> 0\<close> show "P a b"
      by (blast intro: H2)
  qed
qed

definition lcm_eucl :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
where
  "lcm_eucl a b = normalize (a * b) div gcd_eucl a b"

definition Lcm_eucl :: "'a set \<Rightarrow> 'a" \<comment> \<open>
  Somewhat complicated definition of Lcm that has the advantage of working
  for infinite sets as well\<close>
where
  "Lcm_eucl A = (if \<exists>l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) then
     let l = SOME l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) \<and> euclidean_size l =
       (LEAST n. \<exists>l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) \<and> euclidean_size l = n)
       in normalize l
      else 0)"

definition Gcd_eucl :: "'a set \<Rightarrow> 'a"
where
  "Gcd_eucl A = Lcm_eucl {d. \<forall>a\<in>A. d dvd a}"

declare Lcm_eucl_def Gcd_eucl_def [code del]

lemma gcd_eucl_0:
  "gcd_eucl a 0 = normalize a"
  by (simp add: gcd_eucl.simps [of a 0])

lemma gcd_eucl_0_left:
  "gcd_eucl 0 a = normalize a"
  by (simp_all add: gcd_eucl_0 gcd_eucl.simps [of 0 a])

lemma gcd_eucl_non_0:
  "b \<noteq> 0 \<Longrightarrow> gcd_eucl a b = gcd_eucl b (a mod b)"
  by (simp add: gcd_eucl.simps [of a b] gcd_eucl.simps [of b 0])

lemma gcd_eucl_dvd1 [iff]: "gcd_eucl a b dvd a"
  and gcd_eucl_dvd2 [iff]: "gcd_eucl a b dvd b"
  by (induct a b rule: gcd_eucl_induct)
     (simp_all add: gcd_eucl_0 gcd_eucl_non_0 dvd_mod_iff)

lemma normalize_gcd_eucl [simp]:
  "normalize (gcd_eucl a b) = gcd_eucl a b"
  by (induct a b rule: gcd_eucl_induct) (simp_all add: gcd_eucl_0 gcd_eucl_non_0)

lemma gcd_eucl_greatest:
  fixes k a b :: 'a
  shows "k dvd a \<Longrightarrow> k dvd b \<Longrightarrow> k dvd gcd_eucl a b"
proof (induct a b rule: gcd_eucl_induct)
  case (zero a) from zero(1) show ?case by (rule dvd_trans) (simp add: gcd_eucl_0)
next
  case (mod a b)
  then show ?case
    by (simp add: gcd_eucl_non_0 dvd_mod_iff)
qed

lemma gcd_euclI:
  fixes gcd :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes "d dvd a" "d dvd b" "normalize d = d"
          "\<And>k. k dvd a \<Longrightarrow> k dvd b \<Longrightarrow> k dvd d"
  shows   "gcd_eucl a b = d"
  by (rule associated_eqI) (simp_all add: gcd_eucl_greatest assms)

lemma eq_gcd_euclI:
  fixes gcd :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes "\<And>a b. gcd a b dvd a" "\<And>a b. gcd a b dvd b" "\<And>a b. normalize (gcd a b) = gcd a b"
          "\<And>a b k. k dvd a \<Longrightarrow> k dvd b \<Longrightarrow> k dvd gcd a b"
  shows   "gcd = gcd_eucl"
  by (intro ext, rule associated_eqI) (simp_all add: gcd_eucl_greatest assms)

lemma gcd_eucl_zero [simp]:
  "gcd_eucl a b = 0 \<longleftrightarrow> a = 0 \<and> b = 0"
  by (metis dvd_0_left dvd_refl gcd_eucl_dvd1 gcd_eucl_dvd2 gcd_eucl_greatest)+

lemma dvd_Lcm_eucl [simp]: "a \<in> A \<Longrightarrow> a dvd Lcm_eucl A"
  and Lcm_eucl_least: "(\<And>a. a \<in> A \<Longrightarrow> a dvd b) \<Longrightarrow> Lcm_eucl A dvd b"
  and unit_factor_Lcm_eucl [simp]:
          "unit_factor (Lcm_eucl A) = (if Lcm_eucl A = 0 then 0 else 1)"
proof -
  have "(\<forall>a\<in>A. a dvd Lcm_eucl A) \<and> (\<forall>l'. (\<forall>a\<in>A. a dvd l') \<longrightarrow> Lcm_eucl A dvd l') \<and>
    unit_factor (Lcm_eucl A) = (if Lcm_eucl A = 0 then 0 else 1)" (is ?thesis)
  proof (cases "\<exists>l. l \<noteq>  0 \<and> (\<forall>a\<in>A. a dvd l)")
    case False
    hence "Lcm_eucl A = 0" by (auto simp: Lcm_eucl_def)
    with False show ?thesis by auto
  next
    case True
    then obtain l\<^sub>0 where l\<^sub>0_props: "l\<^sub>0 \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l\<^sub>0)" by blast
    define n where "n = (LEAST n. \<exists>l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) \<and> euclidean_size l = n)"
    define l where "l = (SOME l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) \<and> euclidean_size l = n)"
    have "\<exists>l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) \<and> euclidean_size l = n"
      apply (subst n_def)
      apply (rule LeastI[of _ "euclidean_size l\<^sub>0"])
      apply (rule exI[of _ l\<^sub>0])
      apply (simp add: l\<^sub>0_props)
      done
    from someI_ex[OF this] have "l \<noteq> 0" and "\<forall>a\<in>A. a dvd l" and "euclidean_size l = n"
      unfolding l_def by simp_all
    {
      fix l' assume "\<forall>a\<in>A. a dvd l'"
      with \<open>\<forall>a\<in>A. a dvd l\<close> have "\<forall>a\<in>A. a dvd gcd_eucl l l'" by (auto intro: gcd_eucl_greatest)
      moreover from \<open>l \<noteq> 0\<close> have "gcd_eucl l l' \<noteq> 0" by simp
      ultimately have "\<exists>b. b \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd b) \<and>
                          euclidean_size b = euclidean_size (gcd_eucl l l')"
        by (intro exI[of _ "gcd_eucl l l'"], auto)
      hence "euclidean_size (gcd_eucl l l') \<ge> n" by (subst n_def) (rule Least_le)
      moreover have "euclidean_size (gcd_eucl l l') \<le> n"
      proof -
        have "gcd_eucl l l' dvd l" by simp
        then obtain a where "l = gcd_eucl l l' * a" unfolding dvd_def by blast
        with \<open>l \<noteq> 0\<close> have "a \<noteq> 0" by auto
        hence "euclidean_size (gcd_eucl l l') \<le> euclidean_size (gcd_eucl l l' * a)"
          by (rule size_mult_mono)
        also have "gcd_eucl l l' * a = l" using \<open>l = gcd_eucl l l' * a\<close> ..
        also note \<open>euclidean_size l = n\<close>
        finally show "euclidean_size (gcd_eucl l l') \<le> n" .
      qed
      ultimately have *: "euclidean_size l = euclidean_size (gcd_eucl l l')"
        by (intro le_antisym, simp_all add: \<open>euclidean_size l = n\<close>)
      from \<open>l \<noteq> 0\<close> have "l dvd gcd_eucl l l'"
        by (rule dvd_euclidean_size_eq_imp_dvd) (auto simp add: *)
      hence "l dvd l'" by (rule dvd_trans[OF _ gcd_eucl_dvd2])
    }

    with \<open>(\<forall>a\<in>A. a dvd l)\<close> and unit_factor_is_unit[OF \<open>l \<noteq> 0\<close>] and \<open>l \<noteq> 0\<close>
      have "(\<forall>a\<in>A. a dvd normalize l) \<and>
        (\<forall>l'. (\<forall>a\<in>A. a dvd l') \<longrightarrow> normalize l dvd l') \<and>
        unit_factor (normalize l) =
        (if normalize l = 0 then 0 else 1)"
      by (auto simp: unit_simps)
    also from True have "normalize l = Lcm_eucl A"
      by (simp add: Lcm_eucl_def Let_def n_def l_def)
    finally show ?thesis .
  qed
  note A = this

  {fix a assume "a \<in> A" then show "a dvd Lcm_eucl A" using A by blast}
  {fix b assume "\<And>a. a \<in> A \<Longrightarrow> a dvd b" then show "Lcm_eucl A dvd b" using A by blast}
  from A show "unit_factor (Lcm_eucl A) = (if Lcm_eucl A = 0 then 0 else 1)" by blast
qed

lemma normalize_Lcm_eucl [simp]:
  "normalize (Lcm_eucl A) = Lcm_eucl A"
proof (cases "Lcm_eucl A = 0")
  case True then show ?thesis by simp
next
  case False
  have "unit_factor (Lcm_eucl A) * normalize (Lcm_eucl A) = Lcm_eucl A"
    by (fact unit_factor_mult_normalize)
  with False show ?thesis by simp
qed

lemma eq_Lcm_euclI:
  fixes lcm :: "'a set \<Rightarrow> 'a"
  assumes "\<And>A a. a \<in> A \<Longrightarrow> a dvd lcm A" and "\<And>A c. (\<And>a. a \<in> A \<Longrightarrow> a dvd c) \<Longrightarrow> lcm A dvd c"
          "\<And>A. normalize (lcm A) = lcm A" shows "lcm = Lcm_eucl"
  by (intro ext, rule associated_eqI) (auto simp: assms intro: Lcm_eucl_least)

lemma Gcd_eucl_dvd: "a \<in> A \<Longrightarrow> Gcd_eucl A dvd a"
  unfolding Gcd_eucl_def by (auto intro: Lcm_eucl_least)

lemma Gcd_eucl_greatest: "(\<And>x. x \<in> A \<Longrightarrow> d dvd x) \<Longrightarrow> d dvd Gcd_eucl A"
  unfolding Gcd_eucl_def by auto

lemma normalize_Gcd_eucl [simp]: "normalize (Gcd_eucl A) = Gcd_eucl A"
  by (simp add: Gcd_eucl_def)

lemma Lcm_euclI:
  assumes "\<And>x. x \<in> A \<Longrightarrow> x dvd d" "\<And>d'. (\<And>x. x \<in> A \<Longrightarrow> x dvd d') \<Longrightarrow> d dvd d'" "normalize d = d"
  shows   "Lcm_eucl A = d"
proof -
  have "normalize (Lcm_eucl A) = normalize d"
    by (intro associatedI) (auto intro: dvd_Lcm_eucl Lcm_eucl_least assms)
  thus ?thesis by (simp add: assms)
qed

lemma Gcd_euclI:
  assumes "\<And>x. x \<in> A \<Longrightarrow> d dvd x" "\<And>d'. (\<And>x. x \<in> A \<Longrightarrow> d' dvd x) \<Longrightarrow> d' dvd d" "normalize d = d"
  shows   "Gcd_eucl A = d"
proof -
  have "normalize (Gcd_eucl A) = normalize d"
    by (intro associatedI) (auto intro: Gcd_eucl_dvd Gcd_eucl_greatest assms)
  thus ?thesis by (simp add: assms)
qed

lemmas lcm_gcd_eucl_facts =
  gcd_eucl_dvd1 gcd_eucl_dvd2 gcd_eucl_greatest normalize_gcd_eucl lcm_eucl_def
  Gcd_eucl_def Gcd_eucl_dvd Gcd_eucl_greatest normalize_Gcd_eucl
  dvd_Lcm_eucl Lcm_eucl_least normalize_Lcm_eucl

lemma normalized_factors_product:
  "{p. p dvd a * b \<and> normalize p = p} =
     (\<lambda>(x,y). x * y) ` ({p. p dvd a \<and> normalize p = p} \<times> {p. p dvd b \<and> normalize p = p})"
proof safe
  fix p assume p: "p dvd a * b" "normalize p = p"
  interpret semiring_gcd 1 0 "op *" gcd_eucl lcm_eucl "op div" "op +" "op -" normalize unit_factor
    by standard (rule lcm_gcd_eucl_facts; assumption)+
  from dvd_productE[OF p(1)] guess x y . note xy = this
  define x' y' where "x' = normalize x" and "y' = normalize y"
  have "p = x' * y'"
    by (subst p(2) [symmetric]) (simp add: xy x'_def y'_def normalize_mult)
  moreover from xy have "normalize x' = x'" "normalize y' = y'" "x' dvd a" "y' dvd b"
    by (simp_all add: x'_def y'_def)
  ultimately show "p \<in> (\<lambda>(x, y). x * y) `
                     ({p. p dvd a \<and> normalize p = p} \<times> {p. p dvd b \<and> normalize p = p})"
    by blast
qed (auto simp: normalize_mult mult_dvd_mono)

subclass factorial_semiring
proof (standard, rule factorial_semiring_altI_aux)
  fix x assume "x \<noteq> 0"
  thus "finite {p. p dvd x \<and> normalize p = p}"
  proof (induction "euclidean_size x" arbitrary: x rule: less_induct)
    case (less x)
    show ?case
    proof (cases "\<exists>y. y dvd x \<and> \<not>x dvd y \<and> \<not>is_unit y")
      case False
      have "{p. p dvd x \<and> normalize p = p} \<subseteq> {1, normalize x}"
      proof
        fix p assume p: "p \<in> {p. p dvd x \<and> normalize p = p}"
        with False have "is_unit p \<or> x dvd p" by blast
        thus "p \<in> {1, normalize x}"
        proof (elim disjE)
          assume "is_unit p"
          hence "normalize p = 1" by (simp add: is_unit_normalize)
          with p show ?thesis by simp
        next
          assume "x dvd p"
          with p have "normalize p = normalize x" by (intro associatedI) simp_all
          with p show ?thesis by simp
        qed
      qed
      moreover have "finite \<dots>" by simp
      ultimately show ?thesis by (rule finite_subset)

    next
      case True
      then obtain y where y: "y dvd x" "\<not>x dvd y" "\<not>is_unit y" by blast
      define z where "z = x div y"
      let ?fctrs = "\<lambda>x. {p. p dvd x \<and> normalize p = p}"
      from y have x: "x = y * z" by (simp add: z_def)
      with less.prems have "y \<noteq> 0" "z \<noteq> 0" by auto
      from x y have "\<not>is_unit z" by (auto simp: mult_unit_dvd_iff)
      have "?fctrs x = (\<lambda>(p,p'). p * p') ` (?fctrs y \<times> ?fctrs z)"
        by (subst x) (rule normalized_factors_product)
      also have "\<not>y * z dvd y * 1" "\<not>y * z dvd 1 * z"
        by (subst dvd_times_left_cancel_iff dvd_times_right_cancel_iff; fact)+
      hence "finite ((\<lambda>(p,p'). p * p') ` (?fctrs y \<times> ?fctrs z))"
        by (intro finite_imageI finite_cartesian_product less dvd_proper_imp_size_less)
           (auto simp: x)
      finally show ?thesis .
    qed
  qed
next
  interpret semiring_gcd 1 0 "op *" gcd_eucl lcm_eucl "op div" "op +" "op -" normalize unit_factor
    by standard (rule lcm_gcd_eucl_facts; assumption)+
  fix p assume p: "irreducible p"
  thus "prime_elem p" by (rule irreducible_imp_prime_elem_gcd)
qed

lemma gcd_eucl_eq_gcd_factorial: "gcd_eucl = gcd_factorial"
  by (intro ext gcd_euclI gcd_lcm_factorial)

lemma lcm_eucl_eq_lcm_factorial: "lcm_eucl = lcm_factorial"
  by (intro ext) (simp add: lcm_eucl_def lcm_factorial_gcd_factorial gcd_eucl_eq_gcd_factorial)

lemma Gcd_eucl_eq_Gcd_factorial: "Gcd_eucl = Gcd_factorial"
  by (intro ext Gcd_euclI gcd_lcm_factorial)

lemma Lcm_eucl_eq_Lcm_factorial: "Lcm_eucl = Lcm_factorial"
  by (intro ext Lcm_euclI gcd_lcm_factorial)

lemmas eucl_eq_factorial =
  gcd_eucl_eq_gcd_factorial lcm_eucl_eq_lcm_factorial
  Gcd_eucl_eq_Gcd_factorial Lcm_eucl_eq_Lcm_factorial

end

class euclidean_ring = euclidean_semiring + idom
begin

function euclid_ext_aux :: "'a \<Rightarrow> _" where
  "euclid_ext_aux r' r s' s t' t = (
     if r = 0 then let c = 1 div unit_factor r' in (s' * c, t' * c, normalize r')
     else let q = r' div r
          in  euclid_ext_aux r (r' mod r) s (s' - q * s) t (t' - q * t))"
by auto
termination by (relation "measure (\<lambda>(_,b,_,_,_,_). euclidean_size b)") (simp_all add: mod_size_less)

declare euclid_ext_aux.simps [simp del]

lemma euclid_ext_aux_correct:
  assumes "gcd_eucl r' r = gcd_eucl a b"
  assumes "s' * a + t' * b = r'"
  assumes "s * a + t * b = r"
  shows   "case euclid_ext_aux r' r s' s t' t of (x,y,c) \<Rightarrow>
             x * a + y * b = c \<and> c = gcd_eucl a b" (is "?P (euclid_ext_aux r' r s' s t' t)")
using assms
proof (induction r' r s' s t' t rule: euclid_ext_aux.induct)
  case (1 r' r s' s t' t)
  show ?case
  proof (cases "r = 0")
    case True
    hence "euclid_ext_aux r' r s' s t' t =
             (s' div unit_factor r', t' div unit_factor r', normalize r')"
      by (subst euclid_ext_aux.simps) (simp add: Let_def)
    also have "?P \<dots>"
    proof safe
      have "s' div unit_factor r' * a + t' div unit_factor r' * b =
                (s' * a + t' * b) div unit_factor r'"
        by (cases "r' = 0") (simp_all add: unit_div_commute)
      also have "s' * a + t' * b = r'" by fact
      also have "\<dots> div unit_factor r' = normalize r'" by simp
      finally show "s' div unit_factor r' * a + t' div unit_factor r' * b = normalize r'" .
    next
      from "1.prems" True show "normalize r' = gcd_eucl a b" by (simp add: gcd_eucl_0)
    qed
    finally show ?thesis .
  next
    case False
    hence "euclid_ext_aux r' r s' s t' t =
             euclid_ext_aux r (r' mod r) s (s' - r' div r * s) t (t' - r' div r * t)"
      by (subst euclid_ext_aux.simps) (simp add: Let_def)
    also from "1.prems" False have "?P \<dots>"
    proof (intro "1.IH")
      have "(s' - r' div r * s) * a + (t' - r' div r * t) * b =
              (s' * a + t' * b) - r' div r * (s * a + t * b)" by (simp add: algebra_simps)
      also have "s' * a + t' * b = r'" by fact
      also have "s * a + t * b = r" by fact
      also have "r' - r' div r * r = r' mod r" using div_mult_mod_eq [of r' r]
        by (simp add: algebra_simps)
      finally show "(s' - r' div r * s) * a + (t' - r' div r * t) * b = r' mod r" .
    qed (auto simp: gcd_eucl_non_0 algebra_simps minus_mod_eq_div_mult [symmetric])
    finally show ?thesis .
  qed
qed

definition euclid_ext where
  "euclid_ext a b = euclid_ext_aux a b 1 0 0 1"

lemma euclid_ext_0:
  "euclid_ext a 0 = (1 div unit_factor a, 0, normalize a)"
  by (simp add: euclid_ext_def euclid_ext_aux.simps)

lemma euclid_ext_left_0:
  "euclid_ext 0 a = (0, 1 div unit_factor a, normalize a)"
  by (simp add: euclid_ext_def euclid_ext_aux.simps)

lemma euclid_ext_correct':
  "case euclid_ext a b of (x,y,c) \<Rightarrow> x * a + y * b = c \<and> c = gcd_eucl a b"
  unfolding euclid_ext_def by (rule euclid_ext_aux_correct) simp_all

lemma euclid_ext_gcd_eucl:
  "(case euclid_ext a b of (x,y,c) \<Rightarrow> c) = gcd_eucl a b"
  using euclid_ext_correct'[of a b] by (simp add: case_prod_unfold)

definition euclid_ext' where
  "euclid_ext' a b = (case euclid_ext a b of (x, y, _) \<Rightarrow> (x, y))"

lemma euclid_ext'_correct':
  "case euclid_ext' a b of (x,y) \<Rightarrow> x * a + y * b = gcd_eucl a b"
  using euclid_ext_correct'[of a b] by (simp add: case_prod_unfold euclid_ext'_def)

lemma euclid_ext'_0: "euclid_ext' a 0 = (1 div unit_factor a, 0)"
  by (simp add: euclid_ext'_def euclid_ext_0)

lemma euclid_ext'_left_0: "euclid_ext' 0 a = (0, 1 div unit_factor a)"
  by (simp add: euclid_ext'_def euclid_ext_left_0)

end

class euclidean_semiring_gcd = euclidean_semiring + gcd + Gcd +
  assumes gcd_gcd_eucl: "gcd = gcd_eucl" and lcm_lcm_eucl: "lcm = lcm_eucl"
  assumes Gcd_Gcd_eucl: "Gcd = Gcd_eucl" and Lcm_Lcm_eucl: "Lcm = Lcm_eucl"
begin

subclass semiring_gcd
  by standard (simp_all add: gcd_gcd_eucl gcd_eucl_greatest lcm_lcm_eucl lcm_eucl_def)

subclass semiring_Gcd
  by standard (auto simp: Gcd_Gcd_eucl Lcm_Lcm_eucl Gcd_eucl_def intro: Lcm_eucl_least)

subclass factorial_semiring_gcd
proof
  fix a b
  show "gcd a b = gcd_factorial a b"
    by (rule sym, rule gcdI) (rule gcd_lcm_factorial; assumption)+
  thus "lcm a b = lcm_factorial a b"
    by (simp add: lcm_factorial_gcd_factorial lcm_gcd)
next
  fix A
  show "Gcd A = Gcd_factorial A"
    by (rule sym, rule GcdI) (rule gcd_lcm_factorial; assumption)+
  show "Lcm A = Lcm_factorial A"
    by (rule sym, rule LcmI) (rule gcd_lcm_factorial; assumption)+
qed

lemma gcd_non_0:
  "b \<noteq> 0 \<Longrightarrow> gcd a b = gcd b (a mod b)"
  unfolding gcd_gcd_eucl by (fact gcd_eucl_non_0)

lemmas gcd_0 = gcd_0_right
lemmas dvd_gcd_iff = gcd_greatest_iff
lemmas gcd_greatest_iff = dvd_gcd_iff

lemma gcd_mod1 [simp]:
  "gcd (a mod b) b = gcd a b"
  by (rule gcdI, metis dvd_mod_iff gcd_dvd1 gcd_dvd2, simp_all add: gcd_greatest dvd_mod_iff)

lemma gcd_mod2 [simp]:
  "gcd a (b mod a) = gcd a b"
  by (rule gcdI, simp, metis dvd_mod_iff gcd_dvd1 gcd_dvd2, simp_all add: gcd_greatest dvd_mod_iff)

lemma euclidean_size_gcd_le1 [simp]:
  assumes "a \<noteq> 0"
  shows "euclidean_size (gcd a b) \<le> euclidean_size a"
proof -
   have "gcd a b dvd a" by (rule gcd_dvd1)
   then obtain c where A: "a = gcd a b * c" unfolding dvd_def by blast
   with \<open>a \<noteq> 0\<close> show ?thesis by (subst (2) A, intro size_mult_mono) auto
qed

lemma euclidean_size_gcd_le2 [simp]:
  "b \<noteq> 0 \<Longrightarrow> euclidean_size (gcd a b) \<le> euclidean_size b"
  by (subst gcd.commute, rule euclidean_size_gcd_le1)

lemma euclidean_size_gcd_less1:
  assumes "a \<noteq> 0" and "\<not>a dvd b"
  shows "euclidean_size (gcd a b) < euclidean_size a"
proof (rule ccontr)
  assume "\<not>euclidean_size (gcd a b) < euclidean_size a"
  with \<open>a \<noteq> 0\<close> have A: "euclidean_size (gcd a b) = euclidean_size a"
    by (intro le_antisym, simp_all)
  have "a dvd gcd a b"
    by (rule dvd_euclidean_size_eq_imp_dvd) (simp_all add: assms A)
  hence "a dvd b" using dvd_gcdD2 by blast
  with \<open>\<not>a dvd b\<close> show False by contradiction
qed

lemma euclidean_size_gcd_less2:
  assumes "b \<noteq> 0" and "\<not>b dvd a"
  shows "euclidean_size (gcd a b) < euclidean_size b"
  using assms by (subst gcd.commute, rule euclidean_size_gcd_less1)

lemma euclidean_size_lcm_le1:
  assumes "a \<noteq> 0" and "b \<noteq> 0"
  shows "euclidean_size a \<le> euclidean_size (lcm a b)"
proof -
  have "a dvd lcm a b" by (rule dvd_lcm1)
  then obtain c where A: "lcm a b = a * c" ..
  with \<open>a \<noteq> 0\<close> and \<open>b \<noteq> 0\<close> have "c \<noteq> 0" by (auto simp: lcm_eq_0_iff)
  then show ?thesis by (subst A, intro size_mult_mono)
qed

lemma euclidean_size_lcm_le2:
  "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> euclidean_size b \<le> euclidean_size (lcm a b)"
  using euclidean_size_lcm_le1 [of b a] by (simp add: ac_simps)

lemma euclidean_size_lcm_less1:
  assumes "b \<noteq> 0" and "\<not>b dvd a"
  shows "euclidean_size a < euclidean_size (lcm a b)"
proof (rule ccontr)
  from assms have "a \<noteq> 0" by auto
  assume "\<not>euclidean_size a < euclidean_size (lcm a b)"
  with \<open>a \<noteq> 0\<close> and \<open>b \<noteq> 0\<close> have "euclidean_size (lcm a b) = euclidean_size a"
    by (intro le_antisym, simp, intro euclidean_size_lcm_le1)
  with assms have "lcm a b dvd a"
    by (rule_tac dvd_euclidean_size_eq_imp_dvd) (auto simp: lcm_eq_0_iff)
  hence "b dvd a" by (rule lcm_dvdD2)
  with \<open>\<not>b dvd a\<close> show False by contradiction
qed

lemma euclidean_size_lcm_less2:
  assumes "a \<noteq> 0" and "\<not>a dvd b"
  shows "euclidean_size b < euclidean_size (lcm a b)"
  using assms euclidean_size_lcm_less1 [of a b] by (simp add: ac_simps)

lemma Lcm_eucl_set [code]:
  "Lcm_eucl (set xs) = foldl lcm_eucl 1 xs"
  by (simp add: Lcm_Lcm_eucl [symmetric] lcm_lcm_eucl Lcm_set)

lemma Gcd_eucl_set [code]:
  "Gcd_eucl (set xs) = foldl gcd_eucl 0 xs"
  by (simp add: Gcd_Gcd_eucl [symmetric] gcd_gcd_eucl Gcd_set)

end

text \<open>
  A Euclidean ring is a Euclidean semiring with additive inverses. It provides a
  few more lemmas; in particular, Bezout's lemma holds for any Euclidean ring.
\<close>

class euclidean_ring_gcd = euclidean_semiring_gcd + idom
begin

subclass euclidean_ring ..
subclass ring_gcd ..
subclass factorial_ring_gcd ..

lemma euclid_ext_gcd [simp]:
  "(case euclid_ext a b of (_, _ , t) \<Rightarrow> t) = gcd a b"
  using euclid_ext_correct'[of a b] by (simp add: case_prod_unfold Let_def gcd_gcd_eucl)

lemma euclid_ext_gcd' [simp]:
  "euclid_ext a b = (r, s, t) \<Longrightarrow> t = gcd a b"
  by (insert euclid_ext_gcd[of a b], drule (1) subst, simp)

lemma euclid_ext_correct:
  "case euclid_ext a b of (x,y,c) \<Rightarrow> x * a + y * b = c \<and> c = gcd a b"
  using euclid_ext_correct'[of a b]
  by (simp add: gcd_gcd_eucl case_prod_unfold)

lemma euclid_ext'_correct:
  "fst (euclid_ext' a b) * a + snd (euclid_ext' a b) * b = gcd a b"
  using euclid_ext_correct'[of a b]
  by (simp add: gcd_gcd_eucl case_prod_unfold euclid_ext'_def)

lemma bezout: "\<exists>s t. s * a + t * b = gcd a b"
  using euclid_ext'_correct by blast

end

subsection \<open>Typical instances\<close>

instantiation nat :: euclidean_semiring
begin

definition [simp]:
  "euclidean_size_nat = (id :: nat \<Rightarrow> nat)"

instance by standard simp_all

end

instantiation int :: euclidean_ring
begin

definition [simp]:
  "euclidean_size_int = (nat \<circ> abs :: int \<Rightarrow> nat)"

instance by standard (auto simp add: abs_mult nat_mult_distrib split: abs_split)

end

instance nat :: euclidean_semiring_gcd
proof
  show [simp]: "gcd = (gcd_eucl :: nat \<Rightarrow> _)" "Lcm = (Lcm_eucl :: nat set \<Rightarrow> _)"
    by (simp_all add: eq_gcd_euclI eq_Lcm_euclI)
  show "lcm = (lcm_eucl :: nat \<Rightarrow> _)" "Gcd = (Gcd_eucl :: nat set \<Rightarrow> _)"
    by (intro ext, simp add: lcm_eucl_def lcm_nat_def Gcd_nat_def Gcd_eucl_def)+
qed

instance int :: euclidean_ring_gcd
proof
  show [simp]: "gcd = (gcd_eucl :: int \<Rightarrow> _)" "Lcm = (Lcm_eucl :: int set \<Rightarrow> _)"
    by (simp_all add: eq_gcd_euclI eq_Lcm_euclI)
  show "lcm = (lcm_eucl :: int \<Rightarrow> _)" "Gcd = (Gcd_eucl :: int set \<Rightarrow> _)"
    by (intro ext, simp add: lcm_eucl_def lcm_altdef_int
          semiring_Gcd_class.Gcd_Lcm Gcd_eucl_def abs_mult)+
qed

end


(* author: R. Thiemann *)

section \<open>Sunflowers\<close>

text \<open>Sunflowers are sets of sets, such that whenever an element
  is contained in at least two of the sets,
  then it is contained in all of the sets.\<close>

theory Sunflower
  imports Main
    "HOL-Library.FuncSet"
begin

definition sunflower :: "'a set set \<Rightarrow> bool" where
  "sunflower S = (\<forall> x. (\<exists> A B. A \<in> S \<and> B \<in> S \<and> A \<noteq> B \<and>
     x \<in> A \<and> x \<in> B)
    \<longrightarrow> (\<forall> A. A \<in> S \<longrightarrow> x \<in> A))"

lemma sunflower_subset: "F \<subseteq> G \<Longrightarrow> sunflower G \<Longrightarrow> sunflower F"
  unfolding sunflower_def by blast

lemma pairwise_disjnt_imp_sunflower:
  "pairwise disjnt F \<Longrightarrow> sunflower F"
  unfolding sunflower_def
  by (metis disjnt_insert1 mk_disjoint_insert pairwiseD)

lemma card2_sunflower: assumes "finite S" and "card S \<le> 2"
  shows "sunflower S"
proof -
  from assms have "card S = 0 \<or> card S = Suc 0 \<or> card S = 2" by linarith
  with \<open>finite S\<close> obtain A B where "S = {} \<or> S = {A} \<or> S = {A,B}"
    using card_2_iff[of S] card_1_singleton_iff[of S] by auto
  thus ?thesis unfolding sunflower_def by auto
qed

lemma empty_sunflower: "sunflower {}"
  by (rule card2_sunflower, auto)

lemma singleton_sunflower: "sunflower {A}"
  by (rule card2_sunflower, auto)

lemma doubleton_sunflower: "sunflower {A,B}"
  by (rule card2_sunflower, auto, cases "A = B", auto)

lemma sunflower_imp_union_intersect_unique:
  assumes "sunflower S"
    and "x \<in> (\<Union> S) - (\<Inter> S)"
  shows "\<exists>! A. A \<in> S \<and> x \<in> A"
proof -
  from assms obtain A where A: "A \<in> S" "x \<in> A" by auto
  show ?thesis
  proof
    show "A \<in> S \<and> x \<in> A" using A by auto
    fix B
    assume B: "B \<in> S \<and> x \<in> B"
    show "B = A"
    proof (rule ccontr)
      assume "B \<noteq> A"
      with A B have "\<exists>A B. A \<in> S \<and> B \<in> S \<and> A \<noteq> B \<and> x \<in> A \<and> x \<in> B" by auto
      from \<open>sunflower S\<close>[unfolded sunflower_def, rule_format, OF this]
      have "x \<in> \<Inter> S" by auto
      with assms show False by auto
    qed
  qed
qed

lemma union_intersect_unique_imp_sunflower:
  assumes "\<And> x. x \<in> (\<Union> S) - (\<Inter> S) \<Longrightarrow> \<exists>\<^sub>\<le>\<^sub>1 A. A \<in> S \<and> x \<in> A"
  shows "sunflower S"
  unfolding sunflower_def
proof (intro allI impI, elim exE conjE, goal_cases)
  case (1 x C A B)
  hence x: "x \<in> \<Union> S" by auto
  show ?case
  proof (cases "x \<in> \<Inter> S")
    case False
    with assms[of x] x have "\<exists>\<^sub>\<le>\<^sub>1 A. A \<in> S \<and> x \<in> A" by blast
    with 1 have False unfolding Uniq_def by blast
    thus ?thesis ..
  next
    case True
    with 1 show ?thesis by blast
  qed
qed

lemma sunflower_iff_union_intersect_unique:
  "sunflower S \<longleftrightarrow> (\<forall> x \<in> \<Union> S - \<Inter> S. \<exists>! A. A \<in> S \<and> x \<in> A)"
  (is "?l = ?r")
proof
  assume ?l
  from sunflower_imp_union_intersect_unique[OF this]
  show ?r by auto
next
  assume ?r
  hence *: "\<forall>x\<in>\<Union> S - \<Inter> S. \<exists>\<^sub>\<le>\<^sub>1 A. A \<in> S \<and> x \<in> A"
    unfolding ex1_iff_ex_Uniq by auto
  show ?l
    by (rule union_intersect_unique_imp_sunflower, insert *, auto)
qed

lemma sunflower_iff_intersect_Uniq:
  "sunflower S \<longleftrightarrow> (\<forall> x.  x \<in> \<Inter> S \<or> (\<exists>\<^sub>\<le>\<^sub>1 A. A \<in> S \<and> x \<in> A))"
  (is "?l = ?r")
proof
  assume ?l
  from sunflower_imp_union_intersect_unique[OF this]
  show ?r unfolding ex1_iff_ex_Uniq
    by (metis (no_types, lifting) DiffI UnionI Uniq_I)
next
  assume ?r
  show ?l
    by (rule union_intersect_unique_imp_sunflower, insert \<open>?r\<close>, auto)
qed

text \<open>If there exists sunflowers whenever all elements are sets of
  the same cardinality @{term r}, then there also exists sunflowers
  whenever all elements are sets with cardinality at most @{term r}.\<close>

lemma sunflower_card_subset_lift: fixes F :: "'a set set"
  assumes sunflower: "\<And> G :: ('a + nat) set set.
     (\<forall> A \<in> G. finite A \<and> card A = k) \<Longrightarrow> card G > c
        \<Longrightarrow> \<exists> S. S \<subseteq> G \<and> sunflower S \<and> card S = r"
    and kF: "\<forall> A \<in> F. finite A \<and> card A \<le> k"
    and cardF: "card F > c"
  shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r"
proof -
  let ?n = "Suc c"
  from cardF have "card F \<ge> ?n" by auto
  then obtain FF where sub: "FF \<subseteq> F" and cardF: "card FF = ?n"
    by (rule obtain_subset_with_card_n)
  let ?N = "{0 ..< ?n}"
  from cardF have "finite FF"
    by (simp add: card_ge_0_finite)
  from ex_bij_betw_nat_finite[OF this, unfolded cardF]
  obtain f where f: "bij_betw f ?N FF" by auto
  hence injf: "inj_on f ?N" by (rule bij_betw_imp_inj_on)
  have Ff: "FF = f ` ?N"
    by (metis bij_betw_imp_surj_on f)
  define g where "g = (\<lambda> i. (Inl ` f i) \<union> (Inr ` {0 ..< (k - card (f i))}))"
  have injg: "inj_on g ?N" unfolding g_def using f
  proof (intro inj_onI, goal_cases)
    case (1 x y)
    hence "f x = f y" by auto
    with injf 1 show "x = y"
      by (meson inj_onD)
  qed
  hence cardgN: "card (g ` ?N) > c"
    by (simp add: card_image)
  {
    fix i
    assume "i \<in> ?N"
    hence "f i \<in> FF" unfolding Ff by auto
    with sub have "f i \<in> F" by auto
    hence "card (f i) \<le> k" "finite (f i)" using kF by auto
    hence "card (g i) = k \<and> finite (g i)" unfolding g_def
      by (subst card_Un_disjoint, auto, subst (1 2) card_image, auto intro: inj_onI)
  }
  hence "\<forall> A \<in> g ` ?N. finite A \<and> card A = k" by auto
  from sunflower[OF this cardgN]
  obtain S where SgN: "S \<subseteq> g ` ?N" and sf: "sunflower S" and card: "card S = r" by auto
  from SgN obtain N where NN: "N \<subseteq> ?N" and SgN: "S = g ` N"
    by (meson subset_image_iff)
  from injg NN have inj_g: "inj_on g N"
    by (rule inj_on_subset)
  from injf NN have inj_f: "inj_on f N"
    by (rule inj_on_subset)
  from card_image[OF inj_g] SgN card
  have cardN: "card N = r" by auto
  let ?S = "f ` N"
  show ?thesis
  proof (intro exI[of _ ?S] conjI)
    from NN show "?S \<subseteq> F" using Ff sub by auto
    from card_image[OF inj_f] cardN show "card ?S = r" by auto
    show "sunflower ?S" unfolding sunflower_def
    proof (intro allI impI, elim exE conjE, goal_cases)
      case (1 x C A B)
      from \<open>A \<in> f ` N\<close> obtain i where i: "i \<in> N" and A: "A = f i" by auto
      from \<open>B \<in> f ` N\<close> obtain j where j: "j \<in> N" and B: "B = f j" by auto
      from \<open>C \<in> f ` N\<close> obtain k where k: "k \<in> N" and C: "C = f k" by auto
      hence gk: "g k \<in> g ` N" by auto
      from \<open>A \<noteq> B\<close> A B have ij: "i \<noteq> j" by auto
      from inj_g ij i j have gij: "g i \<noteq> g j" by (metis inj_on_contraD)
      from \<open>x \<in> A\<close> have memi: "Inl x \<in> g i" unfolding A g_def by auto
      from \<open>x \<in> B\<close> have memj: "Inl x \<in> g j" unfolding B g_def by auto
      have "\<exists>A B. A \<in> g ` N \<and> B \<in> g ` N \<and> A \<noteq> B \<and> Inl x \<in> A \<and> Inl x \<in> B"
        using memi memj gij i j by auto
      from sf[unfolded sunflower_def SgN, rule_format, OF this gk] have "Inl x \<in> g k" .
      thus "x \<in> C" unfolding C g_def by auto
    qed
  qed
qed

text \<open>We provide another sunflower lifting lemma that ensures
  non-empty cores. Here, all elements must be taken
  from a finite set, and the bound is multiplied the cardinality.\<close>

lemma sunflower_card_core_lift:
  assumes finE: "finite (E :: 'a set)"
    and sunflower: "\<And> G :: 'a set set.
     (\<forall> A \<in> G. finite A \<and> card A \<le> k) \<Longrightarrow> card G > c
        \<Longrightarrow> \<exists> S. S \<subseteq> G \<and> sunflower S \<and> card S = r"
    and F: "\<forall> A \<in> F. A \<subseteq> E \<and> s \<le> card A \<and> card A \<le> k"
    and cardF: "card F > (card E choose s) * c"
    and s: "s \<noteq> 0"
    and r: "r \<noteq> 0"
  shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r \<and> card (\<Inter> S) \<ge> s"
proof -
  let ?g = "\<lambda> (A :: 'a set) x. card x = s \<and> x \<subseteq> A"
  let ?E = "{X. X \<subseteq> E \<and> card X = s}"
  from cardF have finF: "finite F"
    by (metis card.infinite le_0_eq less_le)
  from cardF have FnE: "F \<noteq> {}" by force
  {
    from FnE obtain B where B: "B \<in> F" by auto
    with F[rule_format, OF B] obtain A where "A \<subseteq> E" "card A = s"
      by (meson obtain_subset_with_card_n order_trans)
    hence "?E \<noteq> {}" using B by auto
  } note EnE = this
  define f where "f = (\<lambda> A. SOME x. ?g A x)"
  from finE have finiteE: "finite ?E" by simp

  have "f \<in> F \<rightarrow> ?E"
  proof
    fix B
    assume B: "B \<in> F"
    with F[rule_format, OF B] have "\<exists> x. ?g B x" by (meson obtain_subset_with_card_n)
    from someI_ex[OF this] B F show "f B \<in> ?E" unfolding f_def by auto
  qed
  from pigeonhole_card[OF this finF finiteE EnE]
  obtain a where a: "a \<in> ?E"
    and le: "card F \<le> card (f -` {a} \<inter> F) * card ?E" by auto
  have precond: "\<forall>A\<in>f -` {a} \<inter> F. finite A \<and> card A \<le> k"
    using F finite_subset[OF _ finE] by auto
  have "c * (card E choose s) = (card E choose s) * c" by simp
  also have "\<dots> < card F" by fact
  also have "\<dots> \<le> (card (f -` {a} \<inter> F)) * card ?E" by fact
  also have "card ?E = card E choose s" by (rule n_subsets[OF finE])
  finally have "c < card (f -` {a} \<inter> F)" by auto
  from sunflower[OF precond this]
  obtain S where *: "S \<subseteq> f -` {a} \<inter> F" "sunflower S" "card S = r"
    by auto
  from finite_subset[OF _ finF, of S]
  have finS: "finite S" using * by auto
  from * r have SnE: "S \<noteq> {}" by auto
  have finIS: "finite (\<Inter> S)"
  proof (rule finite_Inter)
    from SnE obtain A where A: "A \<in> S" by auto
    with F s have "finite A"
      using * precond by blast
    thus "\<exists>A\<in>S. finite A" using A by auto
  qed
  show ?thesis
  proof (intro exI[of _ S] conjI *)
    show "S \<subseteq> F" using * by auto
    {
      fix A
      assume "A \<in> S"
      with *(1) have "A \<in> f -` {a}" and A: "A \<in> F" using * by auto
      from this have **: "f A = a" "A \<in> F" by auto
      from F[rule_format, OF A] have "\<exists>x. card x = s \<and> x \<subseteq> A"
        by (meson obtain_subset_with_card_n order_trans)
      from someI_ex[of "?g A", OF this] **
      have "a \<subseteq> A" unfolding f_def by auto
    }
    hence "a \<subseteq> \<Inter> S" by auto
    from card_mono[OF finIS this]
    have "card a \<le> card (\<Inter> S)" .
    with a show "s \<le> card (\<Inter> S)" by auto
  qed
qed

lemma sunflower_nonempty_core_lift:
  assumes finE: "finite (E :: 'a set)"
    and sunflower: "\<And> G :: 'a set set.
     (\<forall> A \<in> G. finite A \<and> card A \<le> k) \<Longrightarrow> card G > c
        \<Longrightarrow> \<exists> S. S \<subseteq> G \<and> sunflower S \<and> card S = r"
    and F: "\<forall> A \<in> F. A \<subseteq> E \<and> card A \<le> k"
    and empty: "{} \<notin> F"
    and cardF: "card F > card E * c"
  shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r \<and> (\<Inter> S) \<noteq> {}"
proof (cases "r = 0")
  case False
  from F empty have F': "\<forall>A\<in>F. A \<subseteq> E \<and> 1 \<le> card A \<and> card A \<le> k " using finE
    by (metis One_nat_def Suc_leI card_gt_0_iff finite_subset)
  from cardF have cardF': "(card E choose 1) * c < card F" by auto
  from sunflower_card_core_lift[OF finE sunflower, of k c F 1, OF _ _ F' cardF' _ False]
  obtain S where "S \<subseteq> F" and main: "sunflower S" "card S = r" "1 \<le> card (\<Inter> S)" by auto
  thus ?thesis by (intro exI[of _ S], auto)
next
  case True
  thus ?thesis by (intro exI[of _ "{}"], auto simp: empty_sunflower)
qed

end


theory Exercise5p4
imports Main
begin

inductive ev :: "nat \<Rightarrow> bool" where
    ev0:  "ev 0"
  | evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

(* Exercise 5.4 *)
lemma "\<not> ev (Suc (Suc (Suc 0)))" (is "\<not>?P")
proof
  assume "?P"
  then have "ev (Suc 0)" by cases (* This is the same as "proof cases qed" because
                                     there is nothing to prove *)
  then show False by cases
qed

end


(*  Title:       Roots of real quadratics
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

(* After Isabelle 2012, this may be moved to ~~/src/HOL/Library *)

header "Roots of real quadratics"

theory Quadratic_Discriminant
imports Complex_Main
begin

definition discrim :: "[real,real,real] \<Rightarrow> real" where
  "discrim a b c \<equiv> b\<^sup>2 - 4 * a * c"

lemma complete_square:
  fixes a b c x :: "real"
  assumes "a \<noteq> 0"
  shows "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> (2 * a * x + b)\<^sup>2 = discrim a b c"
proof -
  have "4 * a\<^sup>2 * x\<^sup>2 + 4 * a * b * x + 4 * a * c = 4 * a * (a * x\<^sup>2 + b * x + c)"
    by (simp add: algebra_simps power2_eq_square)
  with `a \<noteq> 0`
  have "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> 4 * a\<^sup>2 * x\<^sup>2 + 4 * a * b * x + 4 * a * c = 0"
    by simp
  thus "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> (2 * a * x + b)\<^sup>2 = discrim a b c"
    unfolding discrim_def
    by (simp add: power2_eq_square algebra_simps)
qed

lemma discriminant_negative:
  fixes a b c x :: real
  assumes "a \<noteq> 0"
  and "discrim a b c < 0"
  shows "a * x\<^sup>2 + b * x + c \<noteq> 0"
proof -
  have "(2 * a * x + b)\<^sup>2 \<ge> 0" by simp
  with `discrim a b c < 0` have "(2 * a * x + b)\<^sup>2 \<noteq> discrim a b c" by arith
  with complete_square and `a \<noteq> 0` show "a * x\<^sup>2 + b * x + c \<noteq> 0" by simp
qed

lemma plus_or_minus_sqrt:
  fixes x y :: real
  assumes "y \<ge> 0"
  shows "x\<^sup>2 = y \<longleftrightarrow> x = sqrt y \<or> x = - sqrt y"
proof
  assume "x\<^sup>2 = y"
  hence "sqrt (x\<^sup>2) = sqrt y" by simp
  hence "sqrt y = \<bar>x\<bar>" by simp
  thus "x = sqrt y \<or> x = - sqrt y" by auto
next
  assume "x = sqrt y \<or> x = - sqrt y"
  hence "x\<^sup>2 = (sqrt y)\<^sup>2 \<or> x\<^sup>2 = (- sqrt y)\<^sup>2" by auto
  with `y \<ge> 0` show "x\<^sup>2 = y" by simp
qed

lemma divide_non_zero:
  fixes x y z :: real
  assumes "x \<noteq> 0"
  shows "x * y = z \<longleftrightarrow> y = z / x"
proof
  assume "x * y = z"
  with `x \<noteq> 0` show "y = z / x" by (simp add: field_simps)
next
  assume "y = z / x"
  with `x \<noteq> 0` show "x * y = z" by simp
qed

lemma discriminant_nonneg:
  fixes a b c x :: real
  assumes "a \<noteq> 0"
  and "discrim a b c \<ge> 0"
  shows "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow>
  x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
  x = (-b - sqrt (discrim a b c)) / (2 * a)"
proof -
  from complete_square and plus_or_minus_sqrt and assms
  have "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow>
    (2 * a) * x + b = sqrt (discrim a b c) \<or>
    (2 * a) * x + b = - sqrt (discrim a b c)"
    by simp
  also have "\<dots> \<longleftrightarrow> (2 * a) * x = (-b + sqrt (discrim a b c)) \<or>
    (2 * a) * x = (-b - sqrt (discrim a b c))"
    by auto
  also from `a \<noteq> 0` and divide_non_zero [of "2 * a" x]
  have "\<dots> \<longleftrightarrow> x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
    x = (-b - sqrt (discrim a b c)) / (2 * a)"
    by simp
  finally show "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow>
    x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
    x = (-b - sqrt (discrim a b c)) / (2 * a)" .
qed

lemma discriminant_zero:
  fixes a b c x :: real
  assumes "a \<noteq> 0"
  and "discrim a b c = 0"
  shows "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> x = -b / (2 * a)"
  using discriminant_nonneg and assms
  by simp

theorem discriminant_iff:
  fixes a b c x :: real
  assumes "a \<noteq> 0"
  shows "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow>
  discrim a b c \<ge> 0 \<and>
  (x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
  x = (-b - sqrt (discrim a b c)) / (2 * a))"
proof
  assume "a * x\<^sup>2 + b * x + c = 0"
  with discriminant_negative and `a \<noteq> 0` have "\<not>(discrim a b c < 0)" by auto
  hence "discrim a b c \<ge> 0" by simp
  with discriminant_nonneg and `a * x\<^sup>2 + b * x + c = 0` and `a \<noteq> 0`
  have "x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
    x = (-b - sqrt (discrim a b c)) / (2 * a)"
    by simp
  with `discrim a b c \<ge> 0`
  show "discrim a b c \<ge> 0 \<and>
    (x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
    x = (-b - sqrt (discrim a b c)) / (2 * a))" ..
next
  assume "discrim a b c \<ge> 0 \<and>
    (x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
    x = (-b - sqrt (discrim a b c)) / (2 * a))"
  hence "discrim a b c \<ge> 0" and
    "x = (-b + sqrt (discrim a b c)) / (2 * a) \<or>
    x = (-b - sqrt (discrim a b c)) / (2 * a)"
    by simp_all
  with discriminant_nonneg and `a \<noteq> 0` show "a * x\<^sup>2 + b * x + c = 0" by simp
qed

lemma discriminant_nonneg_ex:
  fixes a b c :: real
  assumes "a \<noteq> 0"
  and "discrim a b c \<ge> 0"
  shows "\<exists> x. a * x\<^sup>2 + b * x + c = 0"
  using discriminant_nonneg and assms
  by auto

lemma discriminant_pos_ex:
  fixes a b c :: real
  assumes "a \<noteq> 0"
  and "discrim a b c > 0"
  shows "\<exists> x y. x \<noteq> y \<and> a * x\<^sup>2 + b * x + c = 0 \<and> a * y\<^sup>2 + b * y + c = 0"
proof -
  let ?x = "(-b + sqrt (discrim a b c)) / (2 * a)"
  let ?y = "(-b - sqrt (discrim a b c)) / (2 * a)"
  from `discrim a b c > 0` have "sqrt (discrim a b c) \<noteq> 0" by simp
  hence "sqrt (discrim a b c) \<noteq> - sqrt (discrim a b c)" by arith
  with `a \<noteq> 0` have "?x \<noteq> ?y" by simp
  moreover
  from discriminant_nonneg [of a b c ?x]
    and discriminant_nonneg [of a b c ?y]
    and assms
  have "a * ?x\<^sup>2 + b * ?x + c = 0" and "a * ?y\<^sup>2 + b * ?y + c = 0" by simp_all
  ultimately
  show "\<exists> x y. x \<noteq> y \<and> a * x\<^sup>2 + b * x + c = 0 \<and> a * y\<^sup>2 + b * y + c = 0" by blast
qed

lemma discriminant_pos_distinct:
  fixes a b c x :: real
  assumes "a \<noteq> 0" and "discrim a b c > 0"
  shows "\<exists> y. x \<noteq> y \<and> a * y\<^sup>2 + b * y + c = 0"
proof -
  from discriminant_pos_ex and `a \<noteq> 0` and `discrim a b c > 0`
  obtain w and z where "w \<noteq> z"
    and "a * w\<^sup>2 + b * w + c = 0" and "a * z\<^sup>2 + b * z + c = 0"
    by blast
  show "\<exists> y. x \<noteq> y \<and> a * y\<^sup>2 + b * y + c = 0"
  proof cases
    assume "x = w"
    with `w \<noteq> z` have "x \<noteq> z" by simp
    with `a * z\<^sup>2 + b * z + c = 0`
    show "\<exists> y. x \<noteq> y \<and> a * y\<^sup>2 + b * y + c = 0" by auto
  next
    assume "x \<noteq> w"
    with `a * w\<^sup>2 + b * w + c = 0`
    show "\<exists> y. x \<noteq> y \<and> a * y\<^sup>2 + b * y + c = 0" by auto
  qed
qed

end